--- /dev/null
+--
+-- This module provides functions for program transformations.
+--
+module CLasH.Normalize.NormalizeTools where
+
+-- Standard modules
+import qualified Data.Monoid as Monoid
+import qualified Data.Either as Either
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Trans.Writer as Writer
+import qualified Control.Monad.Trans.Class as Trans
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+
+-- GHC API
+import CoreSyn
+import qualified Name
+import qualified Id
+import qualified CoreSubst
+import qualified Type
+import qualified CoreUtils
+import Outputable ( showSDoc, ppr, nest )
+
+-- Local imports
+import CLasH.Normalize.NormalizeTypes
+import CLasH.Translator.TranslatorTypes
+import CLasH.VHDL.Constants (builtinIds)
+import CLasH.Utils
+import qualified CLasH.Utils.Core.CoreTools as CoreTools
+import qualified CLasH.VHDL.VHDLTools as VHDLTools
+
+-- Apply the given transformation to all expressions in the given expression,
+-- including the expression itself.
+everywhere :: Transform -> Transform
+everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
+
+data NormDbgLevel =
+ NormDbgNone -- ^ No debugging
+ | NormDbgFinal -- ^ Print functions before / after normalization
+ | NormDbgApplied -- ^ Print expressions before / after applying transformations
+ | NormDbgAll -- ^ Print expressions when a transformation does not apply
+ deriving (Eq, Ord)
+normalize_debug = NormDbgFinal
+
+-- Applies a transform, optionally showing some debug output.
+apply :: (String, Transform) -> Transform
+apply (name, trans) ctx expr = do
+ -- Apply the transformation and find out if it changed anything
+ (expr', any_changed) <- Writer.listen $ trans ctx expr
+ let changed = Monoid.getAny any_changed
+ -- If it changed, increase the transformation counter
+ Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1))
+ -- Prepare some debug strings
+ let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n"
+ let context = "Context: " ++ show ctx ++ "\n"
+ let after = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n"
+ traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $
+ traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before ++ context) $
+ return expr'
+
+-- Apply the first transformation, followed by the second transformation, and
+-- keep applying both for as long as expression still changes.
+applyboth :: Transform -> Transform -> Transform
+applyboth first second context expr = do
+ -- Apply the first
+ expr' <- first context expr
+ -- Apply the second
+ (expr'', changed) <- Writer.listen $ second context expr'
+ if Monoid.getAny $ changed
+ then
+ applyboth first second context expr''
+ else
+ return expr''
+
+-- Apply the given transformation to all direct subexpressions (only), not the
+-- expression itself.
+subeverywhere :: Transform -> Transform
+subeverywhere trans c (App a b) = do
+ a' <- trans (AppFirst:c) a
+ b' <- trans (AppSecond:c) b
+ return $ App a' b'
+
+subeverywhere trans c (Let (NonRec b bexpr) expr) = do
+ bexpr' <- trans (LetBinding:c) bexpr
+ expr' <- trans (LetBody:c) expr
+ return $ Let (NonRec b bexpr') expr'
+
+subeverywhere trans c (Let (Rec binds) expr) = do
+ expr' <- trans (LetBody:c) expr
+ binds' <- mapM transbind binds
+ return $ Let (Rec binds') expr'
+ where
+ transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ transbind (b, e) = do
+ e' <- trans (LetBinding:c) e
+ return (b, e')
+
+subeverywhere trans c (Lam x expr) = do
+ expr' <- trans (LambdaBody:c) expr
+ return $ Lam x expr'
+
+subeverywhere trans c (Case scrut b t alts) = do
+ scrut' <- trans (Other:c) scrut
+ alts' <- mapM transalt alts
+ return $ Case scrut' b t alts'
+ where
+ transalt :: CoreAlt -> TransformMonad CoreAlt
+ transalt (con, binders, expr) = do
+ expr' <- trans (Other:c) expr
+ return (con, binders, expr')
+
+subeverywhere trans c (Var x) = return $ Var x
+subeverywhere trans c (Lit x) = return $ Lit x
+subeverywhere trans c (Type x) = return $ Type x
+
+subeverywhere trans c (Cast expr ty) = do
+ expr' <- trans (Other:c) expr
+ return $ Cast expr' ty
+
+subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
+
+-- Runs each of the transforms repeatedly inside the State monad.
+dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr
+dotransforms transs expr = do
+ (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply trans) [] e) expr transs
+ if Monoid.getAny changed then dotransforms transs expr' else return expr'
+
+-- Inline all let bindings that satisfy the given condition
+inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
+inlinebind condition context expr@(Let (Rec binds) res) = do
+ -- Find all bindings that adhere to the condition
+ res_eithers <- mapM docond binds
+ case Either.partitionEithers res_eithers of
+ -- No replaces? No change
+ ([], _) -> return expr
+ (replace, others) -> do
+ -- Substitute the to be replaced binders with their expression
+ newexpr <- do_substitute replace (Let (Rec others) res)
+ change newexpr
+ where
+ -- Apply the condition to a let binding and return an Either
+ -- depending on whether it needs to be inlined or not.
+ docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
+ docond b = do
+ res <- condition b
+ return $ case res of True -> Left b; False -> Right b
+
+ -- Apply the given list of substitutions to the the given expression
+ do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr
+ do_substitute [] expr = return expr
+ do_substitute ((bndr, val):reps) expr = do
+ -- Perform this substitution in the expression
+ expr' <- substitute_clone bndr val context expr
+ -- And in the substitution values we will be using next
+ reps' <- mapM (subs_bind bndr val) reps
+ -- And then perform the remaining substitutions
+ do_substitute reps' expr'
+
+ -- Replace the given binder with the given expression in the
+ -- expression oft the given let binding
+ subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
+ subs_bind bndr expr (b, v) = do
+ v' <- substitute_clone bndr expr (LetBinding:context) v
+ return (b, v')
+
+
+-- Leave all other expressions unchanged
+inlinebind _ context expr = return expr
+
+-- Sets the changed flag in the TransformMonad, to signify that some
+-- transform has changed the result
+setChanged :: TransformMonad ()
+setChanged = Writer.tell (Monoid.Any True)
+
+-- Sets the changed flag and returns the given value.
+change :: a -> TransformMonad a
+change val = do
+ setChanged
+ return val
+
+-- Returns the given value and sets the changed flag if the bool given is
+-- True. Note that this will not unset the changed flag if the bool is False.
+changeif :: Bool -> a -> TransformMonad a
+changeif True val = change val
+changeif False val = return val
+
+-- | Creates a transformation that substitutes the given binder with the given
+-- expression (This can be a type variable, replace by a Type expression).
+-- Does not set the changed flag.
+substitute :: CoreBndr -> CoreExpr -> Transform
+-- Use CoreSubst to subst a type var in an expression
+substitute find repl context expr = do
+ let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl
+ return $ CoreSubst.substExpr subst expr
+
+-- | Creates a transformation that substitutes the given binder with the given
+-- expression. This does only work for value expressions! All binders in the
+-- expression are cloned before the replacement, to guarantee uniqueness.
+substitute_clone :: CoreBndr -> CoreExpr -> Transform
+-- If we see the var to find, replace it by a uniqued version of repl
+substitute_clone find repl context (Var var) | find == var = do
+ repl' <- Trans.lift $ CoreTools.genUniques repl
+ change repl'
+
+-- For all other expressions, just look in subexpressions
+substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr
+
+-- Is the given expression representable at runtime, based on the type?
+isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
+isRepr tything = Trans.lift (isRepr' tything)
+
+isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
+isRepr' tything = case CoreTools.getType tything of
+ Nothing -> return False
+ Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty
+
+is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
+is_local_var (CoreSyn.Var v) = do
+ bndrs <- getGlobalBinders
+ return $ v `notElem` bndrs
+is_local_var _ = return False
+
+-- Is the given binder defined by the user?
+isUserDefined :: CoreSyn.CoreBndr -> Bool
+-- System names are certain to not be user defined
+isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
+-- Builtin functions are usually not user-defined either (and would
+-- break currently if they are...)
+isUserDefined bndr = str `notElem` builtinIds
+ where
+ str = Name.getOccString bndr
+
+-- | Is the given binder normalizable? This means that its type signature can be
+-- represented in hardware, which should (?) guarantee that it can be made
+-- into hardware. This checks whether all the arguments and (optionally)
+-- the return value are
+-- representable.
+isNormalizeable ::
+ Bool -- ^ Allow the result to be unrepresentable?
+ -> CoreBndr -- ^ The binder to check
+ -> TranslatorSession Bool -- ^ Is it normalizeable?
+isNormalizeable result_nonrep bndr = do
+ let ty = Id.idType bndr
+ let (arg_tys, res_ty) = Type.splitFunTys ty
+ let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys)
+ andM $ mapM isRepr' check_tys
projects / matthijs / master-project / cλash.git / blobdiff