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 Data.Either as Either
  10 import qualified Control.Monad as Monad
  11 import qualified Control.Monad.Trans.Writer as Writer
  12 import qualified "transformers" Control.Monad.Trans as Trans
  13 import qualified Data.Accessor.Monad.Trans.State as MonadState
  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 :: Transform -> Transform
  35 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  36
  37 data NormDbgLevel =
  38     NormDbgNone         -- ^ No debugging
  39   | NormDbgFinal        -- ^ Print functions before / after normalization
  40   | NormDbgApplied      -- ^ Print expressions before / after applying transformations
  41   | NormDbgAll          -- ^ Print expressions when a transformation does not apply
  42   deriving (Eq, Ord)
  43 normalize_debug = NormDbgFinal
  44
  45 -- Applies a transform, optionally showing some debug output.
  46 apply :: (String, Transform) -> Transform
  47 apply (name, trans) ctx expr =  do
  48     -- Apply the transformation and find out if it changed anything
  49     (expr', any_changed) <- Writer.listen $ trans ctx expr
  50     let changed = Monoid.getAny any_changed
  51     -- If it changed, increase the transformation counter
  52     Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
  53     -- Prepare some debug strings
  54     let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
  55     let context = "Context: " ++ show ctx ++ "\n"
  56     let after  = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
  57     traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $
  58      traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before  ++ context) $
  59      return expr'
  60
  61 -- Apply the first transformation, followed by the second transformation, and
  62 -- keep applying both for as long as expression still changes.
  63 applyboth :: Transform -> Transform -> Transform
  64 applyboth first second context expr = do
  65   -- Apply the first
  66   expr' <- first context expr
  67   -- Apply the second
  68   (expr'', changed) <- Writer.listen $ second context expr'
  69   if Monoid.getAny $ changed
  70     then
  71       applyboth first second context expr''
  72     else
  73       return expr''
  74
  75 -- Apply the given transformation to all direct subexpressions (only), not the
  76 -- expression itself.
  77 subeverywhere :: Transform -> Transform
  78 subeverywhere trans c (App a b) = do
  79   a' <- trans (AppFirst:c) a
  80   b' <- trans (AppSecond:c) b
  81   return $ App a' b'
  82
  83 subeverywhere trans c (Let (NonRec b bexpr) expr) = do
  84   bexpr' <- trans (LetBinding:c) bexpr
  85   expr' <- trans (LetBody:c) expr
  86   return $ Let (NonRec b bexpr') expr'
  87
  88 subeverywhere trans c (Let (Rec binds) expr) = do
  89   expr' <- trans (LetBody:c) expr
  90   binds' <- mapM transbind binds
  91   return $ Let (Rec binds') expr'
  92   where
  93     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  94     transbind (b, e) = do
  95       e' <- trans (LetBinding:c) e
  96       return (b, e')
  97
  98 subeverywhere trans c (Lam x expr) = do
  99   expr' <- trans (LambdaBody:c) expr
 100   return $ Lam x expr'
 101
 102 subeverywhere trans c (Case scrut b t alts) = do
 103   scrut' <- trans (Other:c) scrut
 104   alts' <- mapM transalt alts
 105   return $ Case scrut' b t alts'
 106   where
 107     transalt :: CoreAlt -> TransformMonad CoreAlt
 108     transalt (con, binders, expr) = do
 109       expr' <- trans (Other:c) expr
 110       return (con, binders, expr')
 111
 112 subeverywhere trans c (Var x) = return $ Var x
 113 subeverywhere trans c (Lit x) = return $ Lit x
 114 subeverywhere trans c (Type x) = return $ Type x
 115
 116 subeverywhere trans c (Cast expr ty) = do
 117   expr' <- trans (Other:c) expr
 118   return $ Cast expr' ty
 119
 120 subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 121
 122 -- Runs each of the transforms repeatedly inside the State monad.
 123 dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
 124 dotransforms transs expr = do
 125   (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs
 126   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 127
 128 -- Inline all let bindings that satisfy the given condition
 129 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 130 inlinebind condition context expr@(Let (Rec binds) res) = do
 131     -- Find all bindings that adhere to the condition
 132     res_eithers <- mapM docond binds
 133     case Either.partitionEithers res_eithers of
 134       -- No replaces? No change
 135       ([], _) -> return expr
 136       (replace, others) -> do
 137         -- Substitute the to be replaced binders with their expression
 138         newexpr <- do_substitute replace (Let (Rec others) res)
 139         change newexpr
 140   where
 141     -- Apply the condition to a let binding and return an Either
 142     -- depending on whether it needs to be inlined or not.
 143     docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
 144     docond b = do
 145       res <- condition b
 146       return $ case res of True -> Left b; False -> Right b
 147
 148     -- Apply the given list of substitutions to the the given expression
 149     do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr
 150     do_substitute [] expr = return expr
 151     do_substitute ((bndr, val):reps) expr = do
 152       -- Perform this substitution in the expression
 153       expr' <- substitute_clone bndr val context expr
 154       -- And in the substitution values we will be using next
 155       reps' <- mapM (subs_bind bndr val) reps
 156       -- And then perform the remaining substitutions
 157       do_substitute reps' expr'
 158
 159     -- Replace the given binder with the given expression in the
 160     -- expression oft the given let binding
 161     subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
 162     subs_bind bndr expr (b, v) = do
 163       v' <- substitute_clone  bndr expr (LetBinding:context) v
 164       return (b, v')
 165
 166
 167 -- Leave all other expressions unchanged
 168 inlinebind _ context expr = return expr
 169
 170 -- Sets the changed flag in the TransformMonad, to signify that some
 171 -- transform has changed the result
 172 setChanged :: TransformMonad ()
 173 setChanged = Writer.tell (Monoid.Any True)
 174
 175 -- Sets the changed flag and returns the given value.
 176 change :: a -> TransformMonad a
 177 change val = do
 178   setChanged
 179   return val
 180
 181 -- Returns the given value and sets the changed flag if the bool given is
 182 -- True. Note that this will not unset the changed flag if the bool is False.
 183 changeif :: Bool -> a -> TransformMonad a
 184 changeif True val = change val
 185 changeif False val = return val
 186
 187 -- | Creates a transformation that substitutes the given binder with the given
 188 -- expression (This can be a type variable, replace by a Type expression).
 189 -- Does not set the changed flag.
 190 substitute :: CoreBndr -> CoreExpr -> Transform
 191 -- Use CoreSubst to subst a type var in an expression
 192 substitute find repl context expr = do
 193   let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
 194   return $ CoreSubst.substExpr subst expr
 195
 196 -- | Creates a transformation that substitutes the given binder with the given
 197 -- expression. This does only work for value expressions! All binders in the
 198 -- expression are cloned before the replacement, to guarantee uniqueness.
 199 substitute_clone :: CoreBndr -> CoreExpr -> Transform
 200 -- If we see the var to find, replace it by a uniqued version of repl
 201 substitute_clone find repl context (Var var) | find == var = do
 202   repl' <- Trans.lift $ CoreTools.genUniques repl
 203   change repl'
 204
 205 -- For all other expressions, just look in subexpressions
 206 substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
 207
 208 -- Is the given expression representable at runtime, based on the type?
 209 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 210 isRepr tything = Trans.lift (isRepr' tything)
 211
 212 isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
 213 isRepr' tything = case CoreTools.getType tything of
 214   Nothing -> return False
 215   Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
 216
 217 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 218 is_local_var (CoreSyn.Var v) = do
 219   bndrs <- getGlobalBinders
 220   return $ v `notElem` bndrs
 221 is_local_var _ = return False
 222
 223 -- Is the given binder defined by the user?
 224 isUserDefined :: CoreSyn.CoreBndr -> Bool
 225 -- System names are certain to not be user defined
 226 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 227 -- Builtin functions are usually not user-defined either (and would
 228 -- break currently if they are...)
 229 isUserDefined bndr = str `notElem` builtinIds
 230   where
 231     str = Name.getOccString bndr
 232
 233 -- | Is the given binder normalizable? This means that its type signature can be
 234 -- represented in hardware, which should (?) guarantee that it can be made
 235 -- into hardware. This checks whether all the arguments and (optionally)
 236 -- the return value are
 237 -- representable.
 238 isNormalizeable ::
 239   Bool -- ^ Allow the result to be unrepresentable?
 240   -> CoreBndr  -- ^ The binder to check
 241   -> TranslatorSession Bool  -- ^ Is it normalizeable?
 242 isNormalizeable result_nonrep bndr = do
 243   let ty = Id.idType bndr
 244   let (arg_tys, res_ty) = Type.splitFunTys ty
 245   let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys)
 246   andM $ mapM isRepr' check_tys