X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Normalize.hs;h=ea8dd045d60579df06df560667806ec4f51717d6;hb=3a611c1075c67670ed6c86a5e74b59b0b379721c;hp=647168b4587df5f782fca4aef6e8ce998fcae508;hpb=7e65fbaf0756893d3c62faf42d28aa5bd363ae3b;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Normalize.hs b/Normalize.hs index 647168b..ea8dd04 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -11,7 +11,9 @@ import Debug.Trace import qualified Maybe 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.Monoid as Monoid import Data.Accessor -- GHC API @@ -23,6 +25,8 @@ import qualified Id import qualified Var import qualified VarSet import qualified CoreFVs +import qualified CoreUtils +import qualified MkCore import Outputable ( showSDoc, ppr, nest ) -- Local imports @@ -58,7 +62,7 @@ beta (App (Let binds expr) arg) = change $ Let binds (App expr arg) beta (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts' where alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts - (_, ty') = Type.splitFunTy ty + ty' = CoreUtils.applyTypeToArg ty arg -- Leave all other expressions unchanged beta expr = return expr -- Perform this transform everywhere @@ -298,14 +302,13 @@ typeprop, typeproptop :: Transform -- arguments without any free tyvars, since tyvars those wouldn't be in scope -- in the new function. typeprop expr@(App (Var f) arg@(Type ty)) | not $ has_free_tyvars arg = do - id <- cloneVar f - let newty = Type.applyTy (Id.idType f) ty - let newf = Var.setVarType id newty body_maybe <- Trans.lift $ getGlobalBind f case body_maybe of Just body -> do let newbody = App body (Type ty) - Trans.lift $ addGlobalBind newf newbody + -- Create a new function with the same name but a new body + newf <- mkFunction f newbody + -- Replace the application with this new function change (Var newf) -- If we don't have a body for the function called, leave it unchanged (it -- should be a primitive function then). @@ -315,6 +318,84 @@ typeprop expr = return expr -- Perform this transform everywhere typeproptop = everywhere ("typeprop", typeprop) + +-------------------------------- +-- Function-typed argument propagation +-------------------------------- +-- Remove all applications to function-typed arguments, by duplication the +-- function called with the function-typed parameter replaced by the free +-- variables of the argument passed in. +funprop, funproptop :: Transform +-- Transform any application of a named function (i.e., skip applications of +-- lambda's). Also skip applications that have arguments with free type +-- variables, since we can't inline those. +funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do + -- Find the body of the function called + body_maybe <- Trans.lift $ getGlobalBind f + case body_maybe of + Just body -> do + -- Process each of the arguments in turn + (args', changed) <- Writer.listen $ mapM doarg args + -- See if any of the arguments changed + case Monoid.getAny changed of + True -> do + let (newargs', newparams', oldargs) = unzip3 args' + let newargs = concat newargs' + let newparams = concat newparams' + -- Create a new body that consists of a lambda for all new arguments and + -- the old body applied to some arguments. + let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) + -- Create a new function with the same name but a new body + newf <- mkFunction f newbody + -- Replace the original application with one of the new function to the + -- new arguments. + change $ MkCore.mkCoreApps (Var newf) newargs + False -> + -- Don't change the expression if none of the arguments changed + return expr + + -- If we don't have a body for the function called, leave it unchanged (it + -- should be a primitive function then). + Nothing -> return expr + where + -- Find the function called and the arguments + (fexpr, args) = collectArgs expr + Var f = fexpr + + -- Process a single argument and return (args, bndrs, arg), where args are + -- the arguments to replace the given argument in the original + -- application, bndrs are the binders to include in the top-level lambda + -- in the new function body, and arg is the argument to apply to the old + -- function body. + doarg :: CoreExpr -> TransformMonad ([CoreExpr], [CoreBndr], CoreExpr) + doarg arg | is_fun arg = do + bndrs <- Trans.lift getGlobalBinders + -- Find interesting free variables, each of which should be passed to + -- the new function instead of the original function argument. + -- + -- Interesting vars are those that are local, but not available from the + -- top level scope (functions from this module are defined as local, but + -- they're not local to this function, so we can freely move references + -- to them into another function). + let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs) + let free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg + -- Mark the current expression as changed + setChanged + return (map Var free_vars, free_vars, arg) + -- Non-functiontyped arguments can be unchanged. Note that this handles + -- both values and types. + doarg arg = do + -- TODO: preserve original naming? + id <- mkBinderFor arg "param" + -- Just pass the original argument to the new function, which binds it + -- to a new id and just pass that new id to the old function body. + return ([arg], [id], mkReferenceTo id) +-- Leave all other expressions unchanged +funprop expr = return expr +-- Perform this transform everywhere +funproptop = everywhere ("funprop", funprop) + + -- TODO: introduce top level let if needed? -------------------------------- @@ -325,7 +406,7 @@ typeproptop = everywhere ("typeprop", typeprop) -- What transforms to run? -transforms = [typeproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] +transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] -- Turns the given bind into VHDL normalizeModule :: @@ -348,34 +429,46 @@ normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings normalizeBind :: CoreBndr -> TransformSession () -normalizeBind bndr = do - normalized_funcs <- getA tsNormalized - -- See if this function was normalized already - if VarSet.elemVarSet bndr normalized_funcs +normalizeBind bndr = + -- Skip binders that have a polymorphic type, since it's impossible to + -- create polymorphic hardware. + if is_poly (Var bndr) then - -- Yup, don't do it again - return () + -- This should really only happen at the top level... TODO: Give + -- a different error if this happens down in the recursion. + error $ "Function " ++ show bndr ++ " is polymorphic, can't normalize" 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 - -- 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. - let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr' - let used_funcs = VarSet.varSetElems used_funcs_set - -- Process each of the used functions recursively - mapM normalizeBind used_funcs + 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 () - -- We don't have a value for this binder, let's assume this is a builtin - -- function. This might need some extra checking and a nice error - -- message). - Nothing -> 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. + let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) 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, let's assume this is a builtin + -- function. This might need some extra checking and a nice error + -- message). + Nothing -> return ()