diff options
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 20 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 38 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 15 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 53 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 18 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 29 |
7 files changed, 66 insertions, 115 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 57b0cdaf89..8b3bac3b4f 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -118,33 +118,33 @@ variable. -} cgTopBinding :: DynFlags -> StgBinding -> FCode () cgTopBinding dflags (StgNonRec id rhs) = do { id' <- maybeExternaliseId dflags id - ; (info, fcode) <- cgTopRhs NonRecursive id' rhs + ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs ; fcode - ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + ; addBindC info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs' - ; let (infos, fcodes) = unzip r + r = unzipWith (cgTopRhs dflags Recursive) pairs' + (infos, fcodes) = unzip r ; addBindsC infos ; sequence_ fcodes } -cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) +cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary -cgTopRhs _rec bndr (StgRhsCon _cc con args) - = forkStatics (cgTopRhsCon bndr con args) +cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) + = cgTopRhsCon dflags bndr con args -cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) +cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body) + cgTopRhsClosure dflags rec bndr cc bi upd_flag args body --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 7cac6ad263..ba1e0597ba 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -58,22 +58,21 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: RecFlag -- member of a recursive group? +cgTopRhsClosure :: DynFlags + -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> UpdateFlag -> [Id] -- Args -> StgExpr - -> FCode (CgIdInfo, FCode ()) - -cgTopRhsClosure rec id ccs _ upd_flag args body - = do { dflags <- getDynFlags - ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - ; return (cg_id_info, gen_code dflags lf_info closure_label) - } + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure dflags rec id ccs _ upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -128,7 +127,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) = do { (info, fcode) <- cgRhs name rhs - ; addBindC (cg_id info) info + ; addBindC info ; init <- fcode ; emit init } -- init cannot be used in body, so slightly better to sink it eagerly @@ -316,8 +315,8 @@ mkRhsClosure dflags bndr _cc _bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure _ bndr cc _ fvs upd_flag args body - = do { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args +mkRhsClosure dflags bndr cc _ fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where @@ -410,17 +409,18 @@ cgRhsStdThunk bndr lf_info payload ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: Id -- The binder +mkClosureLFInfo :: DynFlags + -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> FCode LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag) + -> LambdaFormInfo +mkClosureLFInfo dflags bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag | otherwise = - do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) } + mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) ------------------------------------------------------------------------ diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 4f12948bcc..57d4759346 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -50,22 +50,21 @@ import Data.Char -- Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: Id -- Name of thing bound to this RHS +cgTopRhsCon :: DynFlags + -> Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode (CgIdInfo, FCode ()) -cgTopRhsCon id con args - = do dflags <- getDynFlags - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - return ( id_info, gen_code ) + -> (CgIdInfo, FCode ()) +cgTopRhsCon dflags id con args = + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + in (id_info, gen_code) where name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code = - do { dflags <- getDynFlags - ; this_mod <- getModuleName + do { this_mod <- getModuleName ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags this_mod con args) ) return () diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 77a3b4e249..353fec5a5f 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -8,8 +8,6 @@ module StgCmmEnv ( CgIdInfo, - cgIdInfoId, cgIdInfoLF, - litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, idInfoToAmode, @@ -113,12 +111,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer addDynTag dflags expr tag = cmmOffsetB dflags expr tag -cgIdInfoId :: CgIdInfo -> Id -cgIdInfoId = cg_id - -cgIdInfoLF :: CgIdInfo -> LambdaFormInfo -cgIdInfoLF = cg_lf - maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) maybeLetNoEscape _other = Nothing @@ -132,10 +124,10 @@ maybeLetNoEscape _other = Nothing -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. --------------------------------------------------------- -addBindC :: Id -> CgIdInfo -> FCode () -addBindC name stuff_to_bind = do +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do binds <- getBinds - setBinds $ extendVarEnv binds name stuff_to_bind + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do @@ -147,39 +139,26 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first - ; local_binds <- getBinds + = do { dflags <- getDynFlags + ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; - Nothing -> do - - { -- Try top-level bindings - static_binds <- getStaticBinds - ; case lookupVarEnv static_binds id of { - Just info -> return info ; - Nothing -> + Nothing -> do { -- Should be imported; make up a CgIdInfo for it - let - name = idName id - in - if isExternalName name then do - let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - dflags <- getDynFlags - return (litIdInfo dflags id (mkLFImported id) ext_lbl) - else - -- Bug - cgLookupPanic id - }}}} + let name = idName id + ; if isExternalName name then + let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) + in return (litIdInfo dflags id (mkLFImported id) ext_lbl) + else + cgLookupPanic id -- Bug + }}} cgLookupPanic :: Id -> FCode a cgLookupPanic id - = do static_binds <- getStaticBinds - local_binds <- getBinds + = do local_binds <- getBinds pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, - ptext (sLit "static binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] ]) @@ -210,7 +189,7 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg bindToReg nvid@(NonVoid id) lf_info = do dflags <- getDynFlags let reg = idToReg dflags nvid - addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) return reg rebindToReg :: NonVoid Id -> FCode LocalReg @@ -218,7 +197,7 @@ rebindToReg :: NonVoid Id -> FCode LocalReg -- get its LF info from the envt rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg nvid (cgIdInfoLF info) } + ; bindToReg nvid (cg_lf info) } bindArgToReg :: NonVoid Id -> FCode LocalReg bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 00c6068fb0..b19341bc8c 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -106,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs) -- See Note [Saving the current cost centre] ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs ; fcode - ; addBindC (cg_id info) info } + ; addBindC info } cgLneBinds join_id (StgRec pairs) = do { local_cc <- saveCurrentCostCentre @@ -676,9 +676,9 @@ cgTailCall fun_id fun_info args = do where fun_arg = StgVarArg fun_id - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cgIdInfoLF fun_info + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info node_points dflags = nodeMustPointToIt dflags lf_info diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index c6e57d5041..6c6e49dafa 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -39,8 +39,7 @@ import CmmInfo import CLabel import StgSyn import Id -import Name -import TyCon ( PrimRep(..) ) +import TyCon ( PrimRep(..) ) import BasicTypes ( RepArity ) import DynFlags import Module @@ -360,15 +359,14 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False -- bring in ARG_P, ARG_N, etc. #include "../includes/rts/storage/FunTypes.h" -mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = do dflags <- getDynFlags - let arg_bits = argBits dflags arg_reps - arg_reps = filter isNonV (map idArgRep args) +mkArgDescr :: DynFlags -> [Id] -> ArgDescr +mkArgDescr dflags args + = let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) + in case stdPattern arg_reps of + Just spec_id -> ArgSpec spec_id + Nothing -> ArgGen arg_bits argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 37b0a26df6..978cfa2ad2 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -26,7 +26,7 @@ module StgCmmMonad ( mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCall, mkCmmCall, - forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly, + forkClosureBody, forkAlts, forkProc, codeOnly, ConTagZ, @@ -48,7 +48,7 @@ module StgCmmMonad ( -- more localised access to monad state CgIdInfo(..), CgLoc(..), - getBinds, setBinds, getStaticBinds, + getBinds, setBinds, -- out of general friendliness, we also export ... CgInfoDownwards(..), CgState(..) -- non-abstract @@ -171,7 +171,6 @@ data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block @@ -299,7 +298,6 @@ initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags , cgd_mod = mod - , cgd_statics = emptyVarEnv , cgd_updfr_off = initUpdFrameOff dflags , cgd_ticky = mkTopTickyCtrLabel , cgd_sequel = initSequel } @@ -428,11 +426,6 @@ setBinds new_binds = do state <- getState setState $ state {cgs_binds = new_binds} -getStaticBinds :: FCode CgBindings -getStaticBinds = do - info <- getInfoDown - return (cgd_statics info) - withState :: FCode a -> CgState -> FCode (a,CgState) withState (FCode fcode) newstate = FCode $ \info_down state -> case fcode info_down newstate of @@ -548,24 +541,6 @@ forkClosureBody body_code ((),fork_state_out) = doFCode body_code body_info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } -forkStatics :: FCode a -> FCode a --- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come --- from the current *local bindings*, but which is otherwise freshly initialised. --- The Abstract~C returned is attached to the current state, but the --- bindings and usage information is otherwise unchanged. -forkStatics body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state - , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - (result, fork_state_out) = doFCode body_code rhs_info_down - (initCgState us) - ; setState (state `addCodeBlocksFrom` fork_state_out) - ; return result } - forkProc :: FCode a -> FCode a -- 'forkProc' takes a code and compiles it in the *current* environment, -- returning the graph thus constructed. |