import NormalizeTypes
import NormalizeTools
import CoreTools
+import Pretty
--------------------------------
-- Start of transformations
change (Lam id (App expr (Var id)))
-- Leave all other expressions unchanged
eta e = return e
-etatop = notapplied ("eta", eta)
+etatop = notappargs ("eta", eta)
--------------------------------
-- β-reduction
-- Perform this transform everywhere
betatop = everywhere ("beta", beta)
+--------------------------------
+-- Cast propagation
+--------------------------------
+-- Try to move casts as much downward as possible.
+castprop, castproptop :: Transform
+castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty)
+castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts')
+ where
+ alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts
+-- Leave all other expressions unchanged
+castprop expr = return expr
+-- Perform this transform everywhere
+castproptop = everywhere ("castprop", castprop)
+
--------------------------------
-- let recursification
--------------------------------
--------------------------------
-- Remove a = b bindings from let expressions everywhere
letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
--------------------------------
-- Function inlining
-- and binds that to b.
mkextracts :: CoreBndr -> Int -> TransformMonad (Maybe (CoreBndr, CoreExpr))
mkextracts b i =
+ -- TODO: Use free variables instead of is_wild. is_wild is a hack.
if is_wild b || Type.isFunTy (Id.idType b)
-- Don't create extra bindings for binders that are already wild, or
-- for binders that bind function types (to prevent loops with
--------------------------------
-- Make sure that all arguments in an application are simple variables.
appsimpl, appsimpltop :: Transform
--- Don't simplify arguments that are already simple
-appsimpl expr@(App f (Var _)) = return expr
+-- Don't simplify arguments that are already simple. Do simplify datacons,
+-- however, since we can't portmap literals.
+appsimpl expr@(App f (Var v)) | not $ Id.isDataConWorkId v = return expr
-- Simplify all non-applicable (to prevent loops with inlinefun) arguments,
-- except for type arguments (since a let can't bind type vars, only a lambda
-- can). Do this by introducing a new Let that binds the argument and passing
-- Perform this transform everywhere
funproptop = everywhere ("funprop", funprop)
+--------------------------------
+-- Function-typed argument extraction
+--------------------------------
+-- 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,
+-- since that only inlines local let bindings, not top level bindings.
+funextract, funextracttop :: Transform
+funextract expr@(App _ _) | is_var fexpr = do
+ body_maybe <- Trans.lift $ getGlobalBind f
+ case body_maybe of
+ -- We don't have a function body for f, so we can perform this transform.
+ Nothing -> do
+ -- Find the new arguments
+ args' <- mapM doarg args
+ -- And update the arguments. We use return instead of changed, so the
+ -- changed flag doesn't get set if none of the args got changed.
+ return $ MkCore.mkCoreApps fexpr args'
+ -- We have a function body for f, leave this application to funprop
+ Just _ -> return expr
+ where
+ -- Find the function called and the arguments
+ (fexpr, args) = collectArgs expr
+ Var f = fexpr
+ -- Change any arguments that have a function type, but are not simple yet
+ -- (ie, a variable or application). This means to create a new function
+ -- for map (\f -> ...) b, but not for map (foo a) b.
+ --
+ -- We could use is_applicable here instead of is_fun, but I think
+ -- arguments to functions could only have forall typing when existential
+ -- typing is enabled. Not sure, though.
+ doarg arg | not (is_simple arg) && is_fun arg = do
+ -- Create a new top level binding that binds the argument. Its body will
+ -- be extended with lambda expressions, to take any free variables used
+ -- by the argument expression.
+ let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg
+ let body = MkCore.mkCoreLams free_vars arg
+ id <- mkBinderFor body "fun"
+ Trans.lift $ addGlobalBind id body
+ -- Replace the argument with a reference to the new function, applied to
+ -- all vars it uses.
+ change $ MkCore.mkCoreApps (Var id) (map Var free_vars)
+ -- Leave all other arguments untouched
+ doarg arg = return arg
--- TODO: introduce top level let if needed?
+-- Leave all other expressions unchanged
+funextract expr = return expr
+-- Perform this transform everywhere
+funextracttop = everywhere ("funextract", funextract)
--------------------------------
-- End of transformations
-- What transforms to run?
-transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [typeproptop, funproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
-- Turns the given bind into VHDL
normalizeModule ::
normalizeBind :: CoreBndr -> TransformSession ()
normalizeBind bndr =
- -- 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 $ "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.
- 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 ()
+ -- Don't normalize global variables, these should be either builtin
+ -- functions or data constructors.
+ Monad.when (Var.isLocalIdVar 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.
+ 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. This really shouldn't
+ -- happen for local id's...
+ Nothing -> error $ "\nNormalize.normalizeBind: No value found for binder " ++ pprString bndr ++ "? This should not happen!"
projects / matthijs / master-project / cλash.git / blobdiff