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 do
 140         -- Substitute the binding in res and return that
 141         res' <- substitute_clone bndr expr' res
 142         change res'
 143       else
 144         -- Don't change this let
 145         return expr
 146 -- Leave all other expressions unchanged
 147 inlinebind _ expr = return expr
 148
 149 -- Sets the changed flag in the TransformMonad, to signify that some
 150 -- transform has changed the result
 151 setChanged :: TransformMonad ()
 152 setChanged = Writer.tell (Monoid.Any True)
 153
 154 -- Sets the changed flag and returns the given value.
 155 change :: a -> TransformMonad a
 156 change val = do
 157   setChanged
 158   return val
 159
 160 -- Returns the given value and sets the changed flag if the bool given is
 161 -- True. Note that this will not unset the changed flag if the bool is False.
 162 changeif :: Bool -> a -> TransformMonad a
 163 changeif True val = change val
 164 changeif False val = return val
 165
 166 -- | Creates a transformation that substitutes the given binder with the given
 167 -- expression (This can be a type variable, replace by a Type expression).
 168 -- Does not set the changed flag.
 169 substitute :: CoreBndr -> CoreExpr -> Transform
 170 -- Use CoreSubst to subst a type var in an expression
 171 substitute find repl expr = do
 172   let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
 173   return $ CoreSubst.substExpr subst expr
 174
 175 -- | Creates a transformation that substitutes the given binder with the given
 176 -- expression. This does only work for value expressions! All binders in the
 177 -- expression are cloned before the replacement, to guarantee uniqueness.
 178 substitute_clone :: CoreBndr -> CoreExpr -> Transform
 179 -- If we see the var to find, replace it by a uniqued version of repl
 180 substitute_clone find repl (Var var) | find == var = do
 181   repl' <- Trans.lift $ CoreTools.genUniques repl
 182   change repl'
 183
 184 -- For all other expressions, just look in subexpressions
 185 substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
 186
 187 -- Is the given expression representable at runtime, based on the type?
 188 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 189 isRepr tything = case CoreTools.getType tything of
 190   Nothing -> return False
 191   Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
 192
 193 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 194 is_local_var (CoreSyn.Var v) = do
 195   bndrs <- getGlobalBinders
 196   return $ not $ v `elem` bndrs
 197 is_local_var _ = return False
 198
 199 -- Is the given binder defined by the user?
 200 isUserDefined :: CoreSyn.CoreBndr -> Bool
 201 -- System names are certain to not be user defined
 202 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 203 -- Check a list of typical compiler-defined names
 204 isUserDefined bndr = not $ str `elem` compiler_names
 205   where
 206     str = Name.getOccString bndr
 207     -- These are names of bindings usually generated by the compiler. For some
 208     -- reason these are not marked as system, probably because the name itself
 209     -- is not made up by the compiler, just this particular binding is.
 210     compiler_names = ["fromInteger"]
 211
 212 -- Is the given binder normalizable? This means that its type signature can be
 213 -- represented in hardware, which should (?) guarantee that it can be made
 214 -- into hardware. Note that if a binder is not normalizable, it might become
 215 -- so using argument propagation.
 216 isNormalizeable :: CoreBndr -> TransformMonad Bool
 217 isNormalizeable bndr = do
 218   let ty = Id.idType bndr
 219   let (arg_tys, res_ty) = Type.splitFunTys ty
 220   -- This function is normalizable if all its arguments and return value are
 221   -- representable.
 222   andM $ mapM isRepr (res_ty:arg_tys)