From 5dd61c6680eb9c2091048cacbfa53ab9e55ddcb6 Mon Sep 17 00:00:00 2001 From: "dias@eecs.tufts.edu" Date: Mon, 23 Mar 2009 20:11:40 +0000 Subject: [PATCH] Code simplifications due to call/return separation; some improvements to how node argument is managed --- compiler/cmm/CmmCallConv.hs | 36 ++---------------------------------- compiler/cmm/CmmProcPointZ.hs | 5 ++--- compiler/cmm/MkZipCfgCmm.hs | 18 +++++++++--------- compiler/codeGen/StgCmmBind.hs | 29 +++++++++++++++-------------- compiler/codeGen/StgCmmHeap.hs | 15 +++++++-------- 5 files changed, 35 insertions(+), 68 deletions(-) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 7b3dd0d..990e178 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -46,13 +46,9 @@ assignArguments f reps = assignments -- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- positive offsets in a CallArea, not negative offsets from the stack pointer. -- Also, I want byte offsets, not word offsets. --- The first argument tells us whether we are assigning positions for call arguments --- or return results. The distinction matters because some conventions use different --- global registers in each case. In particular, the native calling convention --- uses the `node' register to pass the closure environment. -assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] -> +assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] -> ArgumentFormat a ByteOff -assignArgumentsPos conv isCall arg_ty reps = map cvt assignments +assignArgumentsPos conv arg_ty reps = map cvt assignments where -- The calling conventions (CgCallConv.hs) are complicated, to say the least regs = case (reps, conv) of (_, NativeNodeCall) -> getRegsWithNode @@ -65,34 +61,6 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments (_, PrimOpReturn) -> getRegsWithNode (_, Slow) -> noRegs _ -> pprPanic "Unknown calling convention" (ppr conv) - -- regs = if isCall then - -- case (reps, conv) of - -- (_, NativeNodeCall) -> getRegsWithNode - -- (_, NativeDirectCall) -> getRegsWithoutNode - -- (_, GC ) -> getRegsWithNode - -- (_, PrimOpCall) -> allRegs - -- (_, Slow ) -> noRegs - -- _ -> pprPanic "Unknown calling convention" (ppr conv) - -- else - -- case (reps, conv) of - -- (_, NativeNodeCall) -> getRegsWithNode - -- (_, NativeDirectCall) -> getRegsWithoutNode - -- ([_], NativeReturn) -> allRegs - -- (_, NativeReturn) -> getRegsWithNode - -- (_, GC) -> getRegsWithNode - -- ([_], PrimOpReturn) -> allRegs - -- (_, PrimOpReturn) -> getRegsWithNode - -- (_, Slow) -> noRegs - -- _ -> pprPanic "Unknown calling convention" (ppr conv) - -- (_, NativeCall) -> getRegsWithoutNode - -- (_, GC ) -> getRegsWithNode - -- (_, PrimOpCall) -> allRegs - -- (_, Slow ) -> noRegs - -- _ -> panic "Unknown calling convention" - -- else - -- case (reps, conv) of - -- ([_], _) -> allRegs - -- (_, NativeCall) -> getRegsWithNode (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs assignArguments' [] _ _ = [] assignArguments' (r:rs) offset avails = diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index 5ec65c5..60d6ce1 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -329,7 +329,7 @@ add_CopyIns callPPs protos blocks = = case lookupBlockEnv protos id of Just (Protocol c fs _area) -> do LGraph _ blocks <- - lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t) + lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t) return (map snd $ blockEnvToList blocks) Nothing -> return [b] | otherwise = return [b] @@ -356,8 +356,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv if elemBlockSet succId procPoints then case lookupBlockEnv protos succId of Nothing -> z - Just (Protocol c fs _area) -> - insert z succId $ copyOutSlot c Jump fs + Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs else z insert z succId m = do (b, bmap) <- z diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 4b2c022..4eabffb 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -146,15 +146,15 @@ stackStubExpr w = CmmLit (CmmInt 0 w) -- the variables in their spill slots. -- Therefore, for copying arguments and results, we provide different -- functions to pass the arguments in an overflow area and to pass them in spill slots. -copyInOflow :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph) -copyInSlot :: Convention -> Bool -> CmmFormals -> CmmAGraph +copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph) +copyInSlot :: Convention -> CmmFormals -> CmmAGraph copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle]) -copyOutSlot :: Convention -> Transfer -> [LocalReg] -> [Middle] +copyOutSlot :: Convention -> [LocalReg] -> [Middle] -- why a list of middles here instead of an AGraph? copyInOflow = copyIn oneCopyOflowI -copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f +copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) -> (ByteOff, CmmAGraph) @@ -207,7 +207,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off = widthInBytes wordWidth) else ([], 0) Old -> ([], updfr_off) - args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals + args = assignArgumentsPos conv cmmExprType actuals args' = foldl adjust setRA args where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst adjust rst x@(_, RegisterParam _) = x : rst @@ -215,19 +215,19 @@ copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register -- Args passed only in registers and stack slots; no overflow space. -- No return address may apply! -copyOutSlot conv transfer actuals = foldr co [] args +copyOutSlot conv actuals = foldr co [] args where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms co (v, StackParam off) ms = MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms toExp r = CmmReg (CmmLocal r) - args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals + args = assignArgumentsPos conv localRegType actuals -- oneCopySlotO _ (reg, _) (n, ms) = -- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms) -- where w = widthInBytes (typeWidth (localRegType reg)) mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph) -mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals +mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> (ByteOff -> Last) -> CmmAGraph @@ -266,7 +266,7 @@ mkCall f (callConv, retConv) results actuals updfr_off = ppr retConv) $ withFreshLabel "call successor" $ \k -> let area = CallArea $ Young k - (off, copyin) = copyInOflow retConv False area results + (off, copyin) = copyInOflow retConv area results copyout = lastWithArgs Call area callConv actuals updfr_off (toCall f (Just k) updfr_off off) in (copyout <*> mkLabel k <*> copyin) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index f098f3f..5decdeb 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -393,21 +393,22 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details -- Emit the main entry code ; 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 arity arg_regs $ do - { enterCostCentre cl_info cc body + -- 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 arity arg_regs $ 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 + -- Load free vars out of closure *after* + ; if node_points then load_fvs node lf_info fv_bindings else return () + ; cgExpr body }} -- heap check, to reduce live vars over check } diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 0e3501a..ec60953 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -344,15 +344,14 @@ entryHeapCheck fun arity args code = do updfr_sz <- getUpdFrameOff heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive where - fun_expr = CmmReg (CmmLocal fun) - -- JD: ugh... we should only do the following for dynamic closures - args' = fun_expr : map (CmmReg . CmmLocal) args + args' = fun : args + arg_exprs = 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, GC) [] [] updfr_sz + | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz + | otherwise = case gc_lbl args' of + Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) + arg_exprs updfr_sz + Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz gc_lbl :: [LocalReg] -> Maybe LitString {- -- 1.7.10.4