-- β-reduction
--------------------------------
beta, betatop :: Transform
--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Substitute arg for x in expr. For value lambda's, also clone before
+-- substitution.
+beta (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg expr
+ | otherwise = setChanged >> substitute_clone x arg expr
-- Propagate the application into the let
beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
-- Propagate the application into each of the alternatives
inlinetoplevel, inlinetopleveltop :: Transform
-- Any system name is candidate for inlining. Never inline user-defined
-- functions, to preserver structure.
-inlinetoplevel expr@(Var f) | (Name.isSystemName . Id.idName) f = do
+inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
+ norm <- isNormalizeable f
-- See if this is a top level binding for which we have a body
body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- Just body -> do
+ if norm && Maybe.isJust body_maybe
+ then do
-- Get the normalized version
norm <- Trans.lift $ getNormalized f
if needsInline norm
- then
- change norm
+ then do
+ -- Regenerate all uniques in the to-be-inlined expression
+ norm_uniqued <- Trans.lift $ genUniques norm
+ change norm_uniqued
else
return expr
- -- No body, this is probably a local variable or builtin or external
- -- function.
- Nothing -> return expr
+ else
+ -- No body or not normalizeable.
+ return expr
-- Leave all other expressions unchanged
inlinetoplevel expr = return expr
inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel)
needsInline :: CoreExpr -> Bool
--- Any function that just evaluates to another function, can be inlined
---needsInline (Var f) = True
-needsInline _ = False
+needsInline expr = case splitNormalized expr of
+ -- Inline any function that only has a single definition, it is probably
+ -- simple enough. This might inline some stuff that it shouldn't though it
+ -- will never inline user-defined functions (inlinetoplevel only tries
+ -- system names) and inlining should never break things.
+ (args, [bind], res) -> True
+ _ -> False
--------------------------------
-- Scrutinee simplification
-- binding containing a case expression.
dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
dobndr b i = do
- repr <- isRepr (Var b)
+ repr <- isRepr b
-- Is b wild (e.g., not a free var of expr. Since b is only in scope
-- in expr, this means that b is unused if expr does not use it.)
let wild = not (VarSet.elemVarSet b free_vars)
simplrestop expr@(Let _ _) = return expr
simplrestop expr = do
local_var <- Trans.lift $ is_local_var expr
- if local_var
+ -- Don't extract values that are not representable, to prevent loops with
+ -- inlinenonrep
+ repr <- isRepr expr
+ if local_var || not repr
then
return expr
else do
-> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
normalizeExpr what expr = do
+ expr_uniqued <- genUniques expr
-- Normalize this expression
- trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr
+ trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr_uniqued
trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
return expr'
-- GHC API
import CoreSyn
+import qualified Name
+import qualified Id
import qualified CoreSubst
import qualified CoreUtils
+import qualified Type
import Outputable ( showSDoc, ppr, nest )
-- Local imports
import CLasH.Normalize.NormalizeTypes
import CLasH.Translator.TranslatorTypes
+import CLasH.Utils
import CLasH.Utils.Pretty
+import qualified CLasH.Utils.Core.CoreTools as CoreTools
import CLasH.VHDL.VHDLTypes
import qualified CLasH.VHDL.VHDLTools as VHDLTools
inlinebind condition expr@(Let (NonRec bndr expr') res) = do
applies <- condition (bndr, expr')
if applies
- then
+ then do
-- Substitute the binding in res and return that
- change $ substitute [(bndr, expr')] res
+ res' <- substitute_clone bndr expr' res
+ change res'
else
-- Don't change this let
return expr
changeif True val = change val
changeif False val = return val
--- Replace each of the binders given with the coresponding expressions in the
--- given expression.
-substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
-substitute [] expr = expr
--- Apply one substitution on the expression, but also on any remaining
--- substitutions. This seems to be the only way to handle substitutions like
--- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
--- according to CoreSubst documentation (but it doesn't seem to be a problem).
--- TODO: Find out how this works, exactly.
-substitute ((b, e):subss) expr = substitute subss' expr'
- where
- -- Create the Subst
- subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
- -- Apply this substitution to the main expression
- expr' = CoreSubst.substExpr subs expr
- -- Apply this substitution on all the expressions in the remaining
- -- substitutions
- subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
+-- | 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 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 (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 expr = subeverywhere (substitute_clone find repl) expr
-- Is the given expression representable at runtime, based on the type?
-isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
-isRepr (Type ty) = return False
-isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)
+isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
+isRepr tything = case CoreTools.getType tything of
+ Nothing -> return False
+ Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
is_local_var (CoreSyn.Var v) = do
bndrs <- getGlobalBinders
return $ not $ v `elem` 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
+-- Check a list of typical compiler-defined names
+isUserDefined bndr = not $ str `elem` compiler_names
+ where
+ str = Name.getOccString bndr
+ -- These are names of bindings usually generated by the compiler. For some
+ -- reason these are not marked as system, probably because the name itself
+ -- is not made up by the compiler, just this particular binding is.
+ compiler_names = ["fromInteger"]
+
+-- 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. Note that if a binder is not normalizable, it might become
+-- so using argument propagation.
+isNormalizeable :: CoreBndr -> TransformMonad Bool
+isNormalizeable bndr = do
+ let ty = Id.idType bndr
+ let (arg_tys, res_ty) = Type.splitFunTys ty
+ -- This function is normalizable if all its arguments and return value are
+ -- representable.
+ andM $ mapM isRepr (res_ty:arg_tys)
isJustM :: (Monad m) => m (Maybe a) -> m Bool
isJustM = Monad.liftM Maybe.isJust
+
+andM, orM :: (Monad m) => m [Bool] -> m Bool
+andM = Monad.liftM and
+orM = Monad.liftM or
+
+mapAccumLM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
+mapAccumLM _ s [] = return (s, [])
+mapAccumLM f s (x:xs) = do
+ (s', y ) <- f s x
+ (s'', ys) <- mapAccumLM f s' xs
+ return (s'', y:ys)
import qualified CoreFVs
import qualified Literal
import qualified MkCore
+import qualified VarEnv
-- Local imports
import CLasH.Translator.TranslatorTypes
import CLasH.Utils.GhcTools
import CLasH.Utils.HsTools
import CLasH.Utils.Pretty
+import CLasH.Utils
+import qualified CLasH.Utils.Core.BinderTools as BinderTools
-- | A single binding, used as a shortcut to simplify type signatures.
type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr)
has_free_tyvars :: CoreSyn.CoreExpr -> Bool
has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
+-- Does the given type have any free type vars?
+ty_has_free_tyvars :: Type.Type -> Bool
+ty_has_free_tyvars = not . VarSet.isEmptyVarSet . Type.tyVarsOfType
+
-- Does the given CoreExpr have any free local vars?
has_free_vars :: CoreSyn.CoreExpr -> Bool
has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
instance TypedThing Type.Type where
getType = return . id
+
+-- | Generate new uniques for all binders in the given expression.
+-- Does not support making type variables unique, though this could be
+-- supported if required (by passing a CoreSubst.Subst instead of VarEnv to
+-- genUniques' below).
+genUniques :: CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
+genUniques = genUniques' VarEnv.emptyVarEnv
+
+-- | A helper function to generate uniques, that takes a VarEnv containing the
+-- substitutions already performed.
+genUniques' :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr
+genUniques' subst (CoreSyn.Var f) = do
+ -- Replace the binder with its new value, if applicable.
+ let f' = VarEnv.lookupWithDefaultVarEnv subst f f
+ return (CoreSyn.Var f')
+-- Leave literals untouched
+genUniques' subst (CoreSyn.Lit l) = return $ CoreSyn.Lit l
+genUniques' subst (CoreSyn.App f arg) = do
+ -- Only work on subexpressions
+ f' <- genUniques' subst f
+ arg' <- genUniques' subst arg
+ return (CoreSyn.App f' arg')
+-- Don't change type abstractions
+genUniques' subst expr@(CoreSyn.Lam bndr res) | CoreSyn.isTyVar bndr = return expr
+genUniques' subst (CoreSyn.Lam bndr res) = do
+ -- Generate a new unique for the bound variable
+ (subst', bndr') <- genUnique subst bndr
+ res' <- genUniques' subst' res
+ return (CoreSyn.Lam bndr' res')
+genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do
+ -- Make the binders unique
+ (subst', bndr') <- genUnique subst bndr
+ bound' <- genUniques' subst' bound
+ res' <- genUniques' subst' res
+ return $ CoreSyn.Let (CoreSyn.NonRec bndr' bound') res'
+genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do
+ -- Make each of the binders unique
+ (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds)
+ bounds' <- mapM (genUniques' subst') (map snd binds)
+ res' <- genUniques' subst' res
+ let binds' = zip bndrs' bounds'
+ return $ CoreSyn.Let (CoreSyn.Rec binds') res'
+genUniques' subst (CoreSyn.Case scrut bndr ty alts) = do
+ -- Process the scrutinee with the original substitution, since non of the
+ -- binders bound in the Case statement is in scope in the scrutinee.
+ scrut' <- genUniques' subst scrut
+ -- Generate a new binder for the scrutinee
+ (subst', bndr') <- genUnique subst bndr
+ -- Process each of the alts
+ alts' <- mapM (doalt subst') alts
+ return $ CoreSyn.Case scrut' bndr' ty alts'
+ where
+ doalt subst (con, bndrs, expr) = do
+ (subst', bndrs') <- mapAccumLM genUnique subst bndrs
+ expr' <- genUniques' subst' expr
+ -- Note that we don't return subst', since bndrs are only in scope in
+ -- expr.
+ return (con, bndrs', expr')
+genUniques' subst (CoreSyn.Cast expr coercion) = do
+ expr' <- genUniques' subst expr
+ -- Just process the casted expression
+ return $ CoreSyn.Cast expr' coercion
+genUniques' subst (CoreSyn.Note note expr) = do
+ expr' <- genUniques' subst expr
+ -- Just process the annotated expression
+ return $ CoreSyn.Note note expr'
+-- Leave types untouched
+genUniques' subst expr@(CoreSyn.Type _) = return expr
+
+-- Generate a new unique for the given binder, and extend the given
+-- substitution to reflect this.
+genUnique :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> TranslatorSession (VarEnv.VarEnv CoreSyn.CoreBndr, CoreSyn.CoreBndr)
+genUnique subst bndr = do
+ bndr' <- BinderTools.cloneVar bndr
+ -- Replace all occurences of the old binder with a reference to the new
+ -- binder.
+ let subst' = VarEnv.extendVarEnv subst bndr bndr'
+ return (subst', bndr')
Just ty -> vhdl_ty_either' ty
vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
-vhdl_ty_either' ty = do
+vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
+ | otherwise = do
typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
projects / matthijs / master-project / cλash.git / commitdiff