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.VHDL.Constants (builtinIds)
  28 import CLasH.Utils
  29 import qualified CLasH.Utils.Core.CoreTools as CoreTools
  30 import qualified CLasH.VHDL.VHDLTools as VHDLTools
  31
  32 -- Apply the given transformation to all expressions in the given expression,
  33 -- including the expression itself.
  34 everywhere :: (String, Transform) -> Transform
  35 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  36
  37 -- Apply the first transformation, followed by the second transformation, and
  38 -- keep applying both for as long as expression still changes.
  39 applyboth :: Transform -> (String, Transform) -> Transform
  40 applyboth first (name, second) context expr = do
  41   -- Apply the first
  42   expr' <- first context expr
  43   -- Apply the second
  44   (expr'', changed) <- Writer.listen $ second context expr'
  45   if Monoid.getAny $
  46         -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n")
  47         changed
  48     then
  49      -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
  50      --        ++ "Context: " ++ show context ++ "\n"
  51      --        ++ "Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
  52       do
  53         Trans.lift $ MonadState.modify tsTransformCounter (+1)
  54         applyboth first (name, second) context expr''
  55     else
  56       -- trace ("No changes") $
  57       return expr''
  58
  59 -- Apply the given transformation to all direct subexpressions (only), not the
  60 -- expression itself.
  61 subeverywhere :: Transform -> Transform
  62 subeverywhere trans c (App a b) = do
  63   a' <- trans (AppFirst:c) a
  64   b' <- trans (AppSecond:c) b
  65   return $ App a' b'
  66
  67 subeverywhere trans c (Let (NonRec b bexpr) expr) = do
  68   bexpr' <- trans (LetBinding:c) bexpr
  69   expr' <- trans (LetBody:c) expr
  70   return $ Let (NonRec b bexpr') expr'
  71
  72 subeverywhere trans c (Let (Rec binds) expr) = do
  73   expr' <- trans (LetBody:c) expr
  74   binds' <- mapM transbind binds
  75   return $ Let (Rec binds') expr'
  76   where
  77     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  78     transbind (b, e) = do
  79       e' <- trans (LetBinding:c) e
  80       return (b, e')
  81
  82 subeverywhere trans c (Lam x expr) = do
  83   expr' <- trans (LambdaBody:c) expr
  84   return $ Lam x expr'
  85
  86 subeverywhere trans c (Case scrut b t alts) = do
  87   scrut' <- trans (Other:c) scrut
  88   alts' <- mapM transalt alts
  89   return $ Case scrut' b t alts'
  90   where
  91     transalt :: CoreAlt -> TransformMonad CoreAlt
  92     transalt (con, binders, expr) = do
  93       expr' <- trans (Other:c) expr
  94       return (con, binders, expr')
  95
  96 subeverywhere trans c (Var x) = return $ Var x
  97 subeverywhere trans c (Lit x) = return $ Lit x
  98 subeverywhere trans c (Type x) = return $ Type x
  99
 100 subeverywhere trans c (Cast expr ty) = do
 101   expr' <- trans (Other:c) expr
 102   return $ Cast expr' ty
 103
 104 subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 105
 106 -- Runs each of the transforms repeatedly inside the State monad.
 107 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
 108 dotransforms transs expr = do
 109   (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> trans [] e) expr transs
 110   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 111
 112 -- Inline all let bindings that satisfy the given condition
 113 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 114 inlinebind condition context expr@(Let (NonRec bndr expr') res) = do
 115     applies <- condition (bndr, expr')
 116     if applies
 117       then do
 118         -- Substitute the binding in res and return that
 119         res' <- substitute_clone bndr expr' context res
 120         change res'
 121       else
 122         -- Don't change this let
 123         return expr
 124 -- Leave all other expressions unchanged
 125 inlinebind _ context expr = return expr
 126
 127 -- Sets the changed flag in the TransformMonad, to signify that some
 128 -- transform has changed the result
 129 setChanged :: TransformMonad ()
 130 setChanged = Writer.tell (Monoid.Any True)
 131
 132 -- Sets the changed flag and returns the given value.
 133 change :: a -> TransformMonad a
 134 change val = do
 135   setChanged
 136   return val
 137
 138 -- Returns the given value and sets the changed flag if the bool given is
 139 -- True. Note that this will not unset the changed flag if the bool is False.
 140 changeif :: Bool -> a -> TransformMonad a
 141 changeif True val = change val
 142 changeif False val = return val
 143
 144 -- | Creates a transformation that substitutes the given binder with the given
 145 -- expression (This can be a type variable, replace by a Type expression).
 146 -- Does not set the changed flag.
 147 substitute :: CoreBndr -> CoreExpr -> Transform
 148 -- Use CoreSubst to subst a type var in an expression
 149 substitute find repl context expr = do
 150   let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
 151   return $ CoreSubst.substExpr subst expr
 152
 153 -- | Creates a transformation that substitutes the given binder with the given
 154 -- expression. This does only work for value expressions! All binders in the
 155 -- expression are cloned before the replacement, to guarantee uniqueness.
 156 substitute_clone :: CoreBndr -> CoreExpr -> Transform
 157 -- If we see the var to find, replace it by a uniqued version of repl
 158 substitute_clone find repl context (Var var) | find == var = do
 159   repl' <- Trans.lift $ CoreTools.genUniques repl
 160   change repl'
 161
 162 -- For all other expressions, just look in subexpressions
 163 substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
 164
 165 -- Is the given expression representable at runtime, based on the type?
 166 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 167 isRepr tything = Trans.lift (isRepr' tything)
 168
 169 isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
 170 isRepr' tything = case CoreTools.getType tything of
 171   Nothing -> return False
 172   Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
 173
 174 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 175 is_local_var (CoreSyn.Var v) = do
 176   bndrs <- getGlobalBinders
 177   return $ v `notElem` bndrs
 178 is_local_var _ = return False
 179
 180 -- Is the given binder defined by the user?
 181 isUserDefined :: CoreSyn.CoreBndr -> Bool
 182 -- System names are certain to not be user defined
 183 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 184 -- Builtin functions are usually not user-defined either (and would
 185 -- break currently if they are...)
 186 isUserDefined bndr = str `notElem` builtinIds
 187   where
 188     str = Name.getOccString bndr
 189
 190 -- Is the given binder normalizable? This means that its type signature can be
 191 -- represented in hardware, which should (?) guarantee that it can be made
 192 -- into hardware. Note that if a binder is not normalizable, it might become
 193 -- so using argument propagation.
 194 isNormalizeable :: CoreBndr -> TransformMonad Bool
 195 isNormalizeable bndr = Trans.lift (isNormalizeable' bndr)
 196
 197 isNormalizeable' :: CoreBndr -> TranslatorSession Bool
 198 isNormalizeable' bndr = do
 199   let ty = Id.idType bndr
 200   let (arg_tys, res_ty) = Type.splitFunTys ty
 201   -- This function is normalizable if all its arguments and return value are
 202   -- representable.
 203   andM $ mapM isRepr' (res_ty:arg_tys)