Commit cbe24168 authored by Simon Marlow's avatar Simon Marlow

Get rid of the "safety" field of CmmCall (OldCmm)

This field was doing nothing.  I think it originally appeared in a
very old incarnation of the new code generator.
parent 7d13e504
......@@ -91,7 +91,7 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
Old.CmmCall (cmm_target target)
(add_hints (get_conv target) Results ress)
(add_hints (get_conv target) Arguments args)
Old.CmmUnsafe Old.CmmMayReturn
Old.CmmMayReturn
last :: CmmNode O C -> () -> [Old.CmmStmt]
last node _ = stmts
......
......@@ -133,7 +133,7 @@ lintCmmStmt platform labels = lint
_ <- lintCmmExpr platform l
_ <- lintCmmExpr platform r
return ()
lint (CmmCall target _res args _ _) =
lint (CmmCall target _res args _) =
lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
lint (CmmSwitch e branches) = do
......
......@@ -59,7 +59,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt m (CmmComment _) = m
stmt m (CmmAssign _ e) = expr m e
stmt m (CmmStore e1 e2) = expr (expr m e1) e2
stmt m (CmmCall c _ as _ _) = f (actuals m as) c
stmt m (CmmCall c _ as _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _) = m
stmt m (CmmBranch b) = b:m
......@@ -266,8 +266,8 @@ lookForInline' u expr regset (stmt : rest)
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 srt ret)
= CmmCall (infn target) regs es' srt ret
inlineStmt u a (CmmCall target regs es ret)
= CmmCall (infn target) regs es' ret
where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
......
......@@ -867,10 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
results <- sequence results_code
expr <- expr_code
args <- sequence args_code
--code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
case convention of
-- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
_ ->
let expr' = adjCallTarget convention expr args in
case safety of
......
......@@ -154,7 +154,6 @@ data CmmStmt -- Old-style
CmmCallTarget
[HintedCmmFormal] -- zero or more results
[HintedCmmActual] -- zero or more arguments
CmmSafety -- whether to build a continuation
CmmReturnInfo
-- Some care is necessary when handling the arguments of these, see
-- [Register parameter passing] and the hack in cmm/CmmOpt.hs
......@@ -192,7 +191,7 @@ instance UserOfLocalRegs CmmStmt where
stmt (CmmComment {}) = id
stmt (CmmAssign _ e) = gen e
stmt (CmmStore e1 e2) = gen e1 . gen e2
stmt (CmmCall target _ es _ _) = gen target . gen es
stmt (CmmCall target _ es _) = gen target . gen es
stmt (CmmBranch _) = id
stmt (CmmCondBranch e _) = gen e
stmt (CmmSwitch e _) = gen e
......
......@@ -122,11 +122,10 @@ pprStmt platform stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall (CmmCallee fn cconv) results args safety ret ->
CmmCall (CmmCallee fn cconv) results args ret ->
sep [ pp_lhs <+> pp_conv
, nest 2 (pprExpr9 platform fn <>
parens (commafy (map ppr_ar args)))
<> brackets (pprPlatform platform safety)
, case ret of CmmMayReturn -> empty
CmmNeverReturns -> ptext $ sLit (" never returns")
] <> semi
......@@ -142,9 +141,9 @@ pprStmt platform stmt = case stmt of
_ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
CmmCall (CmmPrim op) results args safety ret ->
CmmCall (CmmPrim op) results args ret ->
pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
results args safety ret)
results args ret)
where
-- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
-- use one to get the label printed.
......
......@@ -193,7 +193,7 @@ pprStmt platform stmt = case stmt of
where
rep = cmmExprType src
CmmCall (CmmCallee fn cconv) results args safety ret ->
CmmCall (CmmCallee fn cconv) results args ret ->
maybe_proto $$
fnCall
where
......@@ -215,7 +215,7 @@ pprStmt platform stmt = case stmt of
case fn of
CmmLit (CmmLabel lbl)
| StdCallConv <- cconv ->
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
in (real_fun_proto lbl, myCall)
-- stdcall functions must be declared with
-- a function type, otherwise the C compiler
......@@ -223,22 +223,22 @@ pprStmt platform stmt = case stmt of
-- can't add the @n suffix ourselves, because
-- it isn't valid C.
| CmmNeverReturns <- ret ->
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args safety <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
)
in (fun_proto lbl, myCall)
_ ->
(empty {- no proto -},
pprCall platform cast_fn cconv results args safety <> semi)
pprCall platform cast_fn cconv results args <> semi)
-- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim op) results args safety _ret ->
pprCall platform ppr_fn CCallConv results args' safety
CmmCall (CmmPrim op) results args _ret ->
pprCall platform ppr_fn CCallConv results args'
where
ppr_fn = pprCallishMachOp_for_C op
-- The mem primops carry an extra alignment arg, must drop it.
......@@ -812,10 +812,10 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-- Foreign Calls
pprCall :: Platform -> SDoc -> CCallConv
-> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
-> [HintedCmmFormal] -> [HintedCmmActual]
-> SDoc
pprCall platform ppr_fn cconv results args _
pprCall platform ppr_fn cconv results args
| not (is_cishCC cconv)
= panic $ "pprCall: unknown calling convention"
......@@ -926,7 +926,7 @@ te_Lit _ = return ()
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_temp.hintlessCmm) rs >>
te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >>
mapM_ (te_Expr.hintlessCmm) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
......
......@@ -482,7 +482,7 @@ emitBlackHoleCode is_single_entry = do
stmtsC [
CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
(CmmReg (CmmGlobal CurrentTSO)),
CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn,
CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmMayReturn,
CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
]
\end{code}
......@@ -580,7 +580,7 @@ link_caf cl_info _is_upd = do
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
CmmHinted (CmmReg nodeReg) AddrHint,
CmmHinted hp_rel AddrHint ]
(Just [node]) False
(Just [node])
-- node is live, so save it.
-- see Note [atomic CAF entry] in rts/sm/Storage.c
......
......@@ -127,7 +127,7 @@ emitForeignCall' safety results target args vols _srt ret
let (caller_save, caller_load) = callerSaveVolatileRegs vols
let caller_load' = if ret == CmmNeverReturns then [] else caller_load
stmtsC caller_save
stmtC (CmmCall target results temp_args CmmUnsafe ret)
stmtC (CmmCall target results temp_args ret)
stmtsC caller_load'
| otherwise = do
......@@ -149,12 +149,12 @@ emitForeignCall' safety results target args vols _srt ret
[ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
, CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
ret)
stmtC (CmmCall temp_target results temp_args ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv)
[ CmmHinted new_base AddrHint ]
[ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
CmmUnsafe ret)
ret)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
......
......@@ -142,7 +142,7 @@ enterCostCentreFun ccs closure =
ifProfiling $ do
if isCurrentCCS ccs
then emitRtsCall rtsPackageId (fsLit "enterFunCCS")
[CmmHinted (costCentreFrom closure) AddrHint] False
[CmmHinted (costCentreFrom closure) AddrHint]
else return () -- top-level function, nothing to do
ifProfiling :: Code -> Code
......@@ -234,7 +234,6 @@ pushCostCentre result ccs cc
rtsPackageId
(fsLit "pushCostCentre") [CmmHinted ccs AddrHint,
CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
False
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
......
......@@ -233,23 +233,22 @@ emitRtsCall
:: PackageId -- ^ package the function is in
-> FastString -- ^ name of function
-> [CmmHinted CmmExpr] -- ^ function args
-> Bool -- ^ whether this is a safe call
-> Code -- ^ cmm code
emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args Nothing safe
emitRtsCall pkg fun args = emitRtsCallGen [] pkg fun args Nothing
-- The 'Nothing' says "save all global registers"
emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
emitRtsCallWithVols pkg fun args vols safe
= emitRtsCallGen [] pkg fun args (Just vols) safe
emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Code
emitRtsCallWithVols pkg fun args vols
= emitRtsCallGen [] pkg fun args (Just vols)
emitRtsCallWithResult
:: LocalReg -> ForeignHint
-> PackageId -> FastString
-> [CmmHinted CmmExpr] -> Bool -> Code
-> [CmmHinted CmmExpr] -> Code
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing safe
emitRtsCallWithResult res hint pkg fun args
= emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing
-- Make a call to an RTS C procedure
emitRtsCallGen
......@@ -258,14 +257,10 @@ emitRtsCallGen
-> FastString
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> Code
emitRtsCallGen res pkg fun args vols safe = do
safety <- if safe
then getSRTInfo >>= (return . CmmSafe)
else return CmmUnsafe
emitRtsCallGen res pkg fun args vols = do
stmtsC caller_save
stmtC (CmmCall target res args safety CmmMayReturn)
stmtC (CmmCall target res args CmmMayReturn)
stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
......@@ -1009,13 +1004,13 @@ fixStgRegStmt stmt
CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
CmmCall target regs args srt returns ->
CmmCall target regs args returns ->
let target' = case target of
CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
other -> other
args' = map (\(CmmHinted arg hint) ->
(CmmHinted (fixStgRegExpr arg) hint)) args
in CmmCall target' regs args' srt returns
in CmmCall target' regs args' returns
CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
......
......@@ -125,7 +125,7 @@ stmtToInstrs env stmt = case stmt of
CmmSwitch arg ids -> genSwitch env arg ids
-- Foreign Call
CmmCall target res args _ ret
CmmCall target res args ret
-> genCall env target res args ret
-- Tail call
......
......@@ -879,7 +879,7 @@ cmmStmtConFold stmt
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
CmmCall target regs args srt returns
CmmCall target regs args returns
-> do target' <- case target of
CmmCallee e conv -> do
e' <- cmmExprConFold CallReference e
......@@ -888,7 +888,7 @@ cmmStmtConFold stmt
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' srt returns
return $ CmmCall target' regs args' returns
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
......
......@@ -135,7 +135,7 @@ stmtToInstrs stmt = do
where ty = cmmExprType src
size = cmmTypeSize ty
CmmCall target result_regs args _ _
CmmCall target result_regs args _
-> genCCall target result_regs args
CmmBranch id -> genBranch id
......
......@@ -135,7 +135,7 @@ stmtToInstrs stmt = case stmt of
where ty = cmmExprType src
size = cmmTypeSize ty
CmmCall target result_regs args _ _
CmmCall target result_regs args _
-> genCCall target result_regs args
CmmBranch id -> genBranch id
......
......@@ -160,7 +160,7 @@ stmtToInstrs stmt = do
where ty = cmmExprType src
size = cmmTypeSize ty
CmmCall target result_regs args _ _
CmmCall target result_regs args _
-> genCCall is32Bit target result_regs args
CmmBranch id -> genBranch id
......@@ -1996,7 +1996,7 @@ outOfLineCmmOp mop res args
targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
let target = CmmCallee targetExpr CCallConv
stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn)
stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmMayReturn)
where
-- Assume we can call these functions directly, and that they're not in a dynamic library.
-- TODO: Why is this ok? Under linux this code will be in libm.so
......
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