-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop]
-
--- 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)
- -> [CoreExpr]
- -> [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)], [(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-
-normalizeModule env uniqsupply bindings testexprs generate_for statefuls = runTransformSession env uniqsupply $ do
- testbinds <- mapM (\x -> do { v <- mkBinderFor' x "test" ; return (v,x) } ) testexprs
- let testbinders = (map fst testbinds)
- -- Put all the bindings in this module in the tsBindings map
- putA tsBindings (Map.fromList (bindings ++ testbinds))
- -- (Recursively) normalize each of the requested bindings
- mapM normalizeBind (generate_for ++ testbinders)
- -- Get all initial bindings and the ones we produced
- bindings_map <- getA tsBindings
- let bindings = Map.assocs bindings_map
- normalized_binders' <- getA tsNormalized
- let normalized_binders = VarSet.delVarSetList normalized_binders' testbinders
- let ret_testbinds = zip testbinders (Maybe.catMaybes $ map (\x -> lookup x bindings) testbinders)
- let ret_binds = filter ((`VarSet.elemVarSet` normalized_binders) . fst) bindings
- typestate <- getA tsType
- -- But return only the normalized bindings
- return $ (ret_binds, ret_testbinds, typestate)
-
-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!"
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letderectop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letmergetop, letremoveunusedtop, castsimpltop]
+
+-- | 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
+ 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
+ normalizeExpr (show bndr) expr
+
+-- | Normalize an expression
+normalizeExpr ::
+ String -- ^ What are we normalizing? For debug output only.
+ -> CoreSyn.CoreExpr -- ^ The expression to normalize
+ -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
+
+normalizeExpr what expr = do
+ -- Normalize this expression
+ trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
+ expr' <- dotransforms transforms expr
+ trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
+ return expr'
+
+-- | 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
+
+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
+
+-- | Split a normalized expression into the argument binders, top level
+-- bindings and the result binder.
+splitNormalized ::
+ CoreExpr -- ^ The normalized expression
+ -> ([CoreBndr], [Binding], CoreBndr)
+splitNormalized expr = (args, binds, res)
+ where
+ (args, letexpr) = CoreSyn.collectBinders expr
+ (binds, resexpr) = flattenLets letexpr
+ res = case resexpr of
+ (Var x) -> x
+ _ -> error $ "Normalize.splitNormalized: Not in normal form: " ++ pprString expr ++ "\n"
+
+-- | Flattens nested lets into a single list of bindings. The expression
+-- passed does not have to be a let expression, if it isn't an empty list of
+-- bindings is returned.
+flattenLets ::
+ CoreExpr -- ^ The expression to flatten.
+ -> ([Binding], CoreExpr) -- ^ The bindings and resulting expression.
+flattenLets (Let binds expr) =
+ (bindings ++ bindings', expr')
+ where
+ -- Recursively flatten the contained expression
+ (bindings', expr') =flattenLets expr
+ -- Flatten our own bindings to remove the Rec / NonRec constructors
+ bindings = CoreSyn.flattenBinds [binds]
+flattenLets expr = ([], expr)
projects / matthijs / master-project / cλash.git / blobdiff