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 qualified Data.Monoid as Monoid
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Monad.Trans.Writer as Writer
  11 import qualified "transformers" Control.Monad.Trans as Trans
  12 import qualified Data.Accessor.Monad.Trans.State as MonadState
  13 -- import Debug.Trace
  14
  15 -- GHC API
  16 import CoreSyn
  17 import qualified Name
  18 import qualified Id
  19 import qualified CoreSubst
  20 import qualified Type
  21 -- import qualified CoreUtils
  22 -- import Outputable ( showSDoc, ppr, nest )
  23
  24 -- Local imports
  25 import CLasH.Normalize.NormalizeTypes
  26 import CLasH.Translator.TranslatorTypes
  27 import CLasH.Utils
  28 import qualified CLasH.Utils.Core.CoreTools as CoreTools
  29 import qualified CLasH.VHDL.VHDLTools as VHDLTools
  30
  31 -- Apply the given transformation to all expressions in the given expression,
  32 -- including the expression itself.
  33 everywhere :: (String, Transform) -> Transform
  34 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  35
  36 -- Apply the first transformation, followed by the second transformation, and
  37 -- keep applying both for as long as expression still changes.
  38 applyboth :: Transform -> (String, Transform) -> Transform
  39 applyboth first (name, second) expr = do
  40   -- Apply the first
  41   expr' <- first expr
  42   -- Apply the second
  43   (expr'', changed) <- Writer.listen $ second expr'
  44   if Monoid.getAny $
  45         -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n")
  46         changed
  47     then
  48      -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
  49      -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
  50       applyboth first (name, second)
  51         expr''
  52     else
  53       -- trace ("No changes") $
  54       return expr''
  55
  56 -- Apply the given transformation to all direct subexpressions (only), not the
  57 -- expression itself.
  58 subeverywhere :: Transform -> Transform
  59 subeverywhere trans (App a b) = do
  60   a' <- trans a
  61   b' <- trans b
  62   return $ App a' b'
  63
  64 subeverywhere trans (Let (NonRec b bexpr) expr) = do
  65   bexpr' <- trans bexpr
  66   expr' <- trans expr
  67   return $ Let (NonRec b bexpr') expr'
  68
  69 subeverywhere trans (Let (Rec binds) expr) = do
  70   expr' <- trans expr
  71   binds' <- mapM transbind binds
  72   return $ Let (Rec binds') expr'
  73   where
  74     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  75     transbind (b, e) = do
  76       e' <- trans e
  77       return (b, e')
  78
  79 subeverywhere trans (Lam x expr) = do
  80   expr' <- trans expr
  81   return $ Lam x expr'
  82
  83 subeverywhere trans (Case scrut b t alts) = do
  84   scrut' <- trans scrut
  85   alts' <- mapM transalt alts
  86   return $ Case scrut' b t alts'
  87   where
  88     transalt :: CoreAlt -> TransformMonad CoreAlt
  89     transalt (con, binders, expr) = do
  90       expr' <- trans expr
  91       return (con, binders, expr')
  92
  93 subeverywhere trans (Var x) = return $ Var x
  94 subeverywhere trans (Lit x) = return $ Lit x
  95 subeverywhere trans (Type x) = return $ Type x
  96
  97 subeverywhere trans (Cast expr ty) = do
  98   expr' <- trans expr
  99   return $ Cast expr' ty
 100
 101 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 102
 103 -- Apply the given transformation to all expressions, except for direct
 104 -- arguments of an application
 105 notappargs :: (String, Transform) -> Transform
 106 notappargs trans = applyboth (subnotappargs trans) trans
 107
 108 -- Apply the given transformation to all (direct and indirect) subexpressions
 109 -- (but not the expression itself), except for direct arguments of an
 110 -- application
 111 subnotappargs :: (String, Transform) -> Transform
 112 subnotappargs trans (App a b) = do
 113   a' <- subnotappargs trans a
 114   b' <- subnotappargs trans b
 115   return $ App a' b'
 116
 117 -- Let subeverywhere handle all other expressions
 118 subnotappargs trans expr = subeverywhere (notappargs trans) expr
 119
 120 -- Runs each of the transforms repeatedly inside the State monad.
 121 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
 122 dotransforms transs expr = do
 123   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
 124   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 125
 126 -- Inline all let bindings that satisfy the given condition
 127 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 128 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
 129     applies <- condition (bndr, expr')
 130     if applies
 131       then do
 132         -- Substitute the binding in res and return that
 133         res' <- substitute_clone bndr expr' res
 134         change res'
 135       else
 136         -- Don't change this let
 137         return expr
 138 -- Leave all other expressions unchanged
 139 inlinebind _ expr = return expr
 140
 141 -- Sets the changed flag in the TransformMonad, to signify that some
 142 -- transform has changed the result
 143 setChanged :: TransformMonad ()
 144 setChanged = Writer.tell (Monoid.Any True)
 145
 146 -- Sets the changed flag and returns the given value.
 147 change :: a -> TransformMonad a
 148 change val = do
 149   setChanged
 150   return val
 151
 152 -- Returns the given value and sets the changed flag if the bool given is
 153 -- True. Note that this will not unset the changed flag if the bool is False.
 154 changeif :: Bool -> a -> TransformMonad a
 155 changeif True val = change val
 156 changeif False val = return val
 157
 158 -- | Creates a transformation that substitutes the given binder with the given
 159 -- expression (This can be a type variable, replace by a Type expression).
 160 -- Does not set the changed flag.
 161 substitute :: CoreBndr -> CoreExpr -> Transform
 162 -- Use CoreSubst to subst a type var in an expression
 163 substitute find repl expr = do
 164   let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
 165   return $ CoreSubst.substExpr subst expr
 166
 167 -- | Creates a transformation that substitutes the given binder with the given
 168 -- expression. This does only work for value expressions! All binders in the
 169 -- expression are cloned before the replacement, to guarantee uniqueness.
 170 substitute_clone :: CoreBndr -> CoreExpr -> Transform
 171 -- If we see the var to find, replace it by a uniqued version of repl
 172 substitute_clone find repl (Var var) | find == var = do
 173   repl' <- Trans.lift $ CoreTools.genUniques repl
 174   change repl'
 175
 176 -- For all other expressions, just look in subexpressions
 177 substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
 178
 179 -- Is the given expression representable at runtime, based on the type?
 180 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 181 isRepr tything = Trans.lift (isRepr' tything)
 182
 183 isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
 184 isRepr' tything = case CoreTools.getType tything of
 185   Nothing -> return False
 186   Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
 187
 188 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 189 is_local_var (CoreSyn.Var v) = do
 190   bndrs <- getGlobalBinders
 191   return $ v `notElem` bndrs
 192 is_local_var _ = return False
 193
 194 -- Is the given binder defined by the user?
 195 isUserDefined :: CoreSyn.CoreBndr -> Bool
 196 -- System names are certain to not be user defined
 197 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 198 -- Check a list of typical compiler-defined names
 199 isUserDefined bndr = str `notElem` (compiler_names ++ builtin_names)
 200   where
 201     str = Name.getOccString bndr
 202     -- These are names of bindings usually generated by the compiler. For some
 203     -- reason these are not marked as system, probably because the name itself
 204     -- is not made up by the compiler, just this particular binding is.
 205     compiler_names = ["fromInteger"]
 206     builtin_names = [ "!", "replace", "head", "last", "tail", "take", "drop"
 207                     , "select", "+>", "<+", "++", "map", "zipWith", "foldl"
 208                     , "foldr", "zip", "unzip", "shiftl", "shiftr", "rotl"
 209                     , "rotr", "concat", "reverse", "iteraten", "iterate"
 210                     , "generaten", "generate", "empty", "singleton", "copyn"
 211                     , "copy", "lengthT", "null", "hwxor", "hwand", "hwor"
 212                     , "hwnot", "not", "+", "*", "-", "fromSizedWord"
 213                     , "resizeWord", "resizeInt", "fst", "snd", "blockRAM"
 214                     , "split", "==", "/="
 215                     ]
 216
 217     -- , (ltId             , (2, genOperator2 (AST.:<:)  ) )
 218     -- , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
 219     -- , (gtId             , (2, genOperator2 (AST.:>:)  ) )
 220     -- , (gteqId           , (2, genOperator2 (AST.:>=:) ) )
 221     -- , (boolOrId         , (2, genOperator2 AST.Or     ) )
 222     -- , (boolAndId        , (2, genOperator2 AST.And    ) )
 223     -- , (negateId         , (1, genNegation             ) )
 224     -- , (sizedIntId       , (1, genSizedInt             ) )
 225     -- , (smallIntegerId   , (1, genFromInteger          ) )
 226
 227 -- Is the given binder normalizable? This means that its type signature can be
 228 -- represented in hardware, which should (?) guarantee that it can be made
 229 -- into hardware. Note that if a binder is not normalizable, it might become
 230 -- so using argument propagation.
 231 isNormalizeable :: CoreBndr -> TransformMonad Bool
 232 isNormalizeable bndr = Trans.lift (isNormalizeable' bndr)
 233
 234 isNormalizeable' :: CoreBndr -> TranslatorSession Bool
 235 isNormalizeable' bndr = do
 236   let ty = Id.idType bndr
 237   let (arg_tys, res_ty) = Type.splitFunTys ty
 238   -- This function is normalizable if all its arguments and return value are
 239   -- representable.
 240   andM $ mapM isRepr' (res_ty:arg_tys)