This frees the Cmm data type from keeping a list of live global registers
in CmmCall which helps prepare for the CPS conversion phase.
CPS conversion does its own liveness analysis and takes input that should
not directly refer to parameter registers (e.g. R1, F5, D3, L2). Since
these are the only things which could occur in the live global register
list, CPS conversion makes that field of the CmmCall constructor obsolite.
Once the CPS conversion pass is fully implemented, global register saving
will move from codeGen into the CPS pass. Until then, this patch
is worth scrutinizing and testing to ensure it doesn't cause any performance
or correctness problems as the code passed to the backends by the CPS
converting will look very similar to the code that this patch makes codeGen
pass to the backend.
CmmCallTarget
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
CmmCallTarget
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
- (Maybe [GlobalReg]) -- Global regs that may need to be saved
- -- if they will be clobbered by the call.
- -- Nothing <=> save *all* globals that
- -- might be clobbered.
| CmmBranch BlockId -- branch to another BB in this fn
| CmmBranch BlockId -- branch to another BB in this fn
lintCmmExpr l
lintCmmExpr r
return ()
lintCmmExpr l
lintCmmExpr r
return ()
-lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
+lintCmmStmt (CmmCall _target _res args) = mapM_ (lintCmmExpr.fst) args
lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
lintCmmStmt (CmmSwitch e _branches) = do
erep <- lintCmmExpr e
lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
lintCmmStmt (CmmSwitch e _branches) = do
erep <- lintCmmExpr e
getStmtUses :: CmmStmt -> UniqFM Int
getStmtUses (CmmAssign _ e) = getExprUses e
getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
getStmtUses :: CmmStmt -> UniqFM Int
getStmtUses (CmmAssign _ e) = getExprUses e
getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
-getStmtUses (CmmCall target _ es _)
+getStmtUses (CmmCall target _ es)
= plusUFM_C (+) (uses target) (getExprsUses (map fst es))
where uses (CmmForeignCall e _) = getExprUses e
uses _ = emptyUFM
= plusUFM_C (+) (uses target) (getExprsUses (map fst es))
where uses (CmmForeignCall e _) = getExprUses e
uses _ = emptyUFM
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
-inlineStmt u a (CmmCall target regs es vols)
- = CmmCall (infn target) regs es' vols
+inlineStmt u a (CmmCall target regs es)
+ = CmmCall (infn target) regs es'
where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
where
rep = cmmExprRep src
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args volatile ->
+ CmmCall (CmmForeignCall fn cconv) results args ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args volatile
+ pprCall ppr_fn cconv results args
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args volatile ->
- pprCall ppr_fn CCallConv results args volatile
+ CmmCall (CmmPrim op) results args ->
+ pprCall ppr_fn CCallConv results args
where
ppr_fn = pprCallishMachOp_for_C op
where
ppr_fn = pprCallishMachOp_for_C op
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> SDoc
-pprCall ppr_fn cconv results args vols
+pprCall ppr_fn cconv results args
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
| otherwise
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
| otherwise
- = save vols $$
- ptext SLIT("CALLER_SAVE_SYSTEM") $$
#if x86_64_TARGET_ARCH
-- HACK around gcc optimisations.
-- x86_64 needs a __DISCARD__() here, to create a barrier between
#if x86_64_TARGET_ARCH
-- HACK around gcc optimisations.
-- x86_64 needs a __DISCARD__() here, to create a barrier between
then ptext SLIT("__DISCARD__();")
else empty) $$
#endif
then ptext SLIT("__DISCARD__();")
else empty) $$
#endif
- ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
- ptext SLIT("CALLER_RESTORE_SYSTEM") $$
- restore vols
+ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
where
ppr_assign [] rhs = rhs
ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
pprUnHint SignedHint rep = parens (machRepCType rep)
pprUnHint _ _ = empty
pprUnHint SignedHint rep = parens (machRepCType rep)
pprUnHint _ _ = empty
- save = save_restore SLIT("CALLER_SAVE")
- restore = save_restore SLIT("CALLER_RESTORE")
-
- -- Nothing says "I don't know what's live; save everything"
- -- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
- save_restore txt Nothing = ptext txt <> ptext SLIT("_USER")
- save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
- where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r
-
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
VanillaReg n -> char 'R' <> int n -- without the .w suffix
pprGlobalRegName :: GlobalReg -> SDoc
pprGlobalRegName gr = case gr of
VanillaReg n -> char 'R' <> int n -- without the .w suffix
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es _) = mapM_ (te_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es) = mapM_ (te_Reg.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args _volatile ->
+ CmmCall (CmmForeignCall fn cconv) results args ->
hcat [ ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
hcat [ ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
- CmmCall (CmmPrim op) results args volatile ->
+ CmmCall (CmmPrim op) results args ->
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
import StaticFlags
import Outputable
import StaticFlags
import Outputable
+import MachRegs (callerSaveVolatileRegs)
+ -- HACK: this is part of the NCG so we shouldn't use this, but we need
+ -- it for now to eliminate the need for saved regs to be in CmmCall.
+ -- The long term solution is to factor callerSaveVolatileRegs
+ -- from nativeGen into codeGen
+
import Control.Monad
-- -----------------------------------------------------------------------------
import Control.Monad
-- -----------------------------------------------------------------------------
emitForeignCall' safety results target args vols
| not (playSafe safety) = do
temp_args <- load_args_into_temps args
emitForeignCall' safety results target args vols
| not (playSafe safety) = do
temp_args <- load_args_into_temps args
- stmtC (CmmCall target results temp_args vols)
+ let (caller_save, caller_load) = callerSaveVolatileRegs vols
+ stmtsC caller_save
+ stmtC (CmmCall target results temp_args)
+ stmtsC caller_load
| otherwise = do
id <- newTemp wordRep
temp_args <- load_args_into_temps args
temp_target <- load_target_into_temp target
| otherwise = do
id <- newTemp wordRep
temp_args <- load_args_into_temps args
temp_target <- load_target_into_temp target
+ let (caller_save, caller_load) = callerSaveVolatileRegs vols
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[(id,PtrHint)]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[(id,PtrHint)]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
- stmtC (CmmCall temp_target results temp_args vols)
+ stmtC (CmmCall temp_target results temp_args)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (CmmGlobal BaseReg, PtrHint) ]
-- Assign the result to BaseReg: we
-- might now have a different
-- Capability!
[ (CmmReg id, PtrHint) ]
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (CmmGlobal BaseReg, PtrHint) ]
-- Assign the result to BaseReg: we
-- might now have a different
-- Capability!
[ (CmmReg id, PtrHint) ]
suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
import PackageConfig
import Outputable
import PackageConfig
import Outputable
+import MachRegs (callerSaveVolatileRegs)
+ -- HACK: this is part of the NCG so we shouldn't use this, but we need
+ -- it for now to eliminate the need for saved regs to be in CmmCall.
+ -- The long term solution is to factor callerSaveVolatileRegs
+ -- from nativeGen into codeGen
+
import Data.Char
import Data.Bits
import Data.Word
import Data.Char
import Data.Bits
import Data.Word
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
-> Code
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
-> Code
-emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols)
+emitRtsCall' res fun args vols = do
+ stmtsC caller_save
+ stmtC (CmmCall target res args)
+ stmtsC caller_load
+ (caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmForeignCall fun_expr CCallConv
fun_expr = mkLblExpr (mkRtsCodeLabel fun)
target = CmmForeignCall fun_expr CCallConv
fun_expr = mkLblExpr (mkRtsCodeLabel fun)
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
-fixAssign (CmmCall target results args vols)
+fixAssign (CmmCall target results args)
= mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
= mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
- returnUs (caller_save ++
- CmmCall target results' args vols :
- caller_restore ++
+ returnUs (CmmCall target results' args :
- -- we also save/restore any caller-saves STG registers here
- (caller_save, caller_restore) = callerSaveVolatileRegs vols
-
fixResult g@(CmmGlobal reg,hint) =
case get_GlobalReg_reg_or_addr reg of
Left realreg -> returnUs (g, [])
fixResult g@(CmmGlobal reg,hint) =
case get_GlobalReg_reg_or_addr reg of
Left realreg -> returnUs (g, [])
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
- CmmCall target regs args vols
+ CmmCall target regs args
-> do target' <- case target of
CmmForeignCall e conv -> do
e' <- cmmExprConFold CallReference e
-> do target' <- case target of
CmmForeignCall e conv -> do
e' <- cmmExprConFold CallReference e
args' <- mapM (\(arg, hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
args' <- mapM (\(arg, hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
- return $ CmmCall target' regs args' vols
+ return $ CmmCall target' regs args'
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
| otherwise -> assignMem_IntCode kind addr src
where kind = cmmExprRep src
| otherwise -> assignMem_IntCode kind addr src
where kind = cmmExprRep src
- CmmCall target result_regs args vols
- -> genCCall target result_regs args vols
+ CmmCall target result_regs args
+ -> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
:: CmmCallTarget -- function to call
-> [(CmmReg,MachHint)] -- where to put the result
-> [(CmmExpr,MachHint)] -- arguments (of mixed type)
:: CmmCallTarget -- function to call
-> [(CmmReg,MachHint)] -- where to put the result
-> [(CmmExpr,MachHint)] -- arguments (of mixed type)
- -> Maybe [GlobalReg] -- volatile regs to save
-> NatM InstrBlock
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-> NatM InstrBlock
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
+genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- we only cope with a single result for foreign calls
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- we only cope with a single result for foreign calls
-genCCall (CmmPrim op) [(r,_)] args vols = do
+genCCall (CmmPrim op) [(r,_)] args = do
case op of
MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args
MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
case op of
MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args
MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args
MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args
MO_F32_Tan -> actuallyInlineFloatOp F32 (GTAN F32) args
MO_F64_Tan -> actuallyInlineFloatOp F64 (GTAN F64) args
- other_op -> outOfLineFloatOp op r args vols
+ other_op -> outOfLineFloatOp op r args
where
actuallyInlineFloatOp rep instr [(x,_)]
= do res <- trivialUFCode rep instr x
any <- anyReg res
return (any (getRegisterReg r))
where
actuallyInlineFloatOp rep instr [(x,_)]
= do res <- trivialUFCode rep instr x
any <- anyReg res
return (any (getRegisterReg r))
-genCCall target dest_regs args vols = do
+genCCall target dest_regs args = do
let
sizes = map (arg_size . cmmExprRep . fst) (reverse args)
#if !darwin_TARGET_OS
let
sizes = map (arg_size . cmmExprRep . fst) (reverse args)
#if !darwin_TARGET_OS
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)]
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> NatM InstrBlock
-outOfLineFloatOp mop res args vols
+ -> NatM InstrBlock
+outOfLineFloatOp mop res args
= do
targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
let target = CmmForeignCall targetExpr CCallConv
if cmmRegRep res == F64
then
= do
targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
let target = CmmForeignCall targetExpr CCallConv
if cmmRegRep res == F64
then
- stmtToInstrs (CmmCall target [(res,FloatHint)] args vols)
+ stmtToInstrs (CmmCall target [(res,FloatHint)] args)
else do
uq <- getUniqueNat
let
tmp = CmmLocal (LocalReg uq F64)
-- in
else do
uq <- getUniqueNat
let
tmp = CmmLocal (LocalReg uq F64)
-- in
- code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args vols)
+ code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args)
code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp))
return (code1 `appOL` code2)
where
code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp))
return (code1 `appOL` code2)
where
-genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
+genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
-genCCall (CmmPrim op) [(r,_)] args vols =
- outOfLineFloatOp op r args vols
+genCCall (CmmPrim op) [(r,_)] args =
+ outOfLineFloatOp op r args
-genCCall target dest_regs args vols = do
+genCCall target dest_regs args = do
-- load up the register arguments
(stack_args, aregs, fregs, load_args_code)
-- load up the register arguments
(stack_args, aregs, fregs, load_args_code)
stack only immediately prior to the call proper. Sigh.
-}
stack only immediately prior to the call proper. Sigh.
-}
-genCCall target dest_regs argsAndHints vols = do
+genCCall target dest_regs argsAndHints = do
let
args = map fst argsAndHints
argcode_and_vregs <- mapM arg_to_int_vregs args
let
args = map fst argsAndHints
argcode_and_vregs <- mapM arg_to_int_vregs args
genCCall (CmmPrim MO_WriteBarrier) _ _ _
= return $ unitOL LWSYNC
genCCall (CmmPrim MO_WriteBarrier) _ _ _
= return $ unitOL LWSYNC
-genCCall target dest_regs argsAndHints vols
+genCCall target dest_regs argsAndHints
= ASSERT (not $ any (`elem` [I8,I16]) argReps)
-- we rely on argument promotion in the codeGen
do
= ASSERT (not $ any (`elem` [I8,I16]) argReps)
-- we rely on argument promotion in the codeGen
do
-- Here we generate the sequence of saves/restores required around a
-- foreign call instruction.
-- Here we generate the sequence of saves/restores required around a
-- foreign call instruction.
+-- TODO: reconcile with includes/Regs.h
+-- * Regs.h claims that BaseReg should be saved last and loaded first
+-- * This might not have been tickled before since BaseReg is callee save
+-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
callerSaveVolatileRegs vols = (caller_save, caller_load)
where
callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
callerSaveVolatileRegs vols = (caller_save, caller_load)
where