+{-# LANGUAGE PackageImports #-}
--
-- Functions to bring a Core expression in normal form. This module provides a
-- top level function "normalize", and defines the actual transformation passes that
-- are performed.
--
-module Normalize (normalize) where
+module Normalize (normalizeModule) where
-- Standard modules
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
import CoreSyn
import qualified UniqSupply
import qualified CoreUtils
import qualified Type
+import qualified TcType
import qualified Id
-import qualified UniqSet
+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 NormalizeTypes
import NormalizeTools
+import VHDLTypes
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
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
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
--------------------------------
-- let simplification
--------------------------------
letsimpl, letsimpltop :: Transform
--- Don't simplifiy lets that are already simple
-letsimpl expr@(Let _ (Var _)) = return expr
-- Put the "in ..." value of a let in its own binding, but not when the
--- expression has a function type (to prevent loops with inlinefun).
-letsimpl (Let (Rec binds) expr) | not $ is_fun expr = do
- id <- mkInternalVar "foo" (CoreUtils.exprType expr)
- let bind = (id, expr)
- change $ Let (Rec (bind:binds)) (Var id)
+-- expression is applicable (to prevent loops with inlinefun).
+letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do
+ local_var <- Trans.lift $ is_local_var res
+ if not local_var
+ then do
+ -- If the result is not a local var already (to prevent loops with
+ -- ourselves), extract it.
+ id <- mkInternalVar "foo" (CoreUtils.exprType res)
+ let bind = (id, res)
+ change $ Let (Rec (bind:binds)) (Var id)
+ else
+ -- If the result is already a local var, don't extract it.
+ return expr
+
-- Leave all other expressions unchanged
letsimpl expr = return expr
-- Perform this transform everywhere
--------------------------------
-- 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) -> Trans.lift $ is_local_var e))
--------------------------------
-- Function inlining
--------------------------------
--- Remove a = B bindings, with B :: a -> b, from let expressions everywhere.
+-- 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.
+--
-- 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.
-inlinefuntop :: Transform
-inlinefuntop = everywhere ("inlinefun", inlinebind (Type.isFunTy . CoreUtils.exprType . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
--------------------------------
-- Scrutinee simplification
-- 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 a function type (to prevent
--- loops with inlinefun, though I don't think a scrutinee can have a function
--- type...)
-scrutsimpl (Case scrut b ty alts) | not $ is_fun scrut = do
+-- 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)
-- Leave all other expressions unchanged
if null bindings || length alts == 1 && length bindings == 1 then return expr else change newlet
where
-- Generate a single wild binder, since they are all the same
- wild = Id.mkWildId
+ wild = MkCore.mkWildBinder
-- Wilden the binders of one alt, producing a list of bindings as a
-- sideeffect.
doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
return (bindings, newalt)
where
-- Make all binders wild
- wildbndrs = map (\bndr -> Id.mkWildId (Id.idType bndr)) bndrs
+ 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 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
+ 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
-- 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 function-typed
+ -- 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_fun expr) = do
+ 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 . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) 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
-- Replace a useless case by the value of its single alternative
caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr
-- Find if any of the binders are used by expr
- where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
+ where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr
-- Leave all other expressions unchanged
caseremove expr = return expr
-- Perform this transform everywhere
caseremovetop = everywhere ("caseremove", caseremove)
--------------------------------
--- Application simplification
+-- Argument extraction
--------------------------------
--- Make sure that all arguments in an application are simple variables.
+-- Make sure that all arguments of a representable type are simple variables.
appsimpl, appsimpltop :: Transform
--- Don't simplify arguments that are already simple
-appsimpl expr@(App f (Var _)) = return expr
--- Simplify all arguments that do not have a function type (to prevent loops
--- with inlinefun) and is not a type argument. Do this by introducing a new
--- Let that binds the argument and passing the new binder in the application.
-appsimpl (App f expr) | (not $ is_fun expr) && (not $ CoreSyn.isTypeArg expr) = do
- id <- mkInternalVar "arg" (CoreUtils.exprType expr)
- change $ Let (Rec [(id, expr)]) (App f (Var id))
+-- Simplify all representable arguments. Do this by introducing a new Let
+-- that binds the argument and passing the new binder in the application.
+appsimpl expr@(App f arg) = do
+ -- Check runtime representability
+ repr <- isRepr arg
+ local_var <- Trans.lift $ is_local_var arg
+ if repr && not local_var
+ then do -- Extract representable arguments
+ id <- mkInternalVar "arg" (CoreUtils.exprType arg)
+ change $ Let (Rec [(id, arg)]) (App f (Var id))
+ else -- Leave non-representable arguments unchanged
+ return expr
-- Leave all other expressions unchanged
appsimpl expr = return expr
-- Perform this transform everywhere
appsimpltop = everywhere ("appsimpl", appsimpl)
--- TODO: introduce top level let if needed?
+--------------------------------
+-- 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.
+argprop, argproptop :: 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.
+argprop expr@(App _ _) | is_var fexpr = 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 = do
+ repr <- isRepr arg
+ bndrs <- Trans.lift getGlobalBinders
+ let interesting var = Var.isLocalVar var && (not $ var `elem` 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
+ -- arguments with free type variables (since those would require types
+ -- not known yet, which will always be known eventually).
+ -- 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 free_vars = VarSet.varSetElems $ CoreFVs.exprSomeFreeVars interesting arg
+ -- Mark the current expression as changed
+ setChanged
+ 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.
+ -- 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
+argprop expr = return expr
+-- Perform this transform everywhere
+argproptop = everywhere ("argprop", argprop)
+
+--------------------------------
+-- 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
+
+-- 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 = [etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, 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)
+ -> [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
--- Normalize a core expression by running transforms until none applies
--- anymore. Uses a UniqSupply to generate new identifiers.
-normalize :: UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
-normalize = dotransforms transforms
+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)
+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!"
projects / matthijs / master-project / cλash.git / blobdiff