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         setChanged >> 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 -- Creates a transformation that substitutes the given binder with the given
 166 -- expression (This can be a type variable, replace by a Type expression). All
 167 -- value binders in the expression are cloned before the replacement, to
 168 -- guarantee uniqueness.
 169 substitute :: CoreBndr -> CoreExpr -> Transform
 170 -- Use CoreSubst to subst a type var in a type
 171 substitute find (Type repl_ty) (Type ty) = do
 172   let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty
 173   let ty' = CoreSubst.substTy subst ty
 174   return (Type ty')
 175 -- Use CoreSubst to subst a type var in the type annotation of a case
 176 substitute find repl@(Type repl_ty) (Case scrut bndr ty alts) = do
 177   let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty
 178   let ty' = CoreSubst.substTy subst ty
 179   -- And continue with substituting on all subexpressions of the case
 180   subeverywhere (substitute find repl) (Case scrut bndr ty' alts)
 181 -- If we see the var to find, replace it by a uniqued version of repl
 182 substitute find repl (Var var) | find == var = do
 183   setChanged >> (Trans.lift $ CoreTools.genUniques repl)
 184
 185 -- For all other expressions, just look in subexpressions
 186 substitute find repl expr = subeverywhere (substitute find repl) expr
 187
 188 -- Is the given expression representable at runtime, based on the type?
 189 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 190 isRepr tything = case CoreTools.getType tything of
 191   Nothing -> return False
 192   Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
 193
 194 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 195 is_local_var (CoreSyn.Var v) = do
 196   bndrs <- getGlobalBinders
 197   return $ not $ v `elem` bndrs
 198 is_local_var _ = return False
 199
 200 -- Is the given binder defined by the user?
 201 isUserDefined :: CoreSyn.CoreBndr -> Bool
 202 -- System names are certain to not be user defined
 203 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 204 -- Check a list of typical compiler-defined names
 205 isUserDefined bndr = str `elem` compiler_names
 206   where
 207     str = Name.getOccString bndr
 208     -- These are names of bindings usually generated by the compiler. For some
 209     -- reason these are not marked as system, probably because the name itself
 210     -- is not made up by the compiler, just this particular binding is.
 211     compiler_names = ["fromInteger"]
 212
 213 -- Is the given binder normalizable? This means that its type signature can be
 214 -- represented in hardware, which should (?) guarantee that it can be made
 215 -- into hardware. Note that if a binder is not normalizable, it might become
 216 -- so using argument propagation.
 217 isNormalizeable :: CoreBndr -> TransformMonad Bool
 218 isNormalizeable bndr = do
 219   let ty = Id.idType bndr
 220   let (arg_tys, res_ty) = Type.splitFunTys ty
 221   -- This function is normalizable if all its arguments and return value are
 222   -- representable.
 223   andM $ mapM isRepr (res_ty:arg_tys)