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