import qualified UniqSupply
import qualified CoreUtils
import qualified Type
+import qualified TcType
import qualified Id
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
-- 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 is applicable (to prevent loops with inlinefun).
-letsimpl (Let (Rec binds) expr) | not $ is_applicable expr = do
- id <- mkInternalVar "foo" (CoreUtils.exprType expr)
- let bind = (id, expr)
- change $ Let (Rec (bind:binds)) (Var id)
+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) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e))
--------------------------------
-- Function inlining
-- 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 (is_applicable . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
--------------------------------
-- Scrutinee simplification
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 =
- -- 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
+ 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
--------------------------------
-- 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 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
--- the new binder in the application.
-appsimpl (App f expr) | (not $ is_applicable 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)
-
---------------------------------
--- Type argument propagation
---------------------------------
--- Remove all applications to type arguments, by duplicating the function
--- called with the type application in its new definition. We leave
--- dictionaries that might be associated with the type untouched, the funprop
--- transform should propagate these later on.
-typeprop, typeproptop :: Transform
--- Transform any function that is applied to a type argument. Since type
--- arguments are always the first ones to apply and we'll remove all type
--- arguments, we can simply do them one by one. We only propagate type
--- 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
- body_maybe <- Trans.lift $ getGlobalBind f
- case body_maybe of
- Just body -> do
- let newbody = App body (Type ty)
- -- 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).
- Nothing -> return expr
--- Leave all other expressions unchanged
-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
+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.
-funprop expr@(App _ _) | is_var fexpr && not (any has_free_tyvars args) = do
+argprop expr@(App _ _) | is_var fexpr = do
-- Find the body of the function called
body_maybe <- Trans.lift $ getGlobalBind f
case body_maybe of
-- 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
+ doarg arg = do
+ repr <- isRepr arg
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)
+ 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
-funprop expr = return expr
+argprop expr = return expr
-- Perform this transform everywhere
-funproptop = everywhere ("funprop", funprop)
+argproptop = everywhere ("argprop", argprop)
--------------------------------
-- Function-typed argument extraction
-- What transforms to run?
-transforms = [typeproptop, funproptop, funextracttop, etatop, betatop, castproptop, 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 ::
- UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+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)] -- ^ The resulting VHDL
+ -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL
-normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do
+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
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
+ 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.isLocalIdVar bndr) $ do
+ 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)
-- 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'
+ 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
projects / matthijs / master-project / cλash.git / blobdiff