-- top level function "normalize", and defines the actual transformation passes that
-- are performed.
--
-module CLasH.Normalize (normalizeModule) where
+module CLasH.Normalize (getNormalized) where
-- Standard modules
import Debug.Trace
-- 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.Pretty
--------------------------------
letsimpl, letsimpltop :: Transform
-- Put the "in ..." value of a let in its own binding, but not when the
--- expression is applicable (to prevent loops with inlinefun).
-letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
+-- expression is already a local variable, or not representable (to prevent loops with inlinenonrep).
+letsimpl expr@(Let (Rec binds) res) = do
+ repr <- isRepr res
local_var <- Trans.lift $ is_local_var res
- if not local_var
+ if not local_var && repr
then do
-- If the result is not a local var already (to prevent loops with
-- ourselves), extract it.
-- Don't touch scrutinees that are already simple
scrutsimpl expr@(Case (Var _) _ _ _) = return expr
-- Replace all other cases with a let that binds the scrutinee and a new
--- simple scrutinee, but not when the scrutinee is applicable (to prevent
--- loops with inlinefun, though I don't think a scrutinee can be
--- applicable...)
-scrutsimpl (Case scrut b ty alts) | not $ is_applicable scrut = do
- id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
- change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+-- simple scrutinee, but only when the scrutinee is representable (to prevent
+-- loops with inlinenonrep, though I don't think a non-representable scrutinee
+-- will be supported anyway...)
+scrutsimpl expr@(Case scrut b ty alts) = do
+ repr <- isRepr scrut
+ if repr
+ then do
+ id <- mkInternalVar "scrut" (CoreUtils.exprType scrut)
+ change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts)
+ else
+ return expr
-- Leave all other expressions unchanged
scrutsimpl expr = return expr
-- Perform this transform everywhere
--------------------------------
-- Case binder wildening
--------------------------------
-casewild, casewildtop :: Transform
-casewild expr@(Case scrut b ty alts) = do
+casesimpl, casesimpltop :: Transform
+-- This is already a selector case (or, if x does not appear in bndrs, a very
+-- simple case statement that will be removed by caseremove below). Just leave
+-- it be.
+casesimpl expr@(Case scrut b ty [(con, bndrs, Var x)]) = return expr
+-- Make sure that all case alternatives have only wild binders and simple
+-- expressions.
+-- This is done by creating a new let binding for each non-wild binder, which
+-- is bound to a new simple selector case statement and for each complex
+-- expression. We do this only for representable types, to prevent loops with
+-- inlinenonrep.
+casesimpl expr@(Case scrut b ty alts) = do
(bindingss, alts') <- (Monad.liftM unzip) $ mapM doalt alts
let bindings = concat bindingss
-- Replace the case with a let with bindings and a case
-- selector (i.e., a single alt with exactly one binding), already a simple
-- selector altan no bindings (i.e., no wild binders in the original case),
-- don't change anything, otherwise, replace the case.
- if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
+ if null bindings then return expr else change newlet
where
-- Generate a single wild binder, since they are all the same
wild = MkCore.mkWildBinder
-- sideeffect.
doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
doalt (con, bndrs, expr) = do
- bindings_maybe <- Monad.zipWithM mkextracts bndrs [0..]
- let bindings = Maybe.catMaybes bindings_maybe
- -- We replace the binders with wild binders only. We can leave expr
- -- unchanged, since the new bindings bind the same vars as the original
- -- did.
- let newalt = (con, wildbndrs, expr)
+ -- Make each binder wild, if possible
+ bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
+ let (newbndrs, bindings_maybe) = unzip bndrs_res
+ -- 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
+ (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
+ -- Create a new alternative
+ let newalt = (con, newbndrs, expr')
+ let bindings = Maybe.catMaybes (exprbinding_maybe : bindings_maybe)
return (bindings, newalt)
where
- -- Make all binders wild
+ -- Make wild alternatives for each binder
wildbndrs = map (\bndr -> MkCore.mkWildBinder (Id.idType bndr)) bndrs
-- A set of all the binders that are used by the expression
free_vars = CoreFVs.exprSomeFreeVars (`elem` bndrs) expr
- -- Creates a case statement to retrieve the ith element from the scrutinee
- -- and binds that to b.
- mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
- mkextracts b i =
- if not (VarSet.elemVarSet b free_vars) || Type.isFunTy (Id.idType b)
- -- Don't create extra bindings for binders that are already wild
- -- (e.g. not in the free variables of expr, so unused), or for
- -- binders that bind function types (to prevent loops with
- -- inlinefun).
- then return Nothing
- else do
+ -- Look at the ith binder in the case alternative. Return a new binder
+ -- for it (either the same one, or a wild one) and optionally a let
+ -- binding containing a case expression.
+ dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr))
+ dobndr b i = do
+ repr <- isRepr (Var 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)
+ -- Create a new binding for any representable binder that is not
+ -- already wild and is representable (to prevent loops with
+ -- inlinenonrep).
+ if (not wild) && repr
+ then do
-- Create on new binder that will actually capture a value in this
- -- case statement, and return it
+ -- case statement, and return it.
let bty = (Id.idType b)
id <- mkInternalVar "sel" bty
let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs
- return $ Just (b, Case scrut b bty [(con, binders, Var id)])
+ let caseexpr = Case scrut b bty [(con, binders, Var id)]
+ return (wildbndrs!!i, Just (b, caseexpr))
+ else
+ -- Just leave the original binder in place, and don't generate an
+ -- extra selector case.
+ return (b, Nothing)
+ -- Process the expression of a case alternative. Accepts an expression
+ -- and whether this expression uses any of the binders in the
+ -- alternative. Returns an optional new binding and a new expression.
+ doexpr :: CoreExpr -> Bool -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreExpr)
+ doexpr expr uses_bndrs = do
+ local_var <- Trans.lift $ is_local_var expr
+ repr <- isRepr expr
+ -- Extract any expressions that do not use any binders from this
+ -- alternative, is not a local var already and is representable (to
+ -- prevent loops with inlinenonrep).
+ if (not uses_bndrs) && (not local_var) && repr
+ then do
+ id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
+ -- 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)
+ else
+ -- Don't simplify anything else
+ return (Nothing, expr)
-- Leave all other expressions unchanged
-casewild expr = return expr
+casesimpl expr = return expr
-- Perform this transform everywhere
-casewildtop = everywhere ("casewild", casewild)
-
---------------------------------
--- Case value simplification
---------------------------------
-casevalsimpl, casevalsimpltop :: Transform
-casevalsimpl expr@(Case scrut b ty alts) = do
- -- Try to simplify each alternative, resulting in an optional binding and a
- -- new alternative.
- (bindings_maybe, alts') <- (Monad.liftM unzip) $ mapM doalt alts
- let bindings = Maybe.catMaybes bindings_maybe
- -- Create a new let around the case, that binds of the cases values.
- let newlet = Let (Rec bindings) (Case scrut b ty alts')
- -- If there were no values that needed and allowed simplification, don't
- -- change the case.
- if null bindings then return expr else change newlet
- where
- doalt :: CoreAlt -> TransformMonad (Maybe (CoreBndr, CoreExpr), CoreAlt)
- -- Don't simplify values that are already simple
- doalt alt@(con, bndrs, Var _) = return (Nothing, alt)
- -- Simplify each alt by creating a new id, binding the case value to it and
- -- replacing the case value with that id. Only do this when the case value
- -- does not use any of the binders bound by this alternative, for that would
- -- cause those binders to become unbound when moving the value outside of
- -- the case statement. Also, don't create a binding for applicable
- -- expressions, to prevent loops with inlinefun.
- doalt (con, bndrs, expr) | (not usesvars) && (not $ is_applicable expr) = do
- id <- mkInternalVar "caseval" (CoreUtils.exprType expr)
- -- We don't flag a change here, since casevalsimpl will do that above
- -- based on Just we return here.
- return $ (Just (id, expr), (con, bndrs, Var id))
- -- Find if any of the binders are used by expr
- where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
- -- Don't simplify anything else
- doalt alt = return (Nothing, alt)
--- Leave all other expressions unchanged
-casevalsimpl expr = return expr
--- Perform this transform everywhere
-casevalsimpltop = everywhere ("casevalsimpl", casevalsimpl)
+casesimpltop = everywhere ("casesimpl", casesimpl)
--------------------------------
-- Case removal
-- This transform takes any function-typed argument that cannot be propagated
-- (because the function that is applied to it is a builtin function), and
-- puts it in a brand new top level binder. This allows us to for example
--- apply map to a lambda expression This will not conflict with inlinefun,
+-- apply map to a lambda expression This will not conflict with inlinenonrep,
-- since that only inlines local let bindings, not top level bindings.
funextract, funextracttop :: Transform
funextract expr@(App _ _) | is_var fexpr = do
-- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop]
+
+-- | Returns the normalized version of the given function.
+getNormalized ::
+ CoreBndr -- ^ The function to get
+ -> TranslatorSession CoreExpr -- The normalized function body
--- Turns the given bind into VHDL
-normalizeModule ::
- HscTypes.HscEnv
- -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use
- -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module)
- -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
- -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
- -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
+getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+ if is_poly (Var bndr)
+ then
+ -- This should really only happen at the top level... TODO: Give
+ -- a different error if this happens down in the recursion.
+ error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
+ else do
+ expr <- getBinding bndr
+ -- Introduce an empty Let at the top level, so there will always be
+ -- a let in the expression (none of the transformations will remove
+ -- the last let).
+ let expr' = Let (Rec []) expr
+ -- Normalize this expression
+ trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
+ expr'' <- dotransforms transforms expr'
+ trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ return expr''
-normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do
- -- Put all the bindings in this module in the tsBindings map
- putA tsBindings (Map.fromList bindings)
- -- (Recursively) normalize each of the requested bindings
- mapM normalizeBind generate_for
- -- Get all initial bindings and the ones we produced
- bindings_map <- getA tsBindings
- let bindings = Map.assocs bindings_map
- normalized_bindings <- getA tsNormalized
- typestate <- getA tsType
- -- But return only the normalized bindings
- return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)
+-- | Get the value that is bound to the given binder at top level. Fails when
+-- there is no such binding.
+getBinding ::
+ CoreBndr -- ^ The binder to get the expression for
+ -> TranslatorSession CoreExpr -- ^ The value bound to the binder
-normalizeBind :: CoreBndr -> TransformSession ()
-normalizeBind bndr =
- -- Don't normalize global variables, these should be either builtin
- -- functions or data constructors.
- Monad.when (Var.isLocalId bndr) $ do
- -- Skip binders that have a polymorphic type, since it's impossible to
- -- create polymorphic hardware.
- if is_poly (Var bndr)
- then
- -- This should really only happen at the top level... TODO: Give
- -- a different error if this happens down in the recursion.
- error $ "\nNormalize.normalizeBind: Function " ++ show bndr ++ " is polymorphic, can't normalize"
- else do
- normalized_funcs <- getA tsNormalized
- -- See if this function was normalized already
- if VarSet.elemVarSet bndr normalized_funcs
- then
- -- Yup, don't do it again
- return ()
- else do
- -- Nope, note that it has been and do it.
- modA tsNormalized (flip VarSet.extendVarSet bndr)
- expr_maybe <- getGlobalBind bndr
- case expr_maybe of
- Just expr -> do
- -- Introduce an empty Let at the top level, so there will always be
- -- a let in the expression (none of the transformations will remove
- -- the last let).
- let expr' = Let (Rec []) expr
- -- Normalize this expression
- trace ("Transforming " ++ (show bndr) ++ "\nBefore:\n\n" ++ showSDoc ( ppr expr' ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr'
- trace ("\nAfter:\n\n" ++ showSDoc ( ppr expr')) $ return ()
- -- And store the normalized version in the session
- modA tsBindings (Map.insert bndr expr')
- -- Find all vars used with a function type. All of these should be global
- -- binders (i.e., functions used), since any local binders with a function
- -- type should have been inlined already.
- bndrs <- getGlobalBinders
- let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr'
- let used_funcs = VarSet.varSetElems used_funcs_set
- -- Process each of the used functions recursively
- mapM normalizeBind used_funcs
- return ()
- -- We don't have a value for this binder. This really shouldn't
- -- happen for local id's...
- Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
+getBinding bndr = Utils.makeCached bndr tsBindings $ do
+ -- 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