diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/CgInfoTbls.hs | 6 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 81 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 320 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 71 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 26 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 71 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 126 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmForeign.hs | 129 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 132 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 112 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 103 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 5 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 42 |
14 files changed, 719 insertions, 513 deletions
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 9fbe4fb36d..9719d71dd2 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -94,12 +94,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) where info = case lf_info of @@ -152,7 +152,7 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable + (CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 56cd1d5555..0fc6c4c5a8 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -104,43 +104,25 @@ variable. -} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () cgTopBinding dflags (StgNonRec id rhs, _srts) = do { id' <- maybeExternaliseId dflags id - --; mapM_ (mkSRT [id']) srts - ; (id,info) <- cgTopRhs id' rhs - ; addBindC id info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + ; info <- cgTopRhs id' rhs + ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs, _srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - --; mapM_ (mkSRT bndrs') srts ; fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; return () } ---mkSRT :: [Id] -> (Id,[Id]) -> FCode () ---mkSRT these (id,ids) --- | null ids = nopC --- | otherwise --- = do { ids <- mapFCs remap ids --- ; id <- remap id --- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id)) --- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) --- } --- where --- -- Sigh, better map all the ids against the environment in --- -- case they've been externalised (see maybeExternaliseId below). --- remap id = case filter (==id) these of --- (id':_) -> returnFC id' --- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } - -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the -- statics "error" call in initC. I DON'T UNDERSTAND WHY! -cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary @@ -153,7 +135,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body) - --------------------------------------------------------------- -- Module initialisation code --------------------------------------------------------------- @@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info -- In this way, Hpc enabled modules can interact seamlessly with -- not Hpc enabled moduled, provided Main is compiled with Hpc. - ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId + ; updfr_sz <- getUpdFrameOff + ; tail <- getCode (pushUpdateFrame imports + (do updfr_sz' <- getUpdFrameOff + emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) + ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs + [ check_already_done retId updfr_sz , init_prof , init_hpc - , catAGraphs $ map (registerImport way) all_imported_mods - , mkBranch retId ] + , tail]) -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init + ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) -- When compiling the module in which the 'main' function lives, -- (that is, this_mod == main_mod) @@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) + (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) } where plain_init_lbl = mkPlainModuleInitLabel this_mod real_init_lbl = mkModuleInitLabel this_mod way plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - jump_to_init = mkJump (mkLblExpr real_init_lbl) [] + jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz -- Main refers to GHC.TopHandler.runIO, so make sure we call the @@ -249,34 +233,30 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info | this_mod == main_mod = [gHC_TOP_HANDLER] | otherwise = [] all_imported_mods = imported_mods ++ extra_imported_mods + imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) + (filter (gHC_PRIM /=) all_imported_mods) mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId + check_already_done retId updfr_sz = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId Nothing <*> mkReturn []) mkNop + (mkLabel retId emptyStackInfo + <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop <*> -- Set mod_reg to 1 to record that we've been here mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = mkAssign spReg (cmmRegOffW spReg 1) - <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerImport :: String -> Module -> CmmAGraph -registerImport way mod - | mod == gHC_PRIM - = mkNop - | otherwise -- Push the init procedure onto the work stack - = mkCmmCall init_lbl [] [] NoC_SRT - where - init_lbl = mkLblExpr $ mkModuleInitLabel mod way + -- incrementing Sp, and then jumps to the popped item + ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord + ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) + -- mkAssign spReg (cmmRegOffW spReg 1) <*> + -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz + pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) + rec_descent_init updfr_sz = + if opt_SccProfilingOn || isHpcUsed hpc_info + then jump_to_init updfr_sz + else ret_code updfr_sz --------------------------------------------------------------- -- Generating static stuff for algebraic data types @@ -351,8 +331,7 @@ cgDataCon data_con (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps emit_info cl_info ticky_code - = do { code_blks <- getCode (mk_code ticky_code) - ; emitClosureCodeAndInfoTable cl_info [] code_blks } + = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0e8d853969..04676787fe 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -9,11 +9,13 @@ module StgCmmBind ( cgTopRhsClosure, cgBind, - emitBlackHoleCode + emitBlackHoleCode, + pushUpdateFrame ) where #include "HsVersions.h" +import StgCmmExpr import StgCmmMonad import StgCmmExpr import StgCmmEnv @@ -35,6 +37,7 @@ import CLabel import StgSyn import CostCentre import Id +import Monad (foldM, liftM) import Name import Module import ListSetOps @@ -59,11 +62,11 @@ cgTopRhsClosure :: Id -> StgBinderInfo -> UpdateFlag -> SRT - -> [Id] -- Args + -> [Id] -- Args -> StgExpr - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo -cgTopRhsClosure id ccs binder_info upd_flag srt args body = do +cgTopRhsClosure id ccs _ upd_flag srt args body = do { -- LAY OUT THE OBJECT let name = idName id ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args @@ -77,12 +80,15 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep - ; forkClosureBody $ do - { node <- bindToReg id lf_info - ; closureCodeBody binder_info closure_info - ccs srt_info node args body } + ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] + (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) + (addIdReps []) + -- Don't drop the non-void args until the closure info has been made + ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info + (nonVoidIds args) (length args) body fv_details) - ; returnFC (id, cg_id_info) } + ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $ + returnFC cg_id_info } ------------------------------------------------------------------------ -- Non-top-level bindings @@ -90,36 +96,77 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) - = do { (name, info) <- cgRhs name rhs - ; addBindC name info } + = do { ((info, init), body) <- getCodeR $ cgRhs name rhs + ; addBindC (cg_id info) info + ; emit (init <*> body) } cgBind (StgRec pairs) - = do { new_binds <- fixC (\ new_binds -> - do { addBindsC new_binds - ; listFCs [ cgRhs b e | (b,e) <- pairs ] }) - ; addBindsC new_binds } + = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> + do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction + ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] }) + ; addBindsC new_binds + ; emit (catAGraphs inits <*> body) } + +{- Recursive let-bindings are tricky. + Consider the following pseudocode: + let x = \_ -> ... y ... + y = \_ -> ... z ... + z = \_ -> ... x ... + in ... + For each binding, we need to allocate a closure, and each closure must + capture the address of the other closures. + We want to generate the following C-- code: + // Initialization Code + x = hp - 24; // heap address of x's closure + y = hp - 40; // heap address of x's closure + z = hp - 64; // heap address of x's closure + // allocate and initialize x + m[hp-8] = ... + m[hp-16] = y // the closure for x captures y + m[hp-24] = x_info; + // allocate and initialize y + m[hp-32] = z; // the closure for y captures z + m[hp-40] = y_info; + // allocate and initialize z + ... + + For each closure, we must generate not only the code to allocate and + initialize the closure itself, but also some Initialization Code that + sets a variable holding the closure pointer. + The complication here is that we don't know the heap offsets a priori, + which has two consequences: + 1. we need a fixpoint + 2. we can't trivially separate the Initialization Code from the + code that compiles the right-hand-sides + + Note: We don't need this complication with let-no-escapes, because + in that case, the names are bound to labels in the environment, + and we don't need to emit any code to witness that binding. +-} -------------------- -cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph) -- The Id is passed along so a binding can be set up + -- The returned values are the binding for the environment + -- and the Initialization Code that witnesses the binding cgRhs name (StgRhsCon maybe_cc con args) - = do { idinfo <- buildDynCon name maybe_cc con args - ; return (name, idinfo) } + = buildDynCon name maybe_cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = mkRhsClosure name cc bi fvs upd_flag srt args body + = pprTrace "cgRhs closure" (ppr name <+> ppr args) $ + mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo - -> [Id] -- Free vars + -> [NonVoid Id] -- Free vars -> UpdateFlag -> SRT - -> [Id] -- Args + -> [Id] -- Args -> StgExpr - -> FCode (Id, CgIdInfo) + -> FCode (CgIdInfo, CmmAGraph) {- mkRhsClosure looks for two special forms of the right-hand side: a) selector thunks @@ -158,7 +205,7 @@ for semi-obvious reasons. ---------- Note [Selectors] ------------------ mkRhsClosure bndr cc bi - [the_fv] -- Just one free var + [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk _srt [] -- A thunk @@ -184,7 +231,7 @@ mkRhsClosure bndr cc bi (isUpdatable upd_flag) (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout - maybe_offset = assocMaybe params_w_offsets selectee + maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize @@ -197,7 +244,7 @@ mkRhsClosure bndr cc bi body@(StgApp fun_id args) | args `lengthIs` (arity-1) - && all isFollowableArg (map idCgRep fvs) + && all isFollowableArg (map (idCgRep . stripNV) fvs) && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE @@ -211,19 +258,19 @@ mkRhsClosure bndr cc bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure bndr cc bi fvs upd_flag srt args body +mkRhsClosure bndr cc _ fvs upd_flag srt args body = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. -- NB we can be sure that Node will point to it, because we - -- havn't told mkClosureLFInfo about this; so if the binder + -- haven't told mkClosureLFInfo about this; so if the binder -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* -- stored in the closure itself, so it will make sure that -- Node points to it... ; let is_elem = isIn "cgRhsClosure" - bndr_is_a_fv = bndr `is_elem` fvs - reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] + bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] | otherwise = fvs @@ -233,43 +280,35 @@ mkRhsClosure bndr cc bi fvs upd_flag srt args body ; c_srt <- getSRTInfo srt ; let name = idName bndr descr = closureDescription mod_name name - fv_details :: [(Id, VirtualHpOffset)] + fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) - (addIdReps reduced_fvs) + (addIdReps (map stripNV reduced_fvs)) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds c_srt descr -- BUILD ITS INFO TABLE AND CODE - ; forkClosureBody $ do - { -- Bind the binder itself - -- It does no harm to have it in the envt even if - -- it's not a free variable; and we need a reg for it - node <- bindToReg bndr lf_info - - -- Bind the free variables - ; mapCs (bind_fv node) fv_details - - -- And compile the body - ; closureCodeBody bi closure_info cc c_srt node args body } + ; forkClosureBody $ + -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere + -- (b) ignore Sequel from context; use empty Sequel + -- And compile the body + closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args) + (length args) body fv_details -- BUILD THE OBJECT ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body ; emit (mkComment $ mkFastString "calling allocDynClosure") - ; tmp <- allocDynClosure closure_info use_cc blame_cc - (mapFst StgVarArg fv_details) + ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) + ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc + (map toVarArg fv_details) -- RETURN - ; return (bndr, regIdInfo bndr lf_info tmp) } - where - -- A function closure pointer may be tagged, so we - -- must take it into account when accessing the free variables. - tag = tagForArity (length args) + ; return $ (regIdInfo bndr lf_info tmp, init) } - bind_fv node (id, off) - = do { reg <- rebindToReg id - ; emit $ mkTaggedObjectLoad reg node off tag } +-- Use with care; if used inappropriately, it could break invariants. +stripNV :: NonVoid a -> a +stripNV (NonVoid a) = a ------------------------- cgStdThunk @@ -279,7 +318,7 @@ cgStdThunk -> StgExpr -> LambdaFormInfo -> [StgArg] -- payload - -> FCode (Id, CgIdInfo) + -> FCode (CgIdInfo, CmmAGraph) cgStdThunk bndr cc _bndr_info body lf_info payload = do -- AHA! A STANDARD-FORM THUNK @@ -297,35 +336,36 @@ cgStdThunk bndr cc _bndr_info body lf_info payload ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body -- BUILD THE OBJECT - ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets + ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets -- RETURN - ; returnFC (bndr, regIdInfo bndr lf_info tmp) } + ; returnFC $ (regIdInfo bndr lf_info tmp, init) } mkClosureLFInfo :: Id -- The binder -> TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag - -> [Id] -- Args + -> [Id] -- Args -> FCode LambdaFormInfo mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top fvs upd_flag) + | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag) | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top fvs args arg_descr) } + ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) } ------------------------------------------------------------------------ -- The code for closures} ------------------------------------------------------------------------ -closureCodeBody :: StgBinderInfo -- XXX: unused? +closureCodeBody :: Bool -- whether this is a top-level binding + -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure -> C_SRT - -> LocalReg -- The closure itself; first argument - -- The Id is in scope already, bound to this reg - -> [Id] + -> [NonVoid Id] -- incoming args to the closure + -> Int -- arity, including void args -> StgExpr + -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables -> FCode () {- There are two main cases for the code for closures. @@ -341,41 +381,50 @@ closureCodeBody :: StgBinderInfo -- XXX: unused? argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL -} -closureCodeBody _binder_info cl_info cc srt node args body - | null args -- No args i.e. thunk - = do { code <- getCode $ thunkCode cl_info cc srt node body - ; emitClosureCodeAndInfoTable cl_info [node] code } +closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details + | length args == 0 -- No args i.e. thunk + = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $ + (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body) -closureCodeBody _binder_info cl_info cc srt node args body +closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details = ASSERT( length args > 0 ) do { -- Allocate the global ticky counter, -- and establish the ticky-counter -- label for this block let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info - ; emitTickyCounter cl_info args + ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do --- -- XXX: no slow-entry code for now --- -- Emit the slow-entry code --- { reg_save_code <- mkSlowEntryCode cl_info reg_args - -- Emit the main entry code - ; let node_points = nodeMustPointToIt (closureLFInfo cl_info) - ; arg_regs <- bindArgsToRegs args - ; blks <- forkProc $ getCode $ do - { enterCostCentre cl_info cc body + ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do + -- Emit the slow-entry code (for entering a closure through a PAP) + { mkSlowEntryCode cl_info arg_regs + + ; let lf_info = closureLFInfo cl_info + node_points = nodeMustPointToIt lf_info ; tickyEnterFun cl_info ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points -- Main payload - ; entryHeapCheck node arg_regs srt $ - cgExpr body } + ; entryHeapCheck node arity arg_regs srt $ do + { enterCostCentre cl_info cc body + ; fv_bindings <- mapM bind_fv fv_details + ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after* + ; cgExpr body }} -- heap check, to reduce live vars over check - ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks } -{- +-- A function closure pointer may be tagged, so we +-- must take it into account when accessing the free variables. +bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff) +bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } + +load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () +load_fvs node lf_info = mapCs (\ (reg, off) -> + pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag) + where tag = lfDynTag lf_info + ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its -- arguments on the stack. It loads the arguments into registers @@ -383,76 +432,53 @@ closureCodeBody _binder_info cl_info cc srt node args body -- normal entry point. The function's closure is assumed to be in -- R1/node. -- --- The slow entry point is used in two places: --- --- (a) unknown calls: eg. stg_PAP_entry --- (b) returning from a heap-check failure +-- The slow entry point is used for unknown calls: eg. stg_PAP_entry -mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts +mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () -- If this function doesn't have a specialised ArgDescr, we need --- to generate the function's arg bitmap, slow-entry code, and --- register-save code for the heap-check failure --- Here, we emit the slow-entry code, and --- return the register-save assignments -mkSlowEntryCode cl_info reg_args +-- to generate the function's arg bitmap and slow-entry code. +-- Here, we emit the slow-entry code. +mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do { emitSimpleProc slow_lbl (emitStmts load_stmts) - ; return save_stmts } - | otherwise = return noStmts + = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl + arg_regs jump + | otherwise = return () where - name = closureName cl_info - slow_lbl = mkSlowEntryLabel name - - load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] - save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts - - reps_w_regs :: [(CgRep,GlobalReg)] - reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] - (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) - 0 reps_w_regs - - load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets - mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) - (CmmLoad (cmmRegOffW spReg offset) - (argMachRep rep)) - - save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg ) - CmmStore (cmmRegOffW spReg offset) - (CmmReg (CmmGlobal reg)) - - stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) [] --} + caf_refs = clHasCafRefs cl_info + name = closureName cl_info + slow_lbl = mkSlowEntryLabel name caf_refs + fast_lbl = enterLocalIdLabel name caf_refs + jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) + initUpdFrameOff +mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" ----------------------------------------- -thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode () -thunkCode cl_info cc srt node body +thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> + C_SRT -> LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details cc srt node arity body = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) - ; tickyEnterThunk cl_info ; ldvEnterClosure cl_info -- NB: Node always points when profiling ; granThunk node_points -- Heap overflow check - ; entryHeapCheck node [] srt $ do + ; entryHeapCheck node arity [] srt $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check whenC (blackHoleOnEntry cl_info && node_points) (blackHoleIt cl_info) -- Push update frame - ; setupUpdate cl_info node - + ; setupUpdate cl_info node $ -- We only enter cc after setting up update so -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - ; enterCostCentre cl_info cc body - - ; cgExpr body } } + do { enterCostCentre cl_info cc body + ; let lf_info = closureLFInfo cl_info + ; fv_bindings <- mapM bind_fv fv_details + ; load_fvs node lf_info fv_bindings + ; cgExpr body }}} ------------------------------------------------------------------------ @@ -491,18 +517,20 @@ emitBlackHoleCode is_single_entry eager_blackholing = False -setupUpdate :: ClosureInfo -> LocalReg -> FCode () +setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre -setupUpdate closure_info node +setupUpdate closure_info node body | closureReEntrant closure_info - = return () + = body | not (isStaticClosure closure_info) = if closureUpdReqd closure_info - then do { tickyPushUpdateFrame; pushUpdateFrame node } - else tickyUpdateFrameOmitted + then do { tickyPushUpdateFrame; + ; pushUpdateFrame [CmmReg (CmmLocal node), + mkLblExpr mkUpdInfoLabel] body } + else do { tickyUpdateFrameOmitted; body} | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -510,14 +538,23 @@ setupUpdate closure_info node ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf closure_info True - ; pushUpdateFrame upd_closure } - else tickyUpdateFrameOmitted + ; pushUpdateFrame [CmmReg (CmmLocal upd_closure), + mkLblExpr mkUpdInfoLabel] body } + else do {tickyUpdateFrameOmitted; body} } -pushUpdateFrame :: LocalReg -> FCode () -pushUpdateFrame cl_reg - = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel) - [CmmReg (CmmLocal cl_reg)]) +-- Push the update frame on the stack in the Entry area, +-- leaving room for the return address that is already +-- at the old end of the area. +pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode () +pushUpdateFrame es body + = do updfr <- getUpdFrameOff + offset <- foldM push updfr es + withUpdFrameOff offset body + where push off e = + do emit (mkStore (CmmStackSlot (CallArea Old) base) e) + return base + where base = off + widthInBytes (cmmExprWidth e) ----------------------------------------------------------------------------- -- Entering a CAF @@ -565,7 +602,8 @@ link_caf cl_info is_upd = do { -- Alloc black hole specifying CC_HDR(Node) as the cost centre ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc - ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; emit init -- Call the RTS function newCAF to add the CAF to the CafList -- so that the garbage collector can find them diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c32d7cd857..b4251636b9 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -73,7 +73,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..)) import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..) ) +import Cmm ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel @@ -236,7 +236,7 @@ mkLFLetNoEscape = LFLetNoEscape ------------- mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [Id] -- Free vars -> [Id] -- Args -> ArgDescr -- Argument descriptor -> LambdaFormInfo @@ -335,8 +335,10 @@ tagForArity arity | isSmallFamily arity = arity | otherwise = 0 lfDynTag :: LambdaFormInfo -> DynTag -lfDynTag (LFCon con) = tagForCon con -lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity +-- Return the tag in the low order bits of a variable bound +-- to this LambdaForm +lfDynTag (LFCon con) = pprTrace "tagForCon" (ppr con <+> ppr (tagForCon con)) $ tagForCon con +lfDynTag (LFReEntrant _ arity _ _) = pprTrace "reentrant" (ppr arity) $ tagForArity arity lfDynTag _other = 0 @@ -506,7 +508,8 @@ getCallMethod name caf (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel name caf) arity + | otherwise = pprTrace "getCallMethod" (ppr name <+> ppr arity) $ + DirectEntry (enterIdLabel name caf) arity getCallMethod _name _ LFUnLifted n_args = ASSERT( n_args == 0 ) ReturnIt @@ -675,7 +678,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureCafs :: !CafInfo -- whether the closure may have CAFs } -- Constructor closures don't have a unique info table label (they use @@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureCafs = idCafInfo id } where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -743,39 +748,49 @@ mkConInfo is_static data_con tot_wds ptr_wds cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) + closureType = ty, + closureCafs = cafs }) = ClosureInfo { closureName = nm, closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureCafs = cafs } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) + closureType = ty, + closureCafs = cafs }) = ClosureInfo { closureName = nm, closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureCafs = cafs } seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo" -------------------------------------- -- Extracting ClosureTypeInfo -------------------------------------- -closureTypeInfo :: ClosureInfo -> ClosureTypeInfo -closureTypeInfo cl_info +-- JD: I've added the continuation arguments not for fun but because +-- I don't want to pipe the monad in here (circular module dependencies), +-- and I don't want to pull this code out of this module, which would +-- require us to expose a bunch of abstract types. + +closureTypeInfo :: + ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) -> + (ClosureTypeInfo -> a) -> a +closureTypeInfo cl_info k_with_con_name k_simple = case cl_info of ConInfo { closureCon = con } - -> ConstrInfo (ptrs, nptrs) - (fromIntegral (dataConTagZ con)) - con_name + -> k_with_con_name (ConstrInfo (ptrs, nptrs) + (fromIntegral (dataConTagZ con))) con info_lbl where - con_name = panic "closureTypeInfo" + --con_name = panic "closureTypeInfo" -- Was: -- cstr <- mkByteStringCLit $ dataConIdentity con -- con_name = makeRelativeRefTo info_lbl cstr @@ -783,23 +798,23 @@ closureTypeInfo cl_info ClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ arity _ arg_descr, closureSRT = srt } - -> FunInfo (ptrs, nptrs) - srt - (fromIntegral arity) - arg_descr - (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) + -> k_simple $ FunInfo (ptrs, nptrs) + srt + (fromIntegral arity) + arg_descr + (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _, closureSRT = srt } - -> ThunkSelectorInfo (fromIntegral offset) srt + -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt ClosureInfo { closureLFInfo = LFThunk {}, closureSRT = srt } - -> ThunkInfo (ptrs, nptrs) srt + -> k_simple $ ThunkInfo (ptrs, nptrs) srt _ -> panic "unexpected lambda form in mkCmmInfo" where --- info_lbl = infoTableLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info ptrs = fromIntegral $ closurePtrsSize cl_info size = fromIntegral $ closureNonHdrSize cl_info nptrs = size - ptrs @@ -1092,9 +1107,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? -- SRTs/CAFs -------------------------------------- --- This is horrible, but we need to know whether a closure may have CAFs. +-- We need to know whether a closure may have CAFs. clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs +clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs clHasCafRefs (ConInfo {}) = NoCafRefs diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index de1d77ad20..e818bd742c 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -27,6 +27,7 @@ import StgCmmProf import Cmm import CLabel +import MkZipCfgCmm (CmmAGraph, mkNop) import SMRep import CostCentre import Constants @@ -47,7 +48,7 @@ import Char ( ord ) cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo cgTopRhsCon id con args = do { #if mingw32_TARGET_OS @@ -67,7 +68,7 @@ cgTopRhsCon id con args = layOutStaticConstr con (addArgReps args) get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg - ; return lit } + ; return lit } ; payload <- mapM get_lit nv_args_w_offsets -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs @@ -83,7 +84,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) } + ; return $ litIdInfo id lf_info (CmmLabel closure_label) } --------------------------------------------------------------- @@ -96,7 +97,8 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args - -> FCode CgIdInfo -- Return details about how to find it + -> FCode (CgIdInfo, CmmAGraph) + -- Return details about how to find it and initialization code {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static @@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole! buildDynCon binder _cc con [] = return (litIdInfo binder (mkConLFInfo con) - (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder)))) + (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), + mkNop) -------- buildDynCon: Charlike and Intlike constructors ----------- {- The following three paragraphs about @Char@-like and @Int@-like @@ -155,7 +158,7 @@ buildDynCon binder _cc con [arg] offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = cmmLabelOffW intlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) intlike_amode) } + ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) } buildDynCon binder _cc con [arg] | maybeCharLikeCon con @@ -167,14 +170,14 @@ buildDynCon binder _cc con [arg] offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) charlike_amode) } + ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) } -------- buildDynCon: the general case ----------- buildDynCon binder ccs con args = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args) -- No void args in args_w_offsets - ; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets - ; return (regIdInfo binder lf_info tmp) } + ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets + ; return (regIdInfo binder lf_info tmp, init) } where lf_info = mkConLFInfo con @@ -204,10 +207,11 @@ bindConArgs (DataAlt con) base args -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. - bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg bind_arg (arg, offset) = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag - ; bindArgToReg arg } + ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $ + bindArgToReg arg } bindConArgs _other_con _base args = ASSERT( null args ) return [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index c43bf80174..67d82f08cd 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -14,6 +14,8 @@ module StgCmmEnv ( litIdInfo, lneIdInfo, regIdInfo, idInfoToAmode, + NonVoid(..), isVoidId, nonVoidIds, + addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, @@ -25,6 +27,7 @@ module StgCmmEnv ( #include "HsVersions.h" +import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure @@ -39,11 +42,28 @@ import PprCmm ( {- instance Outputable -} ) import Id import VarEnv import Maybes +import Monad import Name import StgSyn import Outputable +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) + +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +isVoidId :: Id -> Bool +isVoidId = isVoidRep . idPrimRep +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] ------------------------------------- -- Manipulating CgIdInfo @@ -65,15 +85,16 @@ lneIdInfo id regs blk_id = mkBlockId (idUnique id) litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit) +litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit) + mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info)) regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo -regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)) +regIdInfo id lf_info reg = + mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag }) - = addDynTag e tag +idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc @@ -105,10 +126,10 @@ addBindC name stuff_to_bind = do binds <- getBinds setBinds $ extendVarEnv binds name stuff_to_bind -addBindsC :: [(Id, CgIdInfo)] -> FCode () +addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do binds <- getBinds - let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) + let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info) binds new_bindings setBinds new_binds @@ -155,10 +176,11 @@ cgLookupPanic id -------------------- -getArgAmode :: StgArg -> FCode CmmExpr -getArgAmode (StgVarArg var) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } -getArgAmode (StgLitArg lit) = return (CmmLit (mkSimpleLit lit)) -getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = + do { info <- getCgIdInfo var; return (idInfoToAmode info) } +getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit +getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg" getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, @@ -166,7 +188,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode arg + | otherwise = do { amode <- getArgAmode (NonVoid arg) ; amodes <- getNonVoidArgAmodes args ; return ( amode : amodes ) } @@ -175,27 +197,27 @@ getNonVoidArgAmodes (arg:args) -- Interface functions for binding and re-binding names ------------------------------------------------------------------------ -bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg -bindToReg id lf_info - = do { let reg = idToReg id - ; addBindC id (regIdInfo id lf_info reg) +bindToReg nvid@(NonVoid id) lf_info + = do { let reg = idToReg nvid + ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) ; return reg } -rebindToReg :: Id -> FCode LocalReg +rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt -rebindToReg id +rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg id (cgIdInfoLF info) } + ; bindToReg nvid (cgIdInfoLF info) } -bindArgToReg :: Id -> FCode LocalReg -bindArgToReg id = bindToReg id (mkLFArgument id) +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) -bindArgsToRegs :: [Id] -> FCode [LocalReg] +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: Id -> LocalReg +idToReg :: NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -203,7 +225,8 @@ idToReg :: Id -> LocalReg -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg id = LocalReg (idUnique id) - (primRepCmmType (idPrimRep id)) +idToReg (NonVoid id) = LocalReg (idUnique id) + (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) + _ -> primRepCmmType (idPrimRep id)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 74c69b7216..379f1cde37 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -33,7 +33,9 @@ import Cmm() import CmmExpr import CoreSyn import DataCon +import ForeignCall import Id +import PrimOp import TyCon import CostCentre ( CostCentreStack, currentCCS ) import Maybes @@ -50,16 +52,16 @@ cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args - cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } -cgExpr (StgLit lit) = emitReturn [CmmLit (mkSimpleLit lit)] +cgExpr (StgLit lit) = do cmm_lit <- cgLit lit + emitReturn [CmmLit cmm_lit] -cgExpr (StgLet binds expr) = do { emit (mkComment $ mkFastString "calling cgBind"); cgBind binds; emit (mkComment $ mkFastString "calling cgExpr"); cgExpr expr } +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr } -cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) - = cgCase expr bndr srt alt_type alts +cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) = + cgCase expr bndr srt alt_type alts cgExpr (StgLam {}) = panic "cgExpr: StgLam" @@ -68,7 +70,7 @@ cgExpr (StgLam {}) = panic "cgExpr: StgLam" ------------------------------------------------------------------------ {- Generating code for a let-no-escape binding, aka join point is very -very similar to whatwe do for a case expression. The duality is +very similar to what we do for a case expression. The duality is between let-no-escape x = b in e @@ -86,8 +88,8 @@ cgLneBinds :: StgBinding -> FCode () cgLneBinds (StgNonRec bndr rhs) = do { local_cc <- saveCurrentCostCentre -- See Note [Saving the current cost centre] - ; (bndr,info) <- cgLetNoEscapeRhs local_cc bndr rhs - ; addBindC bndr info } + ; info <- cgLetNoEscapeRhs local_cc bndr rhs + ; addBindC (cg_id info) info } cgLneBinds (StgRec pairs) = do { local_cc <- saveCurrentCostCentre @@ -98,16 +100,24 @@ cgLneBinds (StgRec pairs) ; addBindsC new_bindings } + ------------------------- -cgLetNoEscapeRhs +cgLetNoEscapeRhs, cgLetNoEscapeRhsBody :: Maybe LocalReg -- Saved cost centre -> Id -> StgRhs - -> FCode (Id, CgIdInfo) - -cgLetNoEscapeRhs local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body) - = cgLetNoEscapeClosure bndr local_cc cc srt args body -cgLetNoEscapeRhs local_cc bndr (StgRhsCon cc con args) + -> FCode CgIdInfo + +cgLetNoEscapeRhs local_cc bndr rhs = + do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs + ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info + ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body) + ; return info + } + +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body) + = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args) -- For a constructor RHS we want to generate a single chunk of -- code which can be jumped to from many places, which will @@ -120,9 +130,9 @@ cgLetNoEscapeClosure -> Maybe LocalReg -- Slot for saved current cost centre -> CostCentreStack -- XXX: *** NOT USED *** why not? -> SRT - -> [Id] -- Args (as in \ args -> body) + -> [NonVoid Id] -- Args (as in \ args -> body) -> StgExpr -- Body (as in above) - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body = do { arg_regs <- forkProc $ do @@ -133,7 +143,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body -- Using altHeapCheck just reduces -- instructions to save on stack ; return arg_regs } - ; return (bndr, lneIdInfo bndr arg_regs) } + ; return $ lneIdInfo bndr arg_regs} ------------------------------------------------------------------------ @@ -253,6 +263,11 @@ data GcPlan ------------------------------------- cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode () +-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] + -- | isBoolTy (idType bndr) + -- , isDeadBndr bndr + -- = + cgCase scrut bndr srt alt_type alts = do { up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts @@ -270,7 +285,7 @@ cgCase scrut bndr srt alt_type alts ; restoreCurrentCostCentre mb_cc ; bindArgsToRegs ret_bndrs - ; cgAlts gc_plan bndr alt_type alts } + ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) @@ -279,17 +294,25 @@ maybeSaveCostCentre simple_scrut | otherwise = return Nothing - ----------------- isSimpleScrut :: StgExpr -> AltType -> Bool --- Simple scrutinee, does not allocate -isSimpleScrut (StgOpApp _ _ _) _ = True -isSimpleScrut (StgLit _) _ = True -isSimpleScrut (StgApp _ []) (PrimAlt _) = True +-- Simple scrutinee, does not block or allocate; hence safe to amalgamate +-- heap usage from alternatives into the stuff before the case +-- NB: if you get this wrong, and claim that the expression doesn't allocate +-- when it does, you'll deeply mess up allocation +isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op +isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } isSimpleScrut _ _ = False +isSimpleOp :: StgOp -> Bool +-- True iff the op cannot block or allocate +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe) +isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe! +isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) + ----------------- -chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [Id] +chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] -- These are the binders of a case that are assigned -- by the evaluation of the scrutinee -- Only non-void ones come back @@ -300,19 +323,16 @@ chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)] = nonVoidIds ids -- 'bndr' is not assigned! chooseReturnBndrs bndr (AlgAlt _) _alts - = [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs bndr PolyAlt _alts - = [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" -- UbxTupALt has only one alternative -nonVoidIds :: [Id] -> [Id] -nonVoidIds ids = [id | id <- ids, not (isVoidRep (idPrimRep id))] - ------------------------------------- -cgAlts :: GcPlan -> Id -> AltType -> [StgAlt] -> FCode () +cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode () -- At this point the result of the case are in the binders cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)] = maybeAltHeapCheck gc_plan (cgExpr rhs) @@ -347,7 +367,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts | (DataAlt con, cmm) <- tagged_cmms ] -- Is the constructor tag in the node reg? - ; if isSmallFamily fam_sz + ; if isSmallFamily fam_sz then let -- Yes, bndr_reg has constr. tag in ls bits tag_expr = cmmConstrTag1 (CmmReg bndr_reg) branches' = [(tag+1,branch) | (tag,branch) <- branches] @@ -366,7 +386,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- UbxTupAlt and PolyAlt have only one alternative ------------------- -cgAltRhss :: GcPlan -> Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] +cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] cgAltRhss gc_plan bndr alts = forkAlts (map cg_alt alts) where @@ -375,7 +395,7 @@ cgAltRhss gc_plan bndr alts cg_alt (con, bndrs, _uses, rhs) = getCodeR $ maybeAltHeapCheck gc_plan $ - do { bindConArgs con base_reg bndrs + do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs ; cgExpr rhs ; return con } @@ -392,19 +412,28 @@ maybeAltHeapCheck (GcInAlts regs srt) code cgConApp :: DataCon -> [StgArg] -> FCode () cgConApp con stg_args + | isUnboxedTupleCon con -- Unboxed tuple: assign and return + = do { arg_exprs <- getNonVoidArgAmodes stg_args + ; tickyUnboxedTupleReturn (length arg_exprs) + ; emitReturn arg_exprs } + + | otherwise -- Boxed constructors; allocate and return = ASSERT( stg_args `lengthIs` dataConRepArity con ) - do { idinfo <- buildDynCon (dataConWorkId con) currentCCS con stg_args + do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args -- The first "con" says that the name bound to this closure is -- is "con", which is a bit of a fudge, but it only affects profiling + ; emit init ; emitReturn [idInfoToAmode idinfo] } + cgIdApp :: Id -> [StgArg] -> FCode () +cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] cgIdApp fun_id args = do { fun_info <- getCgIdInfo fun_id - ; case maybeLetNoEscape fun_info of - Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall fun_id fun_info args } + ; case maybeLetNoEscape fun_info of + Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args + Nothing -> cgTailCall fun_id fun_info args } cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode () cgLneJump blk_id lne_regs args -- Join point; discard sequel @@ -416,35 +445,40 @@ cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode () cgTailCall fun_id fun_info args = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of - -- A value in WHNF, so we can just return it. + -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? EnterIt -> ASSERT( null args ) -- Discarding arguments - do { [ret,call] <- forkAlts [ + do { let fun' = CmmLoad fun (cmmExprType fun) + ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag - getCode $ emitCall (entryCode fun) [fun]] -- Not tagged + getCode $ do emit (mkAssign nodeReg fun) + emitCall Native (entryCode fun') []] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines { tickySlowCall lf_info args + ; emit $ mkComment $ mkFastString "slowCall" ; slowCall fun args } -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args ; if node_points then - do call <- getCode $ directCall lbl arity args - emit (mkAssign nodeReg fun <*> call) + do emit $ mkComment $ mkFastString "directEntry" + emit (mkAssign nodeReg fun) + directCall lbl arity args -- directCall lbl (arity+1) (StgVarArg fun_id : args)) -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>)) - else directCall lbl arity args } + else do emit $ mkComment $ mkFastString "directEntry else" + directCall lbl arity args } JumpToIt {} -> panic "cgTailCall" -- ??? where - 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 = cgIdInfoLF fun_info node_points = nodeMustPointToIt lf_info diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2d5d79e6ff..2a6b794e2d 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -10,11 +10,10 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, + cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery, ) where @@ -27,18 +26,23 @@ import StgCmmMonad import StgCmmUtils import StgCmmClosure -import MkZipCfgCmm +import BlockId import Cmm import CmmUtils +import MkZipCfg +import MkZipCfgCmm hiding (CmmAGraph) import Type import TysPrim +import UniqSupply import CLabel import SMRep import ForeignCall import Constants import StaticFlags +import FastString import Maybes import Outputable +import ZipCfgCmmRep import Control.Monad @@ -64,8 +68,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a DynamicTarget -> case args of fn:rest -> (rest, fn) call_target = ForeignTarget cmm_target fc - ; srt <- getSRTInfo (panic "emitForeignCall") -- SLPJ: Not sure what SRT - -- is right here + ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT + -- is right here + -- JD: Does it matter in the new codegen? ; emitForeignCall safety results call_target call_args srt CmmMayReturn } where -- in the stdcall calling convention, the symbol needs @size appended @@ -111,50 +116,18 @@ emitForeignCall -> CmmReturnInfo -- This can say "never returns" -- only RTS procedures do this -> FCode () -emitForeignCall safety results target args _srt _ret - | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do +emitForeignCall safety results target args _srt ret + | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do let (caller_save, caller_load) = callerSaveVolatileRegs + updfr_off <- getUpdFrameOff emit caller_save - emit (mkUnsafeCall target results args) + emit $ mkUnsafeCall target results args emit caller_load - | otherwise = panic "ToDo: emitForeignCall'" - -{- | otherwise = do - -- Both 'id' and 'new_base' are KindNonPtr because they're - -- RTS only objects and are not subject to garbage collection - id <- newTemp bWord - new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) + updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target - let (caller_save, caller_load) = callerSaveVolatileRegs - emitSaveThreadState - emit caller_save - -- The CmmUnsafe arguments are only correct because this part - -- of the code hasn't been moved into the CPS pass yet. - -- Once that happens, this function will just emit a (CmmSafe srt) call, - -- and the CPS will will be the one to convert that - -- to this sequence of three CmmUnsafe calls. - emit (mkCmmCall (CmmCallee suspendThread CCallConv) - [ (id,AddrHint) ] - [ (CmmReg (CmmGlobal BaseReg), AddrHint) ] - CmmUnsafe - ret) - emit (mkCmmCall temp_target results args CmmUnsafe ret) - emit (mkCmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, AddrHint) ] - [ (CmmReg (CmmLocal id), AddrHint) ] - CmmUnsafe - ret ) - -- Assign the result to BaseReg: we - -- might now have a different Capability! - emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) - emit caller_load - emitLoadThreadState - -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) --} + emit $ mkSafeCall temp_target results args updfr_off {- @@ -170,23 +143,23 @@ load_args_into_temps = mapM arg_assign_temp where arg_assign_temp (e,hint) = do tmp <- maybe_assign_temp e return (tmp,hint) +-} -load_target_into_temp (CmmCallee expr conv) = do +load_target_into_temp (ForeignTarget expr conv) = do tmp <- maybe_assign_temp expr - return (CmmCallee tmp conv) -load_target_into_temp other_target = + return (ForeignTarget tmp conv) +load_target_into_temp other_target@(PrimTarget _) = return other_target maybe_assign_temp e | hasNoGlobalRegs e = return e - | otherwise = do + | otherwise = do -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing reg <- newTemp (cmmExprType e) --TODO FIXME NOW emit (mkAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) --} -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO @@ -194,23 +167,34 @@ maybe_assign_temp e -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -emitSaveThreadState :: FCode () -emitSaveThreadState = do +saveThreadState :: CmmAGraph +saveThreadState = -- CurrentTSO->sp = Sp; - emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp - emitCloseNursery + mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp + <*> closeNursery + -- and save the current cost centre stack in the TSO when profiling: + <*> if opt_SccProfilingOn then + mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS + else mkNop + +emitSaveThreadState :: BlockId -> FCode () +emitSaveThreadState bid = do + -- CurrentTSO->sp = Sp; + emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) + (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord))) + emit closeNursery -- and save the current cost centre stack in the TSO when profiling: when opt_SccProfilingOn $ emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) -- CurrentNursery->free = Hp+1; -emitCloseNursery :: FCode () -emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) +closeNursery :: CmmAGraph +closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -emitLoadThreadState :: FCode () -emitLoadThreadState = do - tso <- newTemp gcWord -- TODO FIXME NOW - emit $ catAGraphs [ +loadThreadState :: LocalReg -> CmmAGraph +loadThreadState tso = do + -- tso <- newTemp gcWord -- TODO FIXME NOW + catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- Sp = tso->sp; @@ -218,16 +202,18 @@ emitLoadThreadState = do bWord), -- SpLim = tso->stack + RESERVED_STACK_WORDS; mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) - rESERVED_STACK_WORDS) - ] - emitOpenNursery - -- and load the current cost centre stack from the TSO when profiling: - when opt_SccProfilingOn $ - emit (mkStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)) - -emitOpenNursery :: FCode () -emitOpenNursery = emit $ catAGraphs [ + rESERVED_STACK_WORDS), + openNursery, + -- and load the current cost centre stack from the TSO when profiling: + if opt_SccProfilingOn then + mkStore curCCSAddr + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) + else mkNop] +emitLoadThreadState :: LocalReg -> FCode () +emitLoadThreadState tso = emit $ loadThreadState tso + +openNursery :: CmmAGraph +openNursery = catAGraphs [ -- Hp = CurrentNursery->free - 1; mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), @@ -246,7 +232,8 @@ emitOpenNursery = emit $ catAGraphs [ ) ) ] - +emitOpenNursery :: FCode () +emitOpenNursery = emit openNursery nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start @@ -285,7 +272,7 @@ currentNursery = CmmGlobal CurrentNursery getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args --- (b) Add foriegn-call shim code +-- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes getFCallArgs args @@ -295,7 +282,7 @@ getFCallArgs args get arg | isVoidRep arg_rep = return Nothing | otherwise - = do { cmm <- getArgAmode arg + = do { cmm <- getArgAmode (NonVoid arg) ; return (Just (add_shim arg_ty cmm, hint)) } where arg_ty = stgArgType arg diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 6a8a4354e1..3f803d1d65 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -51,14 +51,14 @@ import Data.List layOutDynConstr, layOutStaticConstr :: DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(a, VirtualHpOffset)]) + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) -- No Void arguments in result layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True layOutConstr :: Bool -> DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(a, VirtualHpOffset)]) + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) layOutConstr is_static data_con args = (mkConInfo is_static data_con tot_wds ptr_wds, things_w_offsets) @@ -78,13 +78,16 @@ allocDynClosure -> CmmExpr -- Cost Centre to blame for this alloc -- (usually the same; sometimes "OVERHEAD") - -> [(StgArg, VirtualHpOffset)] -- Offsets from start of the object - -- ie Info ptr has offset zero. - -- No void args in here - -> FCode LocalReg + -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of the object + -- ie Info ptr has offset zero. + -- No void args in here + -> FCode (LocalReg, CmmAGraph) -- allocDynClosure allocates the thing in the heap, -- and modifies the virtual Hp to account for this. +-- The second return value is the graph that sets the value of the +-- returned LocalReg, which should point to the closure after executing +-- the graph. -- Note [Return a LocalReg] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,7 +135,7 @@ allocDynClosure cl_info use_cc _blame_cc args_w_offsets -- Assign to a temporary and return -- Note [Return a LocalReg] ; hp_rel <- getHpRelOffset info_offset - ; assignTemp hp_rel } + ; getCodeR $ assignTemp hp_rel } emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs @@ -210,7 +213,7 @@ mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ payload + ++ concatMap padLitToWord payload ++ padding_wds ++ static_link_field ++ saved_info_field @@ -221,6 +224,19 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi ++ staticProfHdr ccs ++ staticTickyHdr +-- JD: Simon had ellided this padding, but without it the C back end asserts failure. +-- Maybe it's a bad assertion, and this padding is indeed unnecessary? +padLitToWord :: CmmLit -> [CmmLit] +padLitToWord lit = lit : padding pad_length + where width = typeWidth (cmmLitType lit) + pad_length = wORD_SIZE - widthInBytes width :: Int + + padding n | n <= 0 = [] + | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) + | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) + | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) + | otherwise = CmmInt 0 W64 : padding (n-8) + ----------------------------------------------------------- -- Heap overflow checking ----------------------------------------------------------- @@ -286,7 +302,7 @@ These are used in the following circumstances Here, the info table needed by the call to gc_1p should be the *same* as the one for the call to f; the C-- optimiser - spots this sharing opportunity + spots this sharing opportunity) (b) No canned sequence for results of f Note second info table @@ -318,24 +334,30 @@ These are used in the following circumstances -------------------------------------------------------------- -- A heap/stack check at a function or thunk entry point. -entryHeapCheck :: LocalReg -- Function - -> [LocalReg] -- Args (empty for thunk) +entryHeapCheck :: LocalReg -- Function (closure environment) + -> Int -- Arity -- not same as length args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) -> C_SRT -> FCode () -> FCode () -entryHeapCheck fun args srt code - = heapCheck gc_call code -- The 'fun' keeps relevant CAFs alive +entryHeapCheck fun arity args srt code + = do updfr_sz <- getUpdFrameOff + heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive where - gc_call - | null args = mkJump (CmmReg (CmmGlobal GCEnter1)) [CmmReg (CmmLocal fun)] - | otherwise = case gc_lbl args of - Just lbl -> mkJump (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) - (map (CmmReg . CmmLocal) (fun:args)) - Nothing -> mkCmmCall generic_gc [] [] srt + fun_expr = CmmReg (CmmLocal fun) + -- JD: ugh... we should only do the following for dynamic closures + args' = fun_expr : map (CmmReg . CmmLocal) args + gc_call updfr_sz + | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz + | otherwise = case gc_lbl (fun : args) of + Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) + args' updfr_sz + Nothing -> mkCall generic_gc GC [] [] updfr_sz gc_lbl :: [LocalReg] -> Maybe LitString - gc_lbl [reg] +{- + gc_lbl [reg] | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p" | isFloatType ty = case width of W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1" @@ -348,6 +370,7 @@ entryHeapCheck fun args srt code where ty = localRegType reg width = typeWidth ty +-} gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) @@ -360,19 +383,19 @@ entryHeapCheck fun args srt code altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a altHeapCheck regs srt code - = heapCheck gc_call code + = do updfr_sz <- getUpdFrameOff + heapCheck False (gc_call updfr_sz) code where - gc_call - | null regs = mkCmmCall generic_gc [] [] srt + gc_call updfr_sz + | null regs = mkCall generic_gc GC [] [] updfr_sz | Just gc_lbl <- rts_label regs -- Canned call - = mkCmmCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) - regs - (map (CmmReg . CmmLocal) regs) - srt + = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC + regs (map (CmmReg . CmmLocal) regs) updfr_sz | otherwise -- No canned call, and non-empty live vars - = mkCmmCall generic_gc [] [] srt + = mkCall generic_gc GC [] [] updfr_sz +{- rts_label [reg] | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") | isFloatType ty = case width of @@ -381,23 +404,26 @@ altHeapCheck regs srt code _other -> Nothing | otherwise = case width of W32 -> Just (sLit "stg_gc_unbx_r1") - W64 -> Just (sLit "stg_gc_unbx_l1") + W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1" _other -> Nothing -- Narrow cases where ty = localRegType reg width = typeWidth ty +-} rts_label _ = Nothing generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls -generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun"))) +generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs"))) +-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... +-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun"))) ------------------------------- -heapCheck :: CmmAGraph -> FCode a -> FCode a -heapCheck do_gc code +heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a +heapCheck checkStack do_gc code = getHeapUsage $ \ hpHw -> - do { emit (do_checks hpHw do_gc) + do { emit $ do_checks checkStack hpHw do_gc -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole ; tickyAllocHeap hpHw @@ -405,20 +431,27 @@ heapCheck do_gc code ; setRealHp hpHw ; code } -do_checks :: WordOff -- Heap headroom - -> CmmAGraph -- What to do on failure - -> CmmAGraph -do_checks 0 _ - = mkNop -do_checks alloc do_gc - = withFreshLabel "gc" $ \ blk_id -> - mkLabel blk_id Nothing - <*> mkAssign hpReg bump_hp - <*> mkCmmIfThen hp_oflo - (save_alloc - <*> do_gc - <*> mkBranch blk_id) - -- Bump heap pointer, and test for heap exhaustion +do_checks :: Bool -- Should we check the stack? + -> WordOff -- Heap headroom + -> CmmAGraph -- What to do on failure + -> CmmAGraph +do_checks checkStack alloc do_gc + = withFreshLabel "gc" $ \ loop_id -> + withFreshLabel "gc" $ \ gc_id -> + mkLabel loop_id emptyStackInfo + <*> (let hpCheck = if alloc == 0 then mkNop + else mkAssign hpReg bump_hp <*> + mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id) + in if checkStack then + mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck + else hpCheck) + <*> mkComment (mkFastString "outOfLine should follow:") + <*> outOfLine (mkLabel gc_id emptyStackInfo + <*> mkComment (mkFastString "outOfLine here") + <*> do_gc + <*> mkBranch loop_id) + -- Test for stack pointer exhaustion, then + -- bump heap pointer, and test for heap exhaustion -- Note that we don't move the heap pointer unless the -- stack check succeeds. Otherwise we might end up -- with slop at the end of the current block, which can @@ -427,6 +460,11 @@ do_checks alloc do_gc alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit + -- Sp overflow if (Sp - CmmHighStack < SpLim) + sp_oflo = CmmMachOp mo_wordULt + [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) + [CmmReg spReg, CmmLit CmmHighStackMark], + CmmReg spLimReg] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index f8d39646d6..1269897f4e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,8 @@ module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, - emitClosureCodeAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, slowCall, directCall, @@ -47,6 +48,7 @@ import CmmUtils import Cmm import CLabel import StgSyn +import DataCon import Id import Name import TyCon ( PrimRep(..) ) @@ -62,7 +64,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( LitString, sLit ) +import FastString ( mkFastString, LitString, sLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -77,21 +79,24 @@ emitReturn :: [CmmExpr] -> FCode () -- p=x; q=y; emitReturn results = do { adjustHpBackwards - ; sequel <- getSequel; + ; sequel <- getSequel; + ; updfr_off <- getUpdFrameOff ; case sequel of - Return _ -> emit (mkReturn results) - AssignTo regs _ -> emit (mkMultiAssign regs results) + Return _ -> emit (mkReturnSimple results updfr_off) + AssignTo regs _ -> emit (mkMultiAssign regs results) } -emitCall :: CmmExpr -> [CmmExpr] -> FCode () +emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode () -- (cgCall fun args) makes a call to the entry-code of 'fun', -- passing 'args', and returning the results to the current sequel -emitCall fun args +emitCall conv fun args = do { adjustHpBackwards - ; sequel <- getSequel; + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; emit $ mkComment $ mkFastString "emitcall" ; case sequel of - Return _ -> emit (mkJump fun args) - AssignTo res_regs srt -> emit (mkCmmCall fun res_regs args srt) + Return _ -> emit (mkForeignJump conv fun args updfr_off) + AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off) } adjustHpBackwards :: FCode () @@ -132,7 +137,7 @@ directCall :: CLabel -> Arity -> [StgArg] -> FCode () -- Both arity and args include void args directCall lbl arity stg_args = do { cmm_args <- getNonVoidArgAmodes stg_args - ; direct_call lbl arity cmm_args (argsLReps stg_args) } + ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) } slowCall :: CmmExpr -> [StgArg] -> FCode () -- (slowCall fun args) applies fun to args, returning the results to Sequel @@ -141,36 +146,42 @@ slowCall fun stg_args ; slow_call fun cmm_args (argsLReps stg_args) } -------------- -direct_call :: CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () --- NB1: (length args) maybe less than (length reps), because +direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () +-- NB1: (length args) may be less than (length reps), because -- the args exclude the void ones -- NB2: 'arity' refers to the *reps* -direct_call lbl arity args reps - | null rest_args - = ASSERT( arity == length args) - emitCall target args +direct_call caller lbl arity args reps + | debugIsOn && arity > length reps -- Too few args + = -- Caller should ensure that there enough args! + pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps) + <+> ppr args <+> ppr reps ) - | otherwise + | null rest_reps -- Precisely the right number of arguments + = emitCall Native target args + + | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord ; let srt = pprTrace "Urk! SRT for over-sat call" (ppr lbl) NoC_SRT -- XXX: what if rest_args contains static refs? ; withSequel (AssignTo [pap_id] srt) - (emitCall target args) + (emitCall Native target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where target = CmmLit (CmmLabel lbl) (initial_reps, rest_reps) = splitAt arity reps arg_arity = count isNonV initial_reps - (_, rest_args) = splitAt arg_arity args + (fast_args, rest_args) = splitAt arg_arity args -------------- slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode () slow_call fun args reps - = direct_call (mkRtsApFastLabel rts_fun) (arity+1) - (fun : args) (P : reps) + = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps + emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++ + " with pat " ++ showSDoc (ptext rts_fun)) + emit (mkAssign nodeReg fun <*> call) where (rts_fun, arity) = slowCallPattern reps @@ -207,6 +218,13 @@ data LRep = P -- GC Ptr | V -- Void | F -- Float | D -- Double +instance Outputable LRep where + ppr P = text "P" + ppr N = text "N" + ppr L = text "L" + ppr V = text "V" + ppr F = text "F" + ppr D = text "D" toLRep :: PrimRep -> LRep toLRep VoidRep = V @@ -254,7 +272,7 @@ mkVirtHeapOffsets -> [(PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* - [(a, VirtualHpOffset)]) + [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER @@ -279,7 +297,7 @@ mkVirtHeapOffsets is_thunk things computeOffset wds_so_far (rep, thing) = (wds_so_far + lRepSizeW (toLRep rep), - (thing, hdr_size + wds_so_far)) + (NonVoid thing, hdr_size + wds_so_far)) ------------------------------------------------------------------------- @@ -437,12 +455,36 @@ mkRegLiveness regs ptrs nptrs -- Here we make an info table of type 'CmmInfo'. The concrete -- representation as a list of 'CmmAddr' is handled later -- in the pipeline by 'cmmToRawCmm'. - -emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals - -> CmmAGraph -> FCode () -emitClosureCodeAndInfoTable cl_info args body - = do { info <- mkCmmInfo cl_info - ; emitProc info (infoLblToEntryLbl info_lbl) args body } +-- When loading the free variables, a function closure pointer may be tagged, +-- so we must take it into account. + +emitClosureProcAndInfoTable :: Bool -- top-level? + -> Id -- name of the closure + -> ClosureInfo -- lots of info abt the closure + -> [NonVoid Id] -- incoming arguments + -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body + -> FCode () +emitClosureProcAndInfoTable top_lvl bndr cl_info args body + = do { let lf_info = closureLFInfo cl_info + -- Bind the binder itself, but only if it's not a top-level + -- binding. We need non-top let-bindings to refer to the + -- top-level binding, which this binding would incorrectly shadow. + ; node <- if top_lvl then return $ idToReg (NonVoid bndr) + else bindToReg (NonVoid bndr) lf_info + ; arg_regs <- + pprTrace "bindArgsToRegs" (ppr args) $ + bindArgsToRegs args + ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs) + } + +-- Data constructors need closures, but not with all the argument handling +-- needed for functions. The shared part goes here. +emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable cl_info args body + = do { info <- mkCmmInfo cl_info + ; blks <- getCode body + ; emitProc info (infoLblToEntryLbl info_lbl) args blks + } where info_lbl = infoTableLabelFromCI cl_info @@ -450,14 +492,18 @@ emitClosureCodeAndInfoTable cl_info args body -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) mkCmmInfo :: ClosureInfo -> FCode CmmInfo mkCmmInfo cl_info - = do { prof <- if opt_SccProfilingOn then + = do { info <- closureTypeInfo cl_info k_with_con_name return + ; prof <- if opt_SccProfilingOn then do fd_lit <- mkStringCLit (closureTypeDescr cl_info) ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)) } + ; return (CmmInfo gc_target Nothing + (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) } where - info = closureTypeInfo cl_info + k_with_con_name con_info con info_lbl = + do cstr <- mkByteStringCLit $ dataConIdentity con + return $ con_info $ makeRelativeRefTo info_lbl cstr cl_type = smRepClosureTypeInt (closureSMRep cl_info) -- The gc_target is to inform the CPS pass when it inserts a stack check. diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 365263941e..2249a463df 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -13,7 +13,7 @@ module StgCmmMonad ( returnFC, fixC, nopC, whenC, newUnique, newUniqSupply, - emit, emitData, emitProc, emitSimpleProc, + emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, getCmm, cgStmtsToBlocks, getCodeR, getCode, getHeapUsage, @@ -28,6 +28,8 @@ module StgCmmMonad ( setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, + withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, setVirtHp, getVirtHp, setRealHp, @@ -50,6 +52,7 @@ module StgCmmMonad ( import StgCmmClosure import DynFlags import MkZipCfgCmm +import ZipCfgCmmRep (UpdFrameOffset) import BlockId import Cmm import CLabel @@ -157,12 +160,13 @@ fixC fcode = FCode ( 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_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel -- What to do at end of basic block + cgd_dflags :: DynFlags, + cgd_mod :: Module, -- Module being compiled + cgd_statics :: CgBindings, -- [Id -> info] : static environment + cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT + 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 } type CgBindings = IdEnv CgIdInfo @@ -173,10 +177,10 @@ data CgIdInfo -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc + , cg_loc :: CgLoc -- CmmExpr for the *tagged* value , cg_rep :: PrimRep -- Cache for (idPrimRep id) , cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf) - } + } data CgLoc = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning @@ -206,21 +210,28 @@ data Sequel [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here C_SRT -- Here are the statics live in the continuation - + -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of { + -- r -> <blah> + -- When compiling the nested case, remember to put the + -- result in r, and fall through initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags, + cgd_mod = mod, + cgd_statics = emptyVarEnv, + cgd_srt_lbl = error "initC: srt_lbl", + cgd_updfr_off = initUpdFrameOff, + cgd_ticky = mkTopTickyCtrLabel, + cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False +initUpdFrameOff :: UpdFrameOffset +initUpdFrameOff = widthInBytes wordWidth -- space for the RA + -------------------------------------------------------- -- The code generator state @@ -240,7 +251,7 @@ data CgState -- the info-down part cgs_hp_usg :: HeapUsage, - + cgs_uniqs :: UniqSupply } data HeapUsage = @@ -253,10 +264,10 @@ type VirtualHpOffset = WordOff initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, + cgs_binds = emptyVarEnv, + cgs_hp_usg = initHpUsage, + cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState -- stateIncUsage@ e1 e2 incorporates in e1 @@ -408,6 +419,26 @@ setSRTLabel srt_lbl code withInfoDown code (info { cgd_srt_lbl = srt_lbl}) -- ---------------------------------------------------------------------------- +-- Get/set the size of the update frame + +-- We keep track of the size of the update frame so that we +-- can set the stack pointer to the proper address on return +-- (or tail call) from the closure. +-- There should be at most one update frame for each closure. +-- Note: I'm including the size of the original return address +-- in the size of the update frame -- hence the default case on `get'. + +withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode () +withUpdFrameOff size code + = do { info <- getInfoDown + ; withInfoDown code (info {cgd_updfr_off = size }) } + +getUpdFrameOff :: FCode UpdFrameOffset +getUpdFrameOff + = do { info <- getInfoDown + ; return $ cgd_updfr_off info } + +-- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel @@ -440,7 +471,8 @@ forkClosureBody body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel } + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -455,8 +487,9 @@ forkStatics body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state, - cgd_sequel = initSequel } + ; let rhs_info_down = info { cgd_statics = cgs_binds state + , cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -473,9 +506,9 @@ forkProc body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let fork_state_in = (initCgState us) - { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in + ; let info_down' = info_down { cgd_sequel = initSequel } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down' fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } @@ -562,20 +595,22 @@ emitData sect lits where data_block = CmmData sect lits -emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () -emitProc info lbl args blocks +emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals -> + CmmAGraph -> FCode () +emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply - ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) Native args + ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks - -- ; blks <- cgStmtsToBlocks blocks ; let proc_block = CmmProc info lbl args blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc = emitProcWithConvention Native + emitSimpleProc :: CLabel -> CmmAGraph -> FCode () --- Emit a procedure whose body is the specified code; no info table -emitSimpleProc lbl code - = emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code +emitSimpleProc lbl code = + emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code getCmm :: FCode () -> FCode CmmZ -- Get all the CmmTops (there should be no stmts) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 96467fe781..69409084d1 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -66,7 +66,9 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) - do { amode <- getArgAmode arg + do { args' <- getNonVoidArgAmodes [arg] + ; let amode = case args' of [amode] -> amode + _ -> panic "TagToEnumOp had void arg" ; emitReturn [tagToClosure tycon amode] } where -- If you're reading this code in the attempt to figure @@ -79,8 +81,8 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args - ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall fun cmm_args } + ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + ; pprTrace "cgOpApp" (ppr primop) $ emitCall PrimOp fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f442295d25..1a18b99ac8 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -37,6 +37,7 @@ module StgCmmProf ( -- For REP_xxx constants, which are MachReps import StgCmmClosure +import StgCmmEnv import StgCmmUtils import StgCmmMonad import SMRep @@ -185,10 +186,10 @@ profAlloc words ccs -- Setting the cost centre in a new closure chooseDynCostCentres :: CostCentreStack - -> [Id] -- Args + -> [Id] -- Args -> StgExpr -- Body -> FCode (CmmExpr, CmmExpr) --- Called when alllcating a closure +-- Called when allocating a closure -- Tells which cost centre to put in the object, and which -- to blame the cost of allocation on chooseDynCostCentres ccs args body = do diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f05f..057e5597e8 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -52,6 +52,7 @@ import BlockId import Cmm import CmmExpr import MkZipCfgCmm +import ZipCfg hiding (last, unzip, zip) import CLabel import CmmUtils import PprCmm ( {- instances -} ) @@ -307,15 +308,17 @@ emitRtsCall' -> FCode () emitRtsCall' res fun args _vols safe = --error "emitRtsCall'" - do { emit caller_save - ; emit call + do { updfr_off <- getUpdFrameOff + ; emit caller_save + ; emit $ call updfr_off ; emit caller_load } where - call = if safe then - mkCall fun_expr CCallConv res' args' undefined - else - mkUnsafeCall (ForeignTarget fun_expr - (ForeignConvention CCallConv arg_hints res_hints)) res' args' + call updfr_off = + if safe then + mkCall fun_expr Native res' args' updfr_off + else + mkUnsafeCall (ForeignTarget fun_expr + (ForeignConvention CCallConv arg_hints res_hints)) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res (caller_save, caller_load) = callerSaveVolatileRegs @@ -633,7 +636,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag mk_switch tag_expr' (sortLe le branches) mb_deflt lo_tag hi_tag via_C -- Sort the branches before calling mk_switch - <*> mkLabel join_lbl Nothing + <*> mkLabel join_lbl emptyStackInfo where (t1,_) `le` (t2,_) = t1 <= t2 @@ -706,9 +709,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches = mkCmmIfThenElse (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) + (mkBranch deflt) (mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C) - (mkBranch deflt) | otherwise -- Use an if-tree = mkCmmIfThenElse @@ -788,6 +791,7 @@ mkCmmLitSwitch scrut branches deflt label_code join_lbl deflt $ \ deflt -> label_branches join_lbl branches $ \ branches -> mk_lit_switch scrut' deflt (sortLe le branches) + <*> mkLabel join_lbl emptyStackInfo where le (t1,_) (t2,_) = t1 <= t2 @@ -795,12 +799,12 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] -> CmmAGraph mk_lit_switch scrut deflt [(lit,blk)] - = mkCbranch - (CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]) - deflt blk + = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk where cmm_lit = mkSimpleLit lit - rep = typeWidth (cmmLitType cmm_lit) + cmm_ty = cmmLitType cmm_lit + rep = typeWidth cmm_ty + ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep mk_lit_switch scrut deflt_blk_id branches = mkCmmIfThenElse cond @@ -846,7 +850,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph -- [L: code; goto J] fun L label_code join_lbl code thing_inside = withFreshLabel "switch" $ \lbl -> - outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl) + outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl) <*> thing_inside lbl @@ -881,10 +885,12 @@ getSRTInfo (SRT off len bmp) = do { id <- newUnique ; top_srt <- getSRTLabel ; let srt_desc_lbl = mkLargeSRTLabel id - ; emitRODataLits srt_desc_lbl - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + -- JD: We're not constructing and emitting SRTs in the back end, + -- which renders this code wrong (and it now names a now-non-existent label). + -- ; emitRODataLits srt_desc_lbl + -- ( cmmLabelOffW top_srt off + -- : mkWordCLit (fromIntegral len) + -- : map mkWordCLit bmp) ; return (C_SRT srt_desc_lbl 0 srt_escape) } | otherwise |