Commit d2ce0f52 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Super-monster patch implementing the new typechecker -- at last

This major patch implements the new OutsideIn constraint solving
algorithm in the typecheker, following our JFP paper "Modular type
inference with local assumptions".  

Done with major help from Dimitrios Vytiniotis and Brent Yorgey.
parent 0084ab49
......@@ -56,7 +56,7 @@ name = Util.globalMVar (value);
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
#else
-- We have to actually use all the variables we are given or we may get
-- unused variable warnings when DEBUG is off.
......
......@@ -30,7 +30,7 @@ module Id (
mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
mkWorkerId,
mkWorkerId, mkWiredInIdName,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
......@@ -258,6 +258,9 @@ mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
......
......@@ -25,26 +25,22 @@ module MkId (
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
lazyId, lazyIdKey,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
mkRuntimeErrorApp, mkImpossibleExpr,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
unsafeCoerceName
-- Re-export error Ids
module PrelRules
) where
#include "HsVersions.h"
import Rules
import TysPrim
import TysWiredIn
import PrelRules
import Type
import Coercion
import TcType
import MkCore
import CoreUtils ( exprType, mkCoerce )
import CoreUnfold
import Literal
......@@ -362,7 +358,8 @@ mkDataConIds wrap_name wkr_name data_con
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
y = mkCoVar (mkSysTvName (mkBuiltinUnique i)
(fsLit "dc_co")) x
in (y:ys,j)
mk_case
......@@ -436,10 +433,12 @@ at the outside. When dealing with classes it's very convenient to
recover the original type signature from the class op selector.
\begin{code}
mkDictSelId :: Bool -- True <=> don't include the unfolding
-- Little point on imports without -O, because the
-- dictionary itself won't be visible
-> Name -> Class -> Id
mkDictSelId :: Bool -- True <=> don't include the unfolding
-- Little point on imports without -O, because the
-- dictionary itself won't be visible
-> Name -- Name of one of the *value* selectors
-- (dictionary superclass or method)
-> Class -> Id
mkDictSelId no_unf name clas
= mkGlobalId (ClassOpId clas) name sel_ty info
where
......@@ -474,7 +473,7 @@ mkDictSelId no_unf name clas
occNameFS (getOccName name)
, ru_fn = name
, ru_nargs = n_ty_args + 1
, ru_try = dictSelRule index n_ty_args }
, ru_try = dictSelRule val_index n_ty_args n_eq_args }
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
......@@ -485,41 +484,45 @@ mkDictSelId no_unf name clas
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
tycon = classTyCon clas
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
eq_theta = dataConEqTheta data_con
index = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
the_arg_id = arg_ids !! index
tycon = classTyCon clas
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
eq_theta = dataConEqTheta data_con
n_eq_args = length eq_theta
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
(eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
arg_ids = mkTemplateLocalsNum n arg_tys
-- 'index' is a 0-index into the *value* arguments of the dictionary
val_index = assoc "MkId.mkDictSelId" sel_index_prs name
sel_index_prs = map idName (classAllSelIds clas) `zip` [0..]
mkCoVarLocals i [] = ([],i)
mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
in (y:ys,j)
the_arg_id = arg_ids !! val_index
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
eq_ids = map mkWildEvBinder eq_theta
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
dictSelRule :: Int -> Arity -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Oh, very clever
-- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
-- op_i t1..tk (D t1..tk op1 ... opm) = opi
-- sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
-- NB: the data constructor has the same number of type args as the class op
dictSelRule index n_ty_args id_unf args
-- NB: the data constructor has the same number of type and
-- coercion args as the selector
--
-- This only works for *value* superclasses
-- There are no selector functions for equality superclasses
dictSelRule val_index n_ty_args n_eq_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (val_args !! index)
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
, let val_args = drop n_eq_args con_args
= Just (val_args !! val_index)
| otherwise
= Nothing
\end{code}
......@@ -644,7 +647,7 @@ mkReboxingAlt us con args rhs
-- Type variable case
go (arg:args) stricts us
| isTyVar arg
| isTyCoVar arg
= let (binds, args') = go args stricts us
in (binds, arg:args')
......@@ -884,31 +887,12 @@ they can unify with both unlifted and lifted types. Hence we provide
another gun with which to shoot yourself in the foot.
\begin{code}
mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
mkWiredInIdName mod fs uniq id
= mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
lazyIdName, errorName, recSelErrorName, runtimeErrorName :: Name
irrefutPatErrorName, recConErrorName, patErrorName :: Name
nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID
runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID
irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID
patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID
noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
nonExhaustiveGuardsErrorName
= mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError")
nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
\end{code}
\begin{code}
......@@ -974,7 +958,7 @@ lazyId = pcMiscPrelId lazyIdName ty info
Note [seqId magic]
~~~~~~~~~~~~~~~~~~
'GHC.Prim.seq' is special in several ways.
'GHC.Prim.seq' is special in several ways.
a) Its second arg can have an unboxed type
x `seq` (v +# w)
......@@ -986,6 +970,8 @@ c) It has quite a bit of desugaring magic.
d) There is some special rule handing: Note [User-defined RULES for seq]
e) See Note [Typing rule for seq] in TcExpr.
Note [User-defined RULES for seq]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Roman found situations where he had
......@@ -1071,81 +1057,6 @@ voidArgId -- :: State# RealWorld
\end{code}
%************************************************************************
%* *
\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
%* *
%************************************************************************
GHC randomly injects these into the code.
@patError@ is just a version of @error@ for pattern-matching
failures. It knows various ``codes'' which expand to longer
strings---this saves space!
@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
well shouldn't be yanked on, but if one is, then you will get a
friendly message from @absentErr@ (rather than a totally random
crash).
@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
\begin{code}
mkRuntimeErrorApp
:: Id -- Should be of type (forall a. Addr# -> a)
-- where Addr# points to a UTF8 encoded string
-> Type -- The type to instantiate 'a'
-> String -- The string to print
-> CoreExpr
mkRuntimeErrorApp err_id res_ty err_msg
= mkApps (Var err_id) [Type res_ty, err_string]
where
err_string = Lit (mkMachString err_msg)
mkImpossibleExpr :: Type -> CoreExpr
mkImpossibleExpr res_ty
= mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
pAT_ERROR_ID = mkRuntimeErrorId patErrorName
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
runtimeErrorTy :: Type
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
\begin{code}
eRROR_ID :: Id
eRROR_ID = pc_bottoming_Id errorName errorTy
errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
-- Notice the openAlphaTyVar. It says that "error" can be applied
-- to unboxed as well as boxed types. This is OK because it never
-- returns, so the return type is irrelevant.
\end{code}
%************************************************************************
%* *
\subsection{Utilities}
%* *
%************************************************************************
\begin{code}
pcMiscPrelId :: Name -> Type -> IdInfo -> Id
pcMiscPrelId name ty info
......@@ -1155,26 +1066,4 @@ pcMiscPrelId name ty info
-- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
pc_bottoming_Id :: Name -> Type -> Id
-- Function of arity 1, which diverges after being given one argument
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
`setArityInfo` 1
-- Make arity and strictness agree
-- Do *not* mark them as NoCafRefs, because they can indeed have
-- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
-- which has some CAFs
-- In due course we may arrange that these error-y things are
-- regarded by the GC as permanently live, in which case we
-- can give them NoCaf info. As it is, any function that calls
-- any pc_bottoming_Id will itself have CafRefs, which bloats
-- SRTs.
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-- These "bottom" out, no matter what their arguments
\end{code}
......@@ -25,8 +25,8 @@
-- Global 'Id's and 'Var's are those that are imported or correspond to a data constructor, primitive operation, or record selectors.
-- Local 'Id's and 'Var's are those bound within an expression (e.g. by a lambda) or at the top level of the module being compiled.
module Var (
-- * The main data type
Var,
-- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
......@@ -41,14 +41,11 @@ module Var (
setIdExported, setIdNotExported,
-- ** Predicates
isCoVar, isId, isTyVar, isTcTyVar,
isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
isLocalVar, isLocalId,
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- * Type variable data type
TyVar,
-- ** Constructing 'TyVar's
mkTyVar, mkTcTyVar, mkWildCoVar,
......@@ -58,9 +55,6 @@ module Var (
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind,
-- * Coercion variable data type
CoVar,
-- ** Constructing 'CoVar's
mkCoVar,
......@@ -68,10 +62,8 @@ module Var (
coVarName,
-- ** Modifying 'CoVar's
setCoVarUnique, setCoVarName,
setCoVarUnique, setCoVarName
-- * 'Var' type synonyms
Id, DictId
) where
#include "HsVersions.h"
......@@ -93,6 +85,30 @@ import Data.Data
\end{code}
%************************************************************************
%* *
Synonyms
%* *
%************************************************************************
-- These synonyms are here and not in Id because otherwise we need a very
-- large number of SOURCE imports of Id.hs :-(
\begin{code}
type EvVar = Var -- An evidence variable: dictionary or equality constraint
-- Could be an DictId or a CoVar
type Id = Var -- A term-level identifier
type DFunId = Id -- A dictionary function
type EvId = Id -- Term-level evidence: DictId or IpId
type DictId = EvId -- A dictionary variable
type IpId = EvId -- A term-level implicit parameter
type TyVar = Var
type CoVar = TyVar -- A coercion variable is simply a type
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
\end{code}
%************************************************************************
%* *
\subsection{The main data type declarations}
......@@ -124,7 +140,7 @@ data Var
varName :: !Name,
realUnique :: FastInt,
varType :: Kind,
tcTyVarDetails :: TcTyVarDetails }
tc_tv_details :: TcTyVarDetails }
| Id {
varName :: !Name,
......@@ -166,7 +182,7 @@ instance Outputable Var where
ppr_debug :: Var -> SDoc
ppr_debug (TyVar {}) = ptext (sLit "tv")
ppr_debug (TcTyVar {tcTyVarDetails = d}) = pprTcTyVarDetails d
ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
ppr_id_scope :: IdScope -> SDoc
......@@ -229,8 +245,6 @@ setVarType id ty = id { varType = ty }
%************************************************************************
\begin{code}
type TyVar = Var
tyVarName :: TyVar -> Name
tyVarName = varName
......@@ -262,8 +276,12 @@ mkTcTyVar name kind details
TcTyVar { varName = name,
realUnique = getKeyFastInt (nameUnique name),
varType = kind,
tcTyVarDetails = details
tc_tv_details = details
}
tcTyVarDetails :: TyVar -> TcTyVarDetails
tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
\end{code}
%************************************************************************
......@@ -273,10 +291,6 @@ mkTcTyVar name kind details
%************************************************************************
\begin{code}
type CoVar = TyVar -- A coercion variable is simply a type
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
coVarName :: CoVar -> Name
coVarName = varName
......@@ -307,11 +321,6 @@ mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
%************************************************************************
\begin{code}
-- These synonyms are here and not in Id because otherwise we need a very
-- large number of SOURCE imports of Id.hs :-(
type Id = Var
type DictId = Var
idInfo :: Id -> IdInfo
idInfo (Id { id_info = info }) = info
idInfo other = pprPanic "idInfo" (ppr other)
......@@ -375,11 +384,20 @@ setIdNotExported id = ASSERT( isLocalId id )
%************************************************************************
\begin{code}
isTyVar :: Var -> Bool -- True of both type and coercion variables
isTyVar (TyVar {}) = True
isTyCoVar :: Var -> Bool -- True of both type and coercion variables
isTyCoVar (TyVar {}) = True
isTyCoVar (TcTyVar {}) = True
isTyCoVar _ = False
isTyVar :: Var -> Bool -- True of both type variables only
isTyVar v@(TyVar {}) = not (isCoercionVar v)
isTyVar (TcTyVar {}) = True
isTyVar _ = False
isCoVar :: Var -> Bool -- Only works after type checking (sigh)
isCoVar v@(TyVar {}) = isCoercionVar v
isCoVar _ = False
isTcTyVar :: Var -> Bool
isTcTyVar (TcTyVar {}) = True
isTcTyVar _ = False
......@@ -392,11 +410,6 @@ isLocalId :: Var -> Bool
isLocalId (Id { idScope = LocalId _ }) = True
isLocalId _ = False
isCoVar :: Var -> Bool
isCoVar (v@(TyVar {})) = isCoercionVar v
isCoVar (TcTyVar {varType = kind}) = isCoercionKind kind -- used during solving
isCoVar _ = False
-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's
-- These are the variables that we need to pay attention to when finding free
-- variables, or doing dependency analysis.
......
......@@ -27,7 +27,8 @@ module VarEnv (
-- ** Operations on InScopeSets
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
getInScopeVars, lookupInScope, lookupInScope_Directly,
elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
......@@ -114,6 +115,10 @@ elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
-- the variable's identity (unique) to its full value.
lookupInScope :: InScopeSet -> Var -> Maybe Var
lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v
lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
lookupInScope_Directly (InScope in_scope _) uniq
= lookupVarEnv_Directly in_scope uniq
\end{code}
\begin{code}
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
module CmmBuildInfoTables
( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
......
......@@ -235,6 +235,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
start_block = lookupWithDefaultBEnv blocks unknown_block start
children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
unknown_block :: a -- Used at more than one type
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
body = start_block : children_blocks
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
......@@ -153,7 +157,10 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
run :: FuelMonad a -> IO a
run = runFuelIO (hsc_OptFuel hsc_env)
dual_rewrite flag txt pass g =
do dump flag ("Pre " ++ txt) g
g <- run $ pass g
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
module CmmSpillReload
( DualLive(..)
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
, layout, manifestSP, igraph, areaBuilder
......
......@@ -461,25 +461,32 @@ postorder_dfs g@(LGraph _ blockenv) =
let FGraph id eblock _ = entry g in
zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l)
=> BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
postorder_dfs_from_except blocks b visited =
vchildren (get_children b) (\acc _visited -> acc) [] visited
postorder_dfs_from_except blocks b visited
= vchildren (get_children b) (\acc _visited -> acc) [] visited
where
-- vnode ::
-- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
-> [Block m l] -> BlockSet -> a
vnode block@(Block id _) cont acc visited =
if elemBlockSet id visited then
cont acc visited
else
let cont' acc visited = cont (block:acc) visited in
vchildren (get_children block) cont' acc (extendBlockSet visited id)
vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
-> [Block m l] -> BlockSet -> a
vchildren bs cont acc visited =
let next children acc visited =
case children of [] -> cont acc visited
(b:bs) -> vnode b (next bs) acc visited
in next bs acc visited
get_children :: HavingSuccessors c => c -> [Block m l]
get_children block = foldl add_id [] (succs block)
add_id :: [Block m l] -> BlockId -> [Block m l]
add_id rst id = case lookupBlockEnv blocks id of
Just b -> b : rst
Nothing -> rst
......