clash/CLasH/Normalize/NormalizeTools.hs

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