import qualified "transformers" Control.Monad.Trans as Trans
import qualified Control.Monad as Monad
import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Map as Map
+import qualified Data.Accessor.Monad.Trans.State as MonadState
import qualified Data.Monoid as Monoid
-import Data.Accessor
+import qualified Data.Map as Map
-- GHC API
import CoreSyn
-import qualified UniqSupply
import qualified CoreUtils
import qualified Type
-import qualified TcType
import qualified Id
import qualified Var
import qualified VarSet
-import qualified NameSet
import qualified CoreFVs
-import qualified CoreUtils
import qualified MkCore
-import qualified HscTypes
import Outputable ( showSDoc, ppr, nest )
-- Local imports
import CLasH.Normalize.NormalizeTypes
import CLasH.Translator.TranslatorTypes
import CLasH.Normalize.NormalizeTools
-import CLasH.VHDL.VHDLTypes
import qualified CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Core.BinderTools
-- β-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
-- to:
-- let b' = expr' in (let b = res' in res)
letflat, letflattop :: Transform
-letflat (Let (NonRec b (Let (NonRec b' expr') res')) res) =
- change $ Let (NonRec b' expr') (Let (NonRec b res') res)
+-- Turn a nonrec let that binds a let into two nested lets.
+letflat (Let (NonRec b (Let binds res')) res) =
+ change $ Let binds (Let (NonRec b res') res)
+letflat (Let (Rec binds) expr) = do
+ -- Flatten each binding.
+ binds' <- Utils.concatM $ Monad.mapM flatbind binds
+ -- Return the new let. We don't use change here, since possibly nothing has
+ -- changed. If anything has changed, flatbind has already flagged that
+ -- change.
+ return $ Let (Rec binds') expr
+ where
+ -- Turns a binding of a let into a multiple bindings, or any other binding
+ -- into a list with just that binding
+ flatbind :: (CoreBndr, CoreExpr) -> TransformMonad [(CoreBndr, CoreExpr)]
+ flatbind (b, Let (Rec binds) expr) = change ((b, expr):binds)
+ flatbind (b, Let (NonRec b' expr') expr) = change [(b, expr), (b', expr')]
+ flatbind (b, expr) = return [(b, expr)]
-- Leave all other expressions unchanged
letflat expr = return expr
-- Perform this transform everywhere
--------------------------------
-- Remove empty (recursive) lets
letremove, letremovetop :: Transform
-letremove (Let (Rec []) res) = change $ res
+letremove (Let (Rec []) res) = change res
-- Leave all other expressions unchanged
letremove expr = return expr
-- Perform this transform everywhere
-- Unused let binding removal
--------------------------------
letremoveunused, letremoveunusedtop :: Transform
-letremoveunused expr@(Let _ _) = do
+letremoveunused expr@(Let (NonRec b bound) res) = do
+ let used = expr_uses_binders [b] res
+ if used
+ then return expr
+ else change res
+letremoveunused expr@(Let (Rec binds) res) = do
-- Filter out all unused binds.
let binds' = filter dobind binds
-- Only set the changed flag if binds got removed
- changeif (length binds' /= length binds) (mkNonRecLets binds' res)
+ changeif (length binds' /= length binds) (Let (Rec binds') res)
where
- (binds, res) = flattenLets expr
bound_exprs = map snd binds
-- For each bind check if the bind is used by res or any of the bound
-- expressions
letremoveunused expr = return expr
letremoveunusedtop = everywhere ("letremoveunused", letremoveunused)
+{-
--------------------------------
-- Identical let binding merging
--------------------------------
-- Leave all other expressions unchanged
letmerge expr = return expr
letmergetop = everywhere ("letmerge", letmerge)
-
+-}
+
--------------------------------
--- Function inlining
+-- Non-representable binding inlining
--------------------------------
--- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
--- expressions everywhere. This means that any value that still needs to be
--- applied to something else (polymorphic values need to be applied to a
--- Type) will be inlined, and will eventually be applied to all their
--- arguments.
+-- Remove a = B bindings, with B of a non-representable type, from let
+-- expressions everywhere. This means that any value that we can't generate a
+-- signal for, will be inlined and hopefully turned into something we can
+-- represent.
--
-- This is a tricky function, which is prone to create loops in the
-- transformations. To fix this, we make sure that no transformation will
--- create a new let binding with a function type. These other transformations
--- will just not work on those function-typed values at first, but the other
--- transformations (in particular β-reduction) should make sure that the type
--- of those values eventually becomes primitive.
+-- create a new let binding with a non-representable type. These other
+-- transformations will just not work on those function-typed values at first,
+-- but the other transformations (in particular β-reduction) should make sure
+-- that the type of those values eventually becomes representable.
inlinenonreptop :: Transform
inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
+--------------------------------
+-- Top level function inlining
+--------------------------------
+-- This transformation inlines top level bindings that have been generated by
+-- the compiler and are really simple. Really simple currently means that the
+-- normalized form only contains a single binding, which catches most of the
+-- cases where a top level function is created that simply calls a type class
+-- method with a type and dictionary argument, e.g.
+-- fromInteger = GHC.Num.fromInteger (SizedWord D8) $dNum
+-- which is later called using simply
+-- fromInteger (smallInteger 10)
+-- By inlining such calls to simple, compiler generated functions, we prevent
+-- huge amounts of trivial components in the VHDL output, which the user never
+-- wanted. We never inline user-defined functions, since we want to preserve
+-- all structure defined by the user. Currently this includes all functions
+-- that were created by funextract, since we would get loops otherwise.
+--
+-- Note that "defined by the compiler" isn't completely watertight, since GHC
+-- doesn't seem to set all those names as "system names", we apply some
+-- guessing here.
+inlinetoplevel, inlinetopleveltop :: Transform
+-- Any system name is candidate for inlining. Never inline user-defined
+-- functions, to preserve structure.
+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
+ if norm && Maybe.isJust body_maybe
+ then do
+ -- Get the normalized version
+ norm <- Trans.lift $ getNormalized f
+ if needsInline norm
+ then do
+ -- Regenerate all uniques in the to-be-inlined expression
+ norm_uniqued <- Trans.lift $ genUniques norm
+ change norm_uniqued
+ else
+ 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
+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
--------------------------------
-- Perform this transform everywhere
scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
+--------------------------------
+-- Scrutinee binder removal
+--------------------------------
+-- A case expression can have an extra binder, to which the scrutinee is bound
+-- after bringing it to WHNF. This is used for forcing evaluation of strict
+-- arguments. Since strictness does not matter for us (rather, everything is
+-- sort of strict), this binder is ignored when generating VHDL, and must thus
+-- be wild in the normal form.
+scrutbndrremove, scrutbndrremovetop :: Transform
+-- If the scrutinee is already simple, and the bndr is not wild yet, replace
+-- all occurences of the binder with the scrutinee variable.
+scrutbndrremove (Case (Var scrut) bndr ty alts) | bndr_used = do
+ alts' <- mapM subs_bndr alts
+ change $ Case (Var scrut) wild ty alts'
+ where
+ is_used (_, _, expr) = expr_uses_binders [bndr] expr
+ bndr_used = or $ map is_used alts
+ subs_bndr (con, bndrs, expr) = do
+ expr' <- substitute bndr (Var scrut) expr
+ return (con, bndrs, expr')
+ wild = MkCore.mkWildBinder (Id.idType bndr)
+-- Leave all other expressions unchanged
+scrutbndrremove expr = return expr
+scrutbndrremovetop = everywhere ("scrutbndrremove", scrutbndrremove)
+
--------------------------------
-- Case binder wildening
--------------------------------
-- Extract a complex expression, if possible. For this we check if any of
-- the new list of bndrs are used by expr. We can't use free_vars here,
-- since that looks at the old bndrs.
- let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+ let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
(exprbinding_maybe, expr') <- doexpr expr uses_bndrs
-- Create a new alternative
let newalt = (con, newbndrs, expr')
- let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe)
+ let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
return (bindings, newalt)
where
-- Make wild alternatives for each binder
-- 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)
id <- Trans.lift $ mkBinderFor expr "caseval"
-- We don't flag a change here, since casevalsimpl will do that above
-- based on Just we return here.
- return $ (Just (id, expr), Var id)
+ return (Just (id, expr), Var id)
else
-- Don't simplify anything else
return (Nothing, expr)
let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs)
-- Create a new function with the same name but a new body
newf <- Trans.lift $ mkFunction f newbody
+
+ Trans.lift $ MonadState.modify tsInitStates (\ismap ->
+ let init_state_maybe = Map.lookup f ismap in
+ case init_state_maybe of
+ Nothing -> ismap
+ Just init_state -> Map.insert newf init_state ismap)
-- Replace the original application with one of the new function to the
-- new arguments.
change $ MkCore.mkCoreApps (Var newf) newargs
doarg arg = do
repr <- isRepr arg
bndrs <- Trans.lift getGlobalBinders
- let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+ let interesting var = Var.isLocalVar var && (var `notElem` bndrs)
if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg)
then do
-- Propagate all complex arguments that are not representable, but not
let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
-- Mark the current expression as changed
setChanged
+ -- TODO: Clone the free_vars (and update references in arg), since
+ -- this might cause conflicts if two arguments that are propagated
+ -- share a free variable. Also, we are now introducing new variables
+ -- into a function that are not fresh, which violates the binder
+ -- uniqueness invariant.
return (map Var free_vars, free_vars, arg)
else do
-- Representable types will not be propagated, and arguments with free
-- type variables will be propagated later.
+ -- Note that we implicitly remove any type variables in the type of
+ -- the original argument by using the type of the actual argument
+ -- for the new formal parameter.
-- TODO: preserve original naming?
id <- Trans.lift $ mkBinderFor arg "param"
-- Just pass the original argument to the new function, which binds it
-- Perform this transform everywhere
funextracttop = everywhere ("funextract", funextract)
+--------------------------------
+-- Ensure that a function that just returns another function (or rather,
+-- another top-level binder) is still properly normalized. This is a temporary
+-- solution, we should probably integrate this pass with lambdasimpl and
+-- letsimpl instead.
+--------------------------------
+simplrestop expr@(Lam _ _) = return expr
+simplrestop expr@(Let _ _) = return expr
+simplrestop expr = do
+ local_var <- Trans.lift $ is_local_var expr
+ -- 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
+ id <- Trans.lift $ mkBinderFor expr "res"
+ change $ Let (NonRec id expr) (Var id)
--------------------------------
-- End of transformations
--------------------------------
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop, lambdasimpltop]
+transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
-- | Returns the normalized version of the given function.
getNormalized ::
CoreBndr -- ^ The function to get
-> TranslatorSession CoreExpr -- The normalized function body
-getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+getNormalized bndr = Utils.makeCached bndr tsNormalized $
if is_poly (Var bndr)
then
-- This should really only happen at the top level... TODO: Give
-> 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'
CoreBndr -- ^ The binder to get the expression for
-> TranslatorSession CoreExpr -- ^ The value bound to the binder
-getBinding bndr = Utils.makeCached bndr tsBindings $ do
+getBinding bndr = Utils.makeCached bndr tsBindings $
-- If the binding isn't in the "cache" (bindings map), then we can't create
-- it out of thin air, so return an error.
error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr
projects / matthijs / master-project / cλash.git / blobdiff