cλash/CLasH/Normalize/NormalizeTools.hs

   1 {-# LANGUAGE PackageImports #-}
   2 --
   3 -- This module provides functions for program transformations.
   4 --
   5 module CLasH.Normalize.NormalizeTools where
   6
   7 -- Standard modules
   8 import Debug.Trace
   9 import qualified List
  10 import qualified Data.Monoid as Monoid
  11 import qualified Data.Either as Either
  12 import qualified Control.Arrow as Arrow
  13 import qualified Control.Monad as Monad
  14 import qualified Control.Monad.Trans.State as State
  15 import qualified Control.Monad.Trans.Writer as Writer
  16 import qualified "transformers" Control.Monad.Trans as Trans
  17 import qualified Data.Map as Map
  18 import Data.Accessor
  19 import Data.Accessor.MonadState as MonadState
  20
  21 -- GHC API
  22 import CoreSyn
  23 import qualified Name
  24 import qualified Id
  25 import qualified CoreSubst
  26 import qualified CoreUtils
  27 import qualified Type
  28 import Outputable ( showSDoc, ppr, nest )
  29
  30 -- Local imports
  31 import CLasH.Normalize.NormalizeTypes
  32 import CLasH.Translator.TranslatorTypes
  33 import CLasH.Utils
  34 import CLasH.Utils.Pretty
  35 import qualified CLasH.Utils.Core.CoreTools as CoreTools
  36 import CLasH.VHDL.VHDLTypes
  37 import qualified CLasH.VHDL.VHDLTools as VHDLTools
  38
  39 -- Apply the given transformation to all expressions in the given expression,
  40 -- including the expression itself.
  41 everywhere :: (String, Transform) -> Transform
  42 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  43
  44 -- Apply the first transformation, followed by the second transformation, and
  45 -- keep applying both for as long as expression still changes.
  46 applyboth :: Transform -> (String, Transform) -> Transform
  47 applyboth first (name, second) expr  = do
  48   -- Apply the first
  49   expr' <- first expr
  50   -- Apply the second
  51   (expr'', changed) <- Writer.listen $ second expr'
  52   if Monoid.getAny $
  53 --        trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
  54         changed
  55     then
  56 --      trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
  57 --      trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
  58       applyboth first (name, second) $
  59         expr''
  60     else
  61 --      trace ("No changes") $
  62       return expr''
  63
  64 -- Apply the given transformation to all direct subexpressions (only), not the
  65 -- expression itself.
  66 subeverywhere :: Transform -> Transform
  67 subeverywhere trans (App a b) = do
  68   a' <- trans a
  69   b' <- trans b
  70   return $ App a' b'
  71
  72 subeverywhere trans (Let (NonRec b bexpr) expr) = do
  73   bexpr' <- trans bexpr
  74   expr' <- trans expr
  75   return $ Let (NonRec b bexpr') expr'
  76
  77 subeverywhere trans (Let (Rec binds) expr) = do
  78   expr' <- trans expr
  79   binds' <- mapM transbind binds
  80   return $ Let (Rec binds') expr'
  81   where
  82     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  83     transbind (b, e) = do
  84       e' <- trans e
  85       return (b, e')
  86
  87 subeverywhere trans (Lam x expr) = do
  88   expr' <- trans expr
  89   return $ Lam x expr'
  90
  91 subeverywhere trans (Case scrut b t alts) = do
  92   scrut' <- trans scrut
  93   alts' <- mapM transalt alts
  94   return $ Case scrut' b t alts'
  95   where
  96     transalt :: CoreAlt -> TransformMonad CoreAlt
  97     transalt (con, binders, expr) = do
  98       expr' <- trans expr
  99       return (con, binders, expr')
 100
 101 subeverywhere trans (Var x) = return $ Var x
 102 subeverywhere trans (Lit x) = return $ Lit x
 103 subeverywhere trans (Type x) = return $ Type x
 104
 105 subeverywhere trans (Cast expr ty) = do
 106   expr' <- trans expr
 107   return $ Cast expr' ty
 108
 109 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 110
 111 -- Apply the given transformation to all expressions, except for direct
 112 -- arguments of an application
 113 notappargs :: (String, Transform) -> Transform
 114 notappargs trans = applyboth (subnotappargs trans) trans
 115
 116 -- Apply the given transformation to all (direct and indirect) subexpressions
 117 -- (but not the expression itself), except for direct arguments of an
 118 -- application
 119 subnotappargs :: (String, Transform) -> Transform
 120 subnotappargs trans (App a b) = do
 121   a' <- subnotappargs trans a
 122   b' <- subnotappargs trans b
 123   return $ App a' b'
 124
 125 -- Let subeverywhere handle all other expressions
 126 subnotappargs trans expr = subeverywhere (notappargs trans) expr
 127
 128 -- Runs each of the transforms repeatedly inside the State monad.
 129 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
 130 dotransforms transs expr = do
 131   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
 132   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 133
 134 -- Inline all let bindings that satisfy the given condition
 135 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 136 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
 137     applies <- condition (bndr, expr')
 138     if applies
 139       then
 140         -- Substitute the binding in res and return that
 141         change $ substitute [(bndr, expr')] res
 142       else
 143         -- Don't change this let
 144         return expr
 145 -- Leave all other expressions unchanged
 146 inlinebind _ expr = return expr
 147
 148 -- Sets the changed flag in the TransformMonad, to signify that some
 149 -- transform has changed the result
 150 setChanged :: TransformMonad ()
 151 setChanged = Writer.tell (Monoid.Any True)
 152
 153 -- Sets the changed flag and returns the given value.
 154 change :: a -> TransformMonad a
 155 change val = do
 156   setChanged
 157   return val
 158
 159 -- Returns the given value and sets the changed flag if the bool given is
 160 -- True. Note that this will not unset the changed flag if the bool is False.
 161 changeif :: Bool -> a -> TransformMonad a
 162 changeif True val = change val
 163 changeif False val = return val
 164
 165 -- Replace each of the binders given with the coresponding expressions in the
 166 -- given expression.
 167 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
 168 substitute [] expr = expr
 169 -- Apply one substitution on the expression, but also on any remaining
 170 -- substitutions. This seems to be the only way to handle substitutions like
 171 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
 172 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
 173 -- TODO: Find out how this works, exactly.
 174 substitute ((b, e):subss) expr = substitute subss' expr'
 175   where
 176     -- Create the Subst
 177     subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
 178     -- Apply this substitution to the main expression
 179     expr' = CoreSubst.substExpr subs expr
 180     -- Apply this substitution on all the expressions in the remaining
 181     -- substitutions
 182     subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
 183
 184 -- Is the given expression representable at runtime, based on the type?
 185 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 186 isRepr tything = case CoreTools.getType tything of
 187   Nothing -> return False
 188   Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
 189
 190 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 191 is_local_var (CoreSyn.Var v) = do
 192   bndrs <- getGlobalBinders
 193   return $ not $ v `elem` bndrs
 194 is_local_var _ = return False
 195
 196 -- Is the given binder defined by the user?
 197 isUserDefined :: CoreSyn.CoreBndr -> Bool
 198 -- System names are certain to not be user defined
 199 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 200 -- Check a list of typical compiler-defined names
 201 isUserDefined bndr = str `elem` compiler_names
 202   where
 203     str = Name.getOccString bndr
 204     -- These are names of bindings usually generated by the compiler. For some
 205     -- reason these are not marked as system, probably because the name itself
 206     -- is not made up by the compiler, just this particular binding is.
 207     compiler_names = ["fromInteger"]
 208
 209 -- Is the given binder normalizable? This means that its type signature can be
 210 -- represented in hardware, which should (?) guarantee that it can be made
 211 -- into hardware. Note that if a binder is not normalizable, it might become
 212 -- so using argument propagation.
 213 isNormalizeable :: CoreBndr -> TransformMonad Bool
 214 isNormalizeable bndr = do
 215   let ty = Id.idType bndr
 216   let (arg_tys, res_ty) = Type.splitFunTys ty
 217   -- This function is normalizable if all its arguments and return value are
 218   -- representable.
 219   andM $ mapM isRepr (res_ty:arg_tys)