Commit c6a61235 authored by Simon Marlow's avatar Simon Marlow

Track liveness of GlobalRegs in the new code generator

This gives the register allocator access to R1.., F1.., D1.. etc. for
the new code generator, and is a cheap way to eliminate all the extra
"x = R1" assignments that we get from copyIn.
parent c9cb46be
...@@ -100,7 +100,7 @@ hash_block block = ...@@ -100,7 +100,7 @@ hash_block block =
hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
hash_node (CmmBranch _) = 23 -- NB. ignore the label hash_node (CmmBranch _) = 23 -- NB. ignore the label
hash_node (CmmCondBranch p _ _) = hash_e p hash_node (CmmCondBranch p _ _) = hash_e p
hash_node (CmmCall e _ _ _ _) = hash_e e hash_node (CmmCall e _ _ _ _ _) = hash_e e
hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
hash_node (CmmSwitch e _) = hash_e e hash_node (CmmSwitch e _) = hash_e e
...@@ -193,8 +193,8 @@ eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool ...@@ -193,8 +193,8 @@ eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) = eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2 c1 == c2 && eqBid t1 t2 && eqBid f1 f2
eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) = eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) = eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2 e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith _ _ _ = False eqLastWith _ _ _ = False
......
...@@ -177,7 +177,7 @@ replaceLabels env g ...@@ -177,7 +177,7 @@ replaceLabels env g
txnode (CmmBranch bid) = CmmBranch (lookup bid) txnode (CmmBranch bid) = CmmBranch (lookup bid)
txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f) txnode (CmmCondBranch p t f) = mkCmmCondBranch (exp p) (lookup t) (lookup f)
txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms) txnode (CmmSwitch e arms) = CmmSwitch (exp e) (map (liftM lookup) arms)
txnode (CmmCall t k a res r) = CmmCall (exp t) (liftM lookup k) a res r txnode (CmmCall t k rg a res r) = CmmCall (exp t) (liftM lookup k) rg a res r
txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc) txnode fc@CmmForeignCall{} = fc{ args = map exp (args fc)
, succ = lookup (succ fc) } , succ = lookup (succ fc) }
txnode other = mapExpDeep exp other txnode other = mapExpDeep exp other
......
...@@ -102,7 +102,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g ...@@ -102,7 +102,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids] CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
-- ToDo: STG Live -- ToDo: STG Live
CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing] CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts Old.BasicBlock _ stmts -> stmts
......
...@@ -894,15 +894,16 @@ lowerSafeForeignCall block ...@@ -894,15 +894,16 @@ lowerSafeForeignCall block
-- so we use a jump, not a branch. -- so we use a jump, not a branch.
succLbl = CmmLit (CmmLabel (infoTblLbl succ)) succLbl = CmmLit (CmmLabel (infoTblLbl succ))
(ret_args, copyout) = copyOutOflow NativeReturn Jump (Young succ) (ret_args, regs, copyout) = copyOutOflow NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res) (map (CmmReg . CmmLocal) res)
updfr (0, []) updfr (0, [])
jump = CmmCall { cml_target = succLbl jump = CmmCall { cml_target = succLbl
, cml_cont = Just succ , cml_cont = Just succ
, cml_args = widthInBytes wordWidth , cml_args_regs = regs
, cml_ret_args = ret_args , cml_args = widthInBytes wordWidth
, cml_ret_off = updfr } , cml_ret_args = ret_args
, cml_ret_off = updfr }
graph' <- lgraphOfAGraph $ suspend <*> graph' <- lgraphOfAGraph $ suspend <*>
midCall <*> midCall <*>
......
...@@ -87,14 +87,14 @@ data CmmNode e x where ...@@ -87,14 +87,14 @@ data CmmNode e x where
-- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
-- (CmmStackSlot (Young b) _). -- (CmmStackSlot (Young b) _).
-- ToDO: add this: cml_args_regs :: [GlobalReg],
-- cml_args_regs :: [GlobalReg], -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
-- It says which GlobalRegs are live for the parameters at the -- to the call. This is essential information for the
-- moment of the call. Later stages can use this to give liveness -- native code generator's register allocator; without
-- everywhere, which in turn guides register allocation. -- knowing which GlobalRegs are live it has to assume that
-- It is the companion of cml_args; cml_args says which stack words -- they are all live. This list should only include
-- hold parameters, while cml_arg_regs says which global regs hold parameters. -- GlobalRegs that are mapped to real machine registers on
-- But do note [Register parameter passing] -- the target platform.
cml_args :: ByteOff, cml_args :: ByteOff,
-- Byte offset, from the *old* end of the Area associated with -- Byte offset, from the *old* end of the Area associated with
...@@ -189,7 +189,7 @@ instance Eq (CmmNode e x) where ...@@ -189,7 +189,7 @@ instance Eq (CmmNode e x) where
(CmmBranch a) == (CmmBranch a') = a==a' (CmmBranch a) == (CmmBranch a') = a==a'
(CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c' (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
(CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b' (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
(CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e' (CmmCall a b c d e f) == (CmmCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
(CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f' (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
_ == _ = False _ == _ = False
...@@ -301,7 +301,7 @@ mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapFore ...@@ -301,7 +301,7 @@ mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapFore
mapExp _ l@(CmmBranch _) = l mapExp _ l@(CmmBranch _) = l
mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt}
mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
...@@ -327,7 +327,7 @@ mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` ...@@ -327,7 +327,7 @@ mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap`
mapExpM _ (CmmBranch _) = Nothing mapExpM _ (CmmBranch _) = Nothing
mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
mapExpM f (CmmUnsafeForeignCall tgt fs as) mapExpM f (CmmUnsafeForeignCall tgt fs as)
= case mapForeignTargetM f tgt of = case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
......
...@@ -245,7 +245,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -245,7 +245,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap
let add_jump_block (env, bs) (pp, l) = let add_jump_block (env, bs) (pp, l) =
do bid <- liftM mkBlockId getUniqueM do bid <- liftM mkBlockId getUniqueM
let b = blockJoin (CmmEntry bid) emptyBlock jump let b = blockJoin (CmmEntry bid) emptyBlock jump
jump = CmmCall (CmmLit (CmmLabel l)) Nothing 0 0 0 jump = CmmCall (CmmLit (CmmLabel l)) Nothing [{-XXX-}] 0 0 0
-- XXX: No regs are live at the call
return (mapInsert pp bid env, b : bs) return (mapInsert pp bid env, b : bs)
add_jumps newGraphEnv (ppId, blockEnv) = add_jumps newGraphEnv (ppId, blockEnv) =
...@@ -286,7 +287,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap ...@@ -286,7 +287,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap
-> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) -> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
lbl (replacePPIds g) lbl (replacePPIds g)
where where
stack_info = panic "No StackInfo" stack_info = StackInfo 0 Nothing -- panic "No StackInfo"
-- cannot use panic, this is printed by -ddump-cmmz
-- References to procpoint IDs can now be replaced with the -- References to procpoint IDs can now be replaced with the
-- infotable's label -- infotable's label
......
...@@ -438,7 +438,7 @@ overlaps (_, o, w) (_, o', w') = ...@@ -438,7 +438,7 @@ overlaps (_, o, w) (_, o', w') =
in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK
lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, invalidateVolatile k assign)] lastAssignment (Plain (CmmCall _ (Just k) _ _ _ _)) assign = [(k, invalidateVolatile k assign)]
lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)]
lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
......
...@@ -294,7 +294,7 @@ data Transfer = Call | Jump | Ret deriving Eq ...@@ -294,7 +294,7 @@ data Transfer = Call | Jump | Ret deriving Eq
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-> UpdFrameOffset -> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
-> (Int, CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
-- Generate code to move the actual parameters into the locations -- Generate code to move the actual parameters into the locations
-- required by the calling convention. This includes a store for the -- required by the calling convention. This includes a store for the
...@@ -307,10 +307,12 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] ...@@ -307,10 +307,12 @@ copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-- of the other parameters. -- of the other parameters.
copyOutOflow conv transfer area actuals updfr_off copyOutOflow conv transfer area actuals updfr_off
(extra_stack_off, extra_stack_stuff) (extra_stack_off, extra_stack_stuff)
= foldr co (init_offset, mkNop) (args' ++ stack_params) = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
where where
co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms) co (v, RegisterParam r) (n, rs, ms)
co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms) = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
co (v, StackParam off) (n, rs, ms)
= (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
stack_params = [ (e, StackParam (off + init_offset)) stack_params = [ (e, StackParam (off + init_offset))
| (e,off) <- extra_stack_stuff ] | (e,off) <- extra_stack_stuff ]
...@@ -341,7 +343,7 @@ mkCallEntry conv formals = copyInOflow conv Old formals ...@@ -341,7 +343,7 @@ mkCallEntry conv formals = copyInOflow conv Old formals
lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> UpdFrameOffset
-> (ByteOff -> CmmAGraph) -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph -> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last = lastWithArgs transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack transfer area conv actuals lastWithArgsAndExtraStack transfer area conv actuals
...@@ -349,18 +351,21 @@ lastWithArgs transfer area conv actuals updfr_off last = ...@@ -349,18 +351,21 @@ lastWithArgs transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual] lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)]) -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
-> (ByteOff -> CmmAGraph) -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph -> CmmAGraph
lastWithArgsAndExtraStack transfer area conv actuals updfr_off lastWithArgsAndExtraStack transfer area conv actuals updfr_off
extra_stack last = extra_stack last =
let (outArgs, copies) = copyOutOflow conv transfer area actuals copies <*> last outArgs regs
updfr_off extra_stack in where
copies <*> last outArgs (outArgs, regs, copies) = copyOutOflow conv transfer area actuals
updfr_off extra_stack
noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)]) noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
noExtraStack = (0,[]) noExtraStack = (0,[])
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-> ByteOff -> [GlobalReg]
-> CmmAGraph -> CmmAGraph
toCall e cont updfr_off res_space arg_space = toCall e cont updfr_off res_space arg_space regs =
mkLast $ CmmCall e cont arg_space res_space updfr_off mkLast $ CmmCall e cont regs arg_space res_space updfr_off
...@@ -227,9 +227,9 @@ pprNode node = pp_node <+> pp_debug ...@@ -227,9 +227,9 @@ pprNode node = pp_node <+> pp_debug
, ptext (sLit ": goto") , ptext (sLit ": goto")
, ppr (head [ id | Just id <- ids]) <> semi ] , ppr (head [ id | Just id <- ids]) <> semi ]
CmmCall tgt k out res updfr_off -> CmmCall tgt k regs out res updfr_off ->
hcat [ ptext (sLit "call"), space hcat [ ptext (sLit "call"), space
, pprFun tgt, ptext (sLit "(...)"), space , pprFun tgt, parens (interpp'SP regs), space
, ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
<+> parens (ppr res) <+> parens (ppr res)
, ptext (sLit " with update frame") <+> ppr updfr_off , ptext (sLit " with update frame") <+> ppr updfr_off
......
...@@ -632,17 +632,15 @@ cgTailCall fun_id fun_info args = do ...@@ -632,17 +632,15 @@ cgTailCall fun_id fun_info args = do
-- A direct function call (possibly with some left-over arguments) -- A direct function call (possibly with some left-over arguments)
DirectEntry lbl arity -> do DirectEntry lbl arity -> do
{ tickyDirectCall arity args { tickyDirectCall arity args
; if node_points then ; if node_points
do emitComment $ mkFastString "directEntry" then directCall NativeNodeCall lbl arity (fun_arg:args)
emitAssign nodeReg fun else directCall NativeDirectCall lbl arity args }
directCall lbl arity args
else do emitComment $ mkFastString "directEntry else"
directCall lbl arity args }
JumpToIt {} -> panic "cgTailCall" -- ??? JumpToIt {} -> panic "cgTailCall" -- ???
where where
fun_name = idName fun_id fun_arg = StgVarArg fun_id
fun_name = idName fun_id
fun = idInfoToAmode fun_info fun = idInfoToAmode fun_info
lf_info = cgIdInfoLF fun_info lf_info = cgIdInfoLF fun_info
node_points = nodeMustPointToIt lf_info node_points = nodeMustPointToIt lf_info
...@@ -693,13 +691,13 @@ emitEnter fun = do ...@@ -693,13 +691,13 @@ emitEnter fun = do
; lcall <- newLabelC ; lcall <- newLabelC
; let area = Young lret ; let area = Young lret
; let (off, copyin) = copyInOflow NativeReturn area res_regs ; let (off, copyin) = copyInOflow NativeReturn area res_regs
(outArgs, copyout) = copyOutOflow NativeNodeCall Call area (outArgs, regs, copyout) = copyOutOflow NativeNodeCall Call area
[fun] updfr_off (0,[]) [fun] updfr_off (0,[])
-- refer to fun via nodeReg after the copyout, to avoid having -- refer to fun via nodeReg after the copyout, to avoid having
-- both live simultaneously; this sometimes enables fun to be -- both live simultaneously; this sometimes enables fun to be
-- inlined in the RHS of the R1 assignment. -- inlined in the RHS of the R1 assignment.
; let entry = entryCode (closureInfoPtr (CmmReg nodeReg)) ; let entry = entryCode (closureInfoPtr (CmmReg nodeReg))
the_call = toCall entry (Just lret) updfr_off off outArgs the_call = toCall entry (Just lret) updfr_off off outArgs regs
; emit $ ; emit $
copyout <*> copyout <*>
mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*> mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*>
......
...@@ -165,14 +165,14 @@ adjustHpBackwards ...@@ -165,14 +165,14 @@ adjustHpBackwards
-- call f() return to Nothing updfr_off: 32 -- call f() return to Nothing updfr_off: 32
directCall :: CLabel -> RepArity -> [StgArg] -> FCode () directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ()
-- (directCall f n args) -- (directCall f n args)
-- calls f(arg1, ..., argn), and applies the result to the remaining args -- calls f(arg1, ..., argn), and applies the result to the remaining args
-- The function f has arity n, and there are guaranteed at least n args -- The function f has arity n, and there are guaranteed at least n args
-- Both arity and args include void args -- Both arity and args include void args
directCall lbl arity stg_args directCall conv lbl arity stg_args
= do { argreps <- getArgRepsAmodes stg_args = do { argreps <- getArgRepsAmodes stg_args
; direct_call "directCall" lbl arity argreps } ; direct_call "directCall" conv lbl arity argreps }
slowCall :: CmmExpr -> [StgArg] -> FCode () slowCall :: CmmExpr -> [StgArg] -> FCode ()
...@@ -181,19 +181,21 @@ slowCall fun stg_args ...@@ -181,19 +181,21 @@ slowCall fun stg_args
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; argsreps <- getArgRepsAmodes stg_args ; argsreps <- getArgRepsAmodes stg_args
; let (rts_fun, arity) = slowCallPattern (map fst argsreps) ; let (rts_fun, arity) = slowCallPattern (map fst argsreps)
; call <- getCode $ direct_call "slow_call" ; direct_call "slow_call" NativeNodeCall
(mkRtsApFastLabel rts_fun) arity argsreps (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
; emitComment $ mkFastString ("slow_call for " ++ ; emitComment $ mkFastString ("slow_call for " ++
showSDoc dflags (ppr fun) ++ showSDoc dflags (ppr fun) ++
" with pat " ++ unpackFS rts_fun) " with pat " ++ unpackFS rts_fun)
; emit (mkAssign nodeReg fun <*> call)
} }
-------------- --------------
direct_call :: String -> CLabel -> RepArity -> [(ArgRep,Maybe CmmExpr)] -> FCode () direct_call :: String
direct_call caller lbl arity args -> Convention -- e.g. NativeNodeCall or NativeDirectCall
| debugIsOn && arity > length args -- Too few args -> CLabel -> RepArity
-> [(ArgRep,Maybe CmmExpr)] -> FCode ()
direct_call caller call_conv lbl arity args
| debugIsOn && real_arity > length args -- Too few args
= do -- Caller should ensure that there enough args! = do -- Caller should ensure that there enough args!
pprPanic "direct_call" $ pprPanic "direct_call" $
text caller <+> ppr arity <+> text caller <+> ppr arity <+>
...@@ -201,15 +203,18 @@ direct_call caller lbl arity args ...@@ -201,15 +203,18 @@ direct_call caller lbl arity args
ppr (map snd args) <+> ppr (map fst args) ppr (map snd args) <+> ppr (map fst args)
| null rest_args -- Precisely the right number of arguments | null rest_args -- Precisely the right number of arguments
= emitCall (NativeDirectCall, NativeReturn) target (nonVArgs args) = emitCall (call_conv, NativeReturn) target (nonVArgs args)
| otherwise -- Note [over-saturated calls] | otherwise -- Note [over-saturated calls]
= emitCallWithExtraStack (NativeDirectCall, NativeReturn) = emitCallWithExtraStack (call_conv, NativeReturn)
target (nonVArgs fast_args) (mkStkOffsets stack_args) target (nonVArgs fast_args) (mkStkOffsets stack_args)
where where
target = CmmLit (CmmLabel lbl) target = CmmLit (CmmLabel lbl)
(fast_args, rest_args) = splitAt arity args (fast_args, rest_args) = splitAt real_arity args
stack_args = slowArgs rest_args stack_args = slowArgs rest_args
real_arity = case call_conv of
NativeNodeCall -> arity+1
_ -> arity
-- When constructing calls, it is easier to keep the ArgReps and the -- When constructing calls, it is easier to keep the ArgReps and the
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment