Commit d76b6a05 authored by Isaac Dupree's avatar Isaac Dupree

change CmmActual, CmmFormal to use a data CmmHinted rather than tuple (#1405)

This allows the instance of UserOfLocalRegs to be within Haskell98, and IMHO
 makes the code a little cleaner generally.
This is one small (though tedious) step towards making GHC's code more
 portable...
parent 84629bd7
......@@ -18,6 +18,7 @@ module Cmm (
CmmReturnInfo(..),
CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, CmmKind,
CmmFormalsWithoutKinds, CmmFormalWithoutKind,
CmmHinted(..),
CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
......@@ -240,8 +241,10 @@ data CmmStmt
CmmActuals -- with these return values.
type CmmKind = MachHint
type CmmActual = (CmmExpr, CmmKind)
type CmmFormal = (LocalReg,CmmKind)
data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: CmmKind }
deriving (Eq)
type CmmActual = CmmHinted CmmExpr
type CmmFormal = CmmHinted LocalReg
type CmmActuals = [CmmActual]
type CmmFormals = [CmmFormal]
type CmmFormalWithoutKind = LocalReg
......@@ -250,8 +253,8 @@ type CmmFormalsWithoutKinds = [CmmFormalWithoutKind]
data CmmSafety = CmmUnsafe | CmmSafe C_SRT
-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
instance UserOfLocalRegs a => UserOfLocalRegs (a, CmmKind) where
foldRegsUsed f set (a, _) = foldRegsUsed f set a
instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
foldRegsUsed f set (CmmHinted a _) = foldRegsUsed f set a
instance UserOfLocalRegs CmmStmt where
foldRegsUsed f set s = stmt s set
......@@ -271,6 +274,11 @@ instance UserOfLocalRegs CmmCallTarget where
foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
foldRegsUsed _ set (CmmPrim {}) = set
--just look like a tuple, since it was a tuple before
-- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmHinted a) where
ppr (CmmHinted a k) = ppr (a, k)
{-
Discussion
~~~~~~~~~~
......
......@@ -348,7 +348,7 @@ makeContinuationEntries formats
case lookup ident formats of
Nothing -> block
Just (ContFormat formals srt is_gc) ->
BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc)
BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc)
stmts targets exit
adaptBlockToFormat :: [(BlockId, ContFormat)]
......@@ -378,7 +378,7 @@ adaptBlockToFormat formats unique
target formals actuals srt ret is_gc
adaptor_block = mk_adaptor_block adaptor_ident
(ContinuationEntry (map fst formals) srt is_gc)
(ContinuationEntry (map hintlessCmm formals) srt is_gc)
next format_formals
adaptor_ident = BlockId unique
......@@ -390,7 +390,8 @@ adaptBlockToFormat formats unique
(CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
(map formal_to_actual format_formals)
formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint)
formal_to_actual (CmmHinted reg hint)
= (CmmHinted (CmmReg (CmmLocal reg)) hint)
-- TODO: Check if NoHint is right. We're
-- jumping to a C-- function not a foreign one
-- so it might always be right.
......
......@@ -359,14 +359,14 @@ continuationMaxStack formats (Continuation _ label _ False blocks) =
map stmt_arg_size (brokenBlockStmts block))
final_arg_size (FinalReturn args) =
argumentsSize (cmmExprRep . fst) args
argumentsSize (cmmExprRep . hintlessCmm) args
final_arg_size (FinalJump _ args) =
argumentsSize (cmmExprRep . fst) args
argumentsSize (cmmExprRep . hintlessCmm) args
final_arg_size (FinalCall next _ _ args _ _ True) = 0
final_arg_size (FinalCall next _ _ args _ _ False) =
-- We have to account for the stack used when we build a frame
-- for the *next* continuation from *this* continuation
argumentsSize (cmmExprRep . fst) args +
argumentsSize (cmmExprRep . hintlessCmm) args +
continuation_frame_size next_format
where
next_format = maybe unknown_format id $ lookup next' formats
......@@ -375,7 +375,7 @@ continuationMaxStack formats (Continuation _ label _ False blocks) =
final_arg_size _ = 0
stmt_arg_size (CmmJump _ args) =
argumentsSize (cmmExprRep . fst) args
argumentsSize (cmmExprRep . hintlessCmm) args
stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
panic "Safe call in processFormats"
stmt_arg_size (CmmReturn _) =
......
......@@ -228,7 +228,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
foreignCall call_uniques (CmmPrim target)
results arguments
formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint)
formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
foreignCall :: [Unique] -> CmmCallTarget -> CmmFormals -> CmmActuals -> [CmmStmt]
foreignCall uniques call results arguments =
......@@ -236,14 +236,14 @@ foreignCall uniques call results arguments =
saveThreadState ++
caller_save ++
[CmmCall (CmmCallee suspendThread CCallConv)
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
[ CmmHinted id PtrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ]
CmmUnsafe
CmmMayReturn,
CmmCall call results new_args CmmUnsafe CmmMayReturn,
CmmCall (CmmCallee resumeThread CCallConv)
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
[ CmmHinted new_base PtrHint ]
[ CmmHinted (CmmReg (CmmLocal id)) PtrHint ]
CmmUnsafe
CmmMayReturn,
-- Assign the result to BaseReg: we
......@@ -251,7 +251,7 @@ foreignCall uniques call results arguments =
CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
caller_load ++
loadThreadState tso_unique ++
[CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)]
[CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
where
(_, arg_stmts, new_args) =
loadArgsIntoTemps argument_uniques arguments
......@@ -363,12 +363,12 @@ tail_call spRel target arguments
= store_arguments ++ adjust_sp_reg spRel ++ jump where
store_arguments =
[stack_put spRel expr offset
| ((expr, _), StackParam offset) <- argument_formats] ++
| ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
[global_put expr global
| ((expr, _), RegisterParam global) <- argument_formats]
| ((CmmHinted expr _), RegisterParam global) <- argument_formats]
jump = [CmmJump target arguments]
argument_formats = assignArguments (cmmExprRep . fst) arguments
argument_formats = assignArguments (cmmExprRep . hintlessCmm) arguments
adjust_sp_reg spRel =
if spRel == 0
......
......@@ -137,7 +137,7 @@ lintCmmStmt labels = lint
lintCmmExpr r
return ()
lint (CmmCall target _res args _ _) =
lintTarget target >> mapM_ (lintCmmExpr.fst) args
lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
......@@ -145,8 +145,8 @@ lintCmmStmt labels = lint
if (erep == wordRep)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr.fst) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr.fst) ress
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
checkTarget id = if elemBlockSet id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
......
......@@ -164,7 +164,7 @@ addKilled new_killed live = live `minusUniqSet` new_killed
-- Liveness of a CmmStmt
--------------------------------
cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg]
cmmFormalsToLiveLocals formals = map fst formals
cmmFormalsToLiveLocals formals = map hintlessCmm formals
cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
cmmStmtLive _ (CmmNop) = id
......@@ -179,7 +179,7 @@ cmmStmtLive _ (CmmStore expr1 expr2) =
cmmExprLive expr2 . cmmExprLive expr1
cmmStmtLive _ (CmmCall target results arguments _ _) =
target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) .
foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) .
addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
target_liveness =
case target of
......@@ -197,9 +197,9 @@ cmmStmtLive other_live (CmmSwitch expr targets) =
id
(mapCatMaybes id targets))
cmmStmtLive _ (CmmJump expr params) =
const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
cmmStmtLive _ (CmmReturn params) =
const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet)
const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
--------------------------------
-- Liveness of a CmmExpr
......
......@@ -156,7 +156,7 @@ inlineStmt u a (CmmCall target regs es srt ret)
= CmmCall (infn target) regs es' srt ret
where infn (CmmCallee fn cconv) = CmmCallee fn cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
......
......@@ -470,10 +470,10 @@ cmm_kind_exprs :: { [ExtFCode CmmActual] }
| cmm_kind_expr ',' cmm_kind_exprs { $1 : $3 }
cmm_kind_expr :: { ExtFCode CmmActual }
: expr { do e <- $1; return (e, inferCmmKind e) }
: expr { do e <- $1; return (CmmHinted e (inferCmmKind e)) }
| expr STRING {% do h <- parseCmmKind $2;
return $ do
e <- $1; return (e,h) }
e <- $1; return (CmmHinted e h) }
exprs0 :: { [ExtFCode CmmExpr] }
: {- empty -} { [] }
......@@ -497,10 +497,10 @@ cmm_formals :: { [ExtFCode CmmFormal] }
| cmm_formal ',' cmm_formals { $1 : $3 }
cmm_formal :: { ExtFCode CmmFormal }
: local_lreg { do e <- $1; return (e, inferCmmKind (CmmReg (CmmLocal e))) }
: local_lreg { do e <- $1; return (CmmHinted e (inferCmmKind (CmmReg (CmmLocal e)))) }
| STRING local_lreg {% do h <- parseCmmKind $1;
return $ do
e <- $2; return (e,h) }
e <- $2; return (CmmHinted e h) }
local_lreg :: { ExtFCode LocalReg }
: NAME { do e <- lookupName $1;
......@@ -921,13 +921,13 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
(CmmCallee expr' convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'"
adjCallTarget :: CCallConv -> CmmExpr -> [(CmmExpr,MachHint)] -> CmmExpr
adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
#ifdef mingw32_TARGET_OS
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
where size (e,_) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
where size (CmmHinted e _) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
-- c.f. CgForeignCall.emitForeignCall
#endif
adjCallTarget _ expr _
......
......@@ -256,7 +256,7 @@ addProcPointProtocols procPoints formals g =
maybe_add_proto (Block id _) env | id == lg_entry g =
extendBlockEnv env id (Protocol stdArgConvention hinted_formals)
maybe_add_proto _ env = env
hinted_formals = map (\x -> (x, NoHint)) formals
hinted_formals = map (\x -> CmmHinted x NoHint) formals
stdArgConvention = ConventionStandard CmmCallConv Arguments
-- | For now, following a suggestion by Ben Lippmeier, we pass all
......@@ -279,7 +279,7 @@ pass_live_vars_as_args procPoints (protos, g) = (protos', g')
Nothing -> let live = lookupBlockEnv liveness id `orElse`
emptyRegSet -- XXX there's a bug lurking!
-- panic ("no liveness at block " ++ show id)
formals = map (\x->(x,NoHint)) $ uniqSetToList live
formals = map (\x -> CmmHinted x NoHint) $ uniqSetToList live
in extendBlockEnv protos id (Protocol ConventionPrivate formals)
g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) }
......
......@@ -196,10 +196,10 @@ loadArgsIntoTemps :: [Unique]
-> CmmActuals
-> ([Unique], [CmmStmt], CmmActuals)
loadArgsIntoTemps uniques [] = (uniques, [], [])
loadArgsIntoTemps uniques ((e, hint):args) =
loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
(uniques'',
new_stmts ++ remaining_stmts,
(new_e, hint) : remaining_e)
(CmmHinted new_e hint) : remaining_e)
where
(uniques', new_stmts, new_e) = maybeAssignTemp uniques e
(uniques'', remaining_stmts, remaining_e) =
......
......@@ -245,9 +245,9 @@ pprCFunType cconv ress args
]
where
res_type [] = ptext SLIT("void")
res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
res_type [CmmHinted one hint] = machRepHintCType (localRegRep one) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprRep expr) hint
-- ---------------------------------------------------------------------
-- unconditional branches
......@@ -755,17 +755,17 @@ pprCall ppr_fn cconv results args _
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
ppr_assign [(one,hint)] rhs
ppr_assign [CmmHinted one hint] rhs
= pprLocalReg one <> ptext SLIT(" = ")
<> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
pprArg (CmmHinted expr PtrHint)
= cCast (ptext SLIT("void *")) expr
-- see comment by machRepHintCType below
pprArg (expr, SignedHint)
pprArg (CmmHinted expr SignedHint)
= cCast (machRepSignedCType (cmmExprRep expr)) expr
pprArg (expr, _other)
pprArg (CmmHinted expr _other)
= pprExpr expr
pprUnHint PtrHint rep = parens (machRepCType rep)
......@@ -849,8 +849,8 @@ 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.fst) rs >>
mapM_ (te_Expr.fst) es
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
te_Stmt (CmmJump e _) = te_Expr e
......
......@@ -284,7 +284,7 @@ genCondBranch expr ident =
--
-- jump foo(a, b, c);
--
genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc
genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
genJump expr args =
hcat [ ptext SLIT("jump")
......@@ -298,18 +298,18 @@ genJump expr args =
, parens ( commafy $ map pprHinted args )
, semi ]
pprHinted :: Outputable a => (a, MachHint) -> SDoc
pprHinted (a, NoHint) = ppr a
pprHinted (a, PtrHint) = quotes(text "address") <+> ppr a
pprHinted (a, SignedHint) = quotes(text "signed") <+> ppr a
pprHinted (a, FloatHint) = quotes(text "float") <+> ppr a
pprHinted :: Outputable a => (CmmHinted a) -> SDoc
pprHinted (CmmHinted a NoHint) = ppr a
pprHinted (CmmHinted a PtrHint) = quotes(text "address") <+> ppr a
pprHinted (CmmHinted a SignedHint) = quotes(text "signed") <+> ppr a
pprHinted (CmmHinted a FloatHint) = quotes(text "float") <+> ppr a
-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
--
-- return (a, b, c);
--
genReturn :: [(CmmExpr, MachHint)] -> SDoc
genReturn :: [CmmHinted CmmExpr] -> SDoc
genReturn args =
hcat [ ptext SLIT("return")
......
......@@ -15,7 +15,7 @@ where
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, CmmCallTarget(..), CmmActuals, CmmFormals
, CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..)
, CmmStmt(CmmSwitch) -- imported in order to call ppr
)
import PprCmm()
......@@ -262,11 +262,11 @@ ppr_target t@(CmmLit _) = ppr t
ppr_target fn' = parens (ppr fn')
pprHinted :: Outputable a => (a, MachHint) -> SDoc
pprHinted (a, NoHint) = ppr a
pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
pprHinted :: Outputable a => CmmHinted a -> SDoc
pprHinted (CmmHinted a NoHint) = ppr a
pprHinted (CmmHinted a PtrHint) = doubleQuotes (text "address") <+> ppr a
pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
pprHinted (CmmHinted a FloatHint) = doubleQuotes (text "float") <+> ppr a
pprLast :: Last -> SDoc
pprLast stmt = (case stmt of
......
......@@ -165,7 +165,7 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
-- exactly like the cgInlinePrimOp case for unboxed tuple alts..
{ res_tmps <- mapFCs bindNewToTemp non_void_res_ids
; let res_hints = map (typeHint.idType) non_void_res_ids
; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts
; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts
; cgExpr rhs }
where
(_, res_ids, _, rhs) = head alts
......
......@@ -560,7 +560,7 @@ link_caf cl_info is_upd = do
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False
; emitRtsCallWithVols SLIT("newCAF") [CmmHinted (CmmReg nodeReg) PtrHint] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
......
......@@ -133,13 +133,13 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
then assignPtrTemp arg
else assignNonPtrTemp arg
| (arg, stg_arg) <- arg_exprs]
let arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args)
let arg_hints = zipWith CmmHinted arg_tmps (map (typeHint.stgArgType) stg_args)
{-
Now, allocate some result regs.
-}
(res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty
ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
emitForeignCall (zip res_regs res_hints) fcall
emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall
arg_hints emptyVarSet{-no live vars-}
-- tagToEnum# is special: we need to pull the constructor out of the table,
......
......@@ -64,7 +64,8 @@ cgForeignCall results fcall stg_args live
| (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
nonVoidArg rep]
arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args)
arg_hints = zipWith CmmHinted
arg_exprs (map (typeHint.stgArgType) stg_args)
-- in
emitForeignCall results fcall arg_hints live
......@@ -72,7 +73,7 @@ cgForeignCall results fcall stg_args live
emitForeignCall
:: CmmFormals -- where to put the results
-> ForeignCall -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> [CmmHinted CmmExpr] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
-> Code
......@@ -86,14 +87,14 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
= case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel
(mkForeignLabel lbl call_size False)))
DynamicTarget -> case args of (fn,_):rest -> (rest, fn)
DynamicTarget -> case args of (CmmHinted fn _):rest -> (rest, fn)
-- in the stdcall calling convention, the symbol needs @size appended
-- to it, where size is the total number of bytes of arguments. We
-- attach this info to the CLabel here, and the CLabel pretty printer
-- will generate the suffix when the label is printed.
call_size
| StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args))
| StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.hintlessCmm) args))
| otherwise = Nothing
-- ToDo: this might not be correct for 64-bit API
......@@ -108,7 +109,7 @@ emitForeignCall'
:: Safety
-> CmmFormals -- where to put the results
-> CmmCallTarget -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> [CmmHinted CmmExpr] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them
-> C_SRT -- the SRT of the calls continuation
-> CmmReturnInfo
......@@ -137,13 +138,13 @@ emitForeignCall' safety results target args vols srt ret
-- and the CPS will will be the one to convert that
-- to this sequence of three CmmUnsafe calls.
stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
[ CmmHinted id PtrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ]
CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv)
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
[ CmmHinted new_base PtrHint ]
[ CmmHinted (CmmReg (CmmLocal id)) PtrHint ]
CmmUnsafe ret)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
......@@ -163,9 +164,9 @@ resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
-- This is a HACK; really it should be done in the back end, but
-- it's easier to generate the temporaries here.
load_args_into_temps = mapM arg_assign_temp
where arg_assign_temp (e,hint) = do
where arg_assign_temp (CmmHinted e hint) = do
tmp <- maybe_assign_temp e
return (tmp,hint)
return (CmmHinted tmp hint)
load_target_into_temp (CmmCallee expr conv) = do
tmp <- maybe_assign_temp expr
......
......@@ -73,15 +73,15 @@ initHpc this_mod (HpcInfo tickCount hashNo)
= do { id <- newNonPtrTemp wordRep -- TODO FIXME NOW
; emitForeignCall'
PlayRisky
[(id,NoHint)]
[CmmHinted id NoHint]
(CmmCallee
(CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
CCallConv
)
[ (mkLblExpr mkHpcModuleNameLabel,PtrHint)
, (word32 tickCount, NoHint)
, (word32 hashNo, NoHint)
, (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
[ CmmHinted (mkLblExpr mkHpcModuleNameLabel) PtrHint
, CmmHinted (word32 tickCount) NoHint
, CmmHinted (word32 hashNo) NoHint
, CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) PtrHint
]
(Just [])
NoC_SRT -- No SRT b/c we PlayRisky
......
......@@ -123,9 +123,10 @@ emitPrimOp [res] ParOp [arg] live
-- later, we might want to inline it.
vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[(res,NoHint)]
[CmmHinted res NoHint]
(CmmCallee newspark CCallConv)
[(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)]
[ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint)
, (CmmHinted arg PtrHint) ]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
......@@ -143,7 +144,8 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
[{-no results-}]
(CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
CCallConv)
[(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
[ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint)
, (CmmHinted mutv PtrHint) ]
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
......@@ -348,9 +350,9 @@ emitPrimOp [res] op args live
| Just prim <- callishOp op
= do vols <- getVolatileRegs live
emitForeignCall' PlayRisky
[(res,NoHint)]
[CmmHinted res NoHint]
(CmmPrim prim)
[(a,NoHint) | a<-args] -- ToDo: hints?
[CmmHinted a NoHint | a<-args] -- ToDo: hints?
(Just vols)
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
......
......@@ -267,7 +267,7 @@ enterCostCentreThunk closure =
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [CmmHinted stack PtrHint] False
-- ToDo: vols
enter_ccs_fsub = enteringPAP 0
......@@ -415,8 +415,8 @@ emitSetCCC cc
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
pushCostCentre result ccs cc
= emitRtsCallWithResult result PtrHint
SLIT("PushCostCentre") [(ccs,PtrHint),
(CmmLit (mkCCostCentre cc), PtrHint)]
SLIT("PushCostCentre") [CmmHinted ccs PtrHint,
CmmHinted (CmmLit (mkCCostCentre cc)) PtrHint]
False
bumpSccCount :: CmmExpr -> CmmStmt
......
......@@ -333,24 +333,24 @@ emitIfThenElse cond then_part else_part
; labelC join_id
}
emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code
emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
emitRtsCallWithVols fun args vols safe
= emitRtsCall' [] fun args (Just vols) safe
emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
-> [(CmmExpr,MachHint)] -> Bool -> Code
-> [CmmHinted CmmExpr] -> Bool -> Code
emitRtsCallWithResult res hint fun args safe
= emitRtsCall' [(res,hint)] fun args Nothing safe
= emitRtsCall' [CmmHinted res hint] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
:: CmmFormals
-> LitString
-> [(CmmExpr,MachHint)]
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> Code
......
......@@ -719,9 +719,9 @@ cmmStmtConFold stmt
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
args' <- mapM (\(arg, hint) -> do
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' srt returns