Commit 20780258 authored by Michael D. Adams's avatar Michael D. Adams

Added pointerhood to LocalReg

This version should compile but is still incomplete as it introduces
potential bugs at the places marked 'TODO FIXME NOW'.
It is being recorded to help keep track of changes.
parent bb5c3f58
......@@ -10,13 +10,13 @@ module Cmm (
GenCmm(..), Cmm,
GenCmmTop(..), CmmTop,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
CmmStmt(..), CmmActuals, CmmFormals,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmCallTarget(..),
CmmStatic(..), Section(..),
CmmExpr(..), cmmExprRep,
CmmReg(..), cmmRegRep,
CmmLit(..), cmmLitRep,
LocalReg(..), localRegRep,
LocalReg(..), localRegRep, Kind(..),
BlockId(..), BlockEnv,
GlobalReg(..), globalRegRep,
......@@ -114,7 +114,7 @@ data CmmStmt
| CmmCall -- A foreign call, with
CmmCallTarget
CmmFormals -- zero or more results
CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments
| CmmBranch BlockId -- branch to another BB in this fn
......@@ -133,8 +133,11 @@ data CmmStmt
| CmmReturn -- Return from a function,
CmmActuals -- with these return values.
type CmmActuals = [(CmmExpr,MachHint)]
type CmmFormals = [(CmmReg,MachHint)]
type CmmActual = CmmExpr
type CmmActuals = [(CmmActual,MachHint)]
type CmmFormal = LocalReg
type CmmHintFormals = [(CmmFormal,MachHint)]
type CmmFormals = [CmmFormal]
{-
Discussion
......@@ -221,17 +224,25 @@ cmmRegRep :: CmmReg -> MachRep
cmmRegRep (CmmLocal reg) = localRegRep reg
cmmRegRep (CmmGlobal reg) = globalRegRep reg
-- | Whether a 'LocalReg' is a GC followable pointer
data Kind = KindPtr | KindNonPtr deriving (Eq)
data LocalReg
= LocalReg !Unique MachRep
= LocalReg
!Unique -- ^ Identifier
MachRep -- ^ Type
Kind -- ^ Should the GC follow as a pointer
instance Eq LocalReg where
(LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
(LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
instance Uniquable LocalReg where
getUnique (LocalReg uniq _) = uniq
getUnique (LocalReg uniq _ _) = uniq
localRegRep :: LocalReg -> MachRep
localRegRep (LocalReg _ rep) = rep
localRegRep (LocalReg _ rep _) = rep
localRegGCFollow (LocalReg _ _ p) = p
data CmmLit
= CmmInt Integer MachRep
......
......@@ -78,7 +78,7 @@ data FinalStmt
BlockId -- ^ Target of the 'CmmGoto'
-- (must be a 'ContinuationEntry')
CmmCallTarget -- ^ The function to call
CmmFormals -- ^ Results from call
CmmHintFormals -- ^ Results from call
-- (redundant with ContinuationEntry)
CmmActuals -- ^ Arguments to call
......@@ -142,7 +142,7 @@ breakBlock uniques (BasicBlock ident stmts) entry =
block = do_call current_id entry accum_stmts exits next_id
target results arguments
rest = breakBlock' (tail uniques) next_id
(ContinuationEntry results) [] [] stmts
(ContinuationEntry (map fst results)) [] [] stmts
(s:stmts) ->
breakBlock' uniques current_id entry
(cond_branch_target s++exits)
......
......@@ -157,7 +157,7 @@ data StackFormat
= StackFormat {
stack_label :: Maybe CLabel, -- The label occupying the top slot
stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
stack_live :: [(CmmReg, WordOff)] -- local reg offsets from stack top
stack_live :: [(LocalReg, WordOff)] -- local reg offsets from stack top
-- TODO: see if the above can be LocalReg
}
......@@ -230,11 +230,11 @@ selectStackFormat live continuations =
live_to_format label formals live =
foldl extend_format
(StackFormat (Just label) retAddrSizeW [])
(uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
(uniqSetToList (live `minusUniqSet` mkUniqSet formals))
extend_format :: StackFormat -> LocalReg -> StackFormat
extend_format (StackFormat label size offsets) reg =
StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
StackFormat label (slot_size reg + size) ((reg, size) : offsets)
slot_size :: LocalReg -> Int
slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
......@@ -315,7 +315,7 @@ pack_continuation (StackFormat curr_id curr_frame_size _)
= store_live_values ++ set_stack_header where
-- TODO: only save variables when actually needed (may be handled by latter pass)
store_live_values =
[stack_put spRel (CmmReg reg) offset
[stack_put spRel (CmmReg (CmmLocal reg)) offset
| (reg, offset) <- cont_offsets]
set_stack_header =
if not needs_header
......@@ -342,11 +342,11 @@ function_entry formals (StackFormat _ _ curr_offsets)
| (reg, offset) <- curr_offsets]
load_args =
[stack_get 0 reg offset
| ((reg, _), StackParam offset) <- argument_formats] ++
| (reg, StackParam offset) <- argument_formats] ++
[global_get reg global
| ((reg, _), RegisterParam global) <- argument_formats]
| (reg, RegisterParam global) <- argument_formats]
argument_formats = assignArguments (cmmRegRep . fst) formals
argument_formats = assignArguments (localRegRep) formals
-----------------------------------------------------------------------------
-- Section: Stack and argument register puts and gets
......@@ -366,13 +366,13 @@ stack_put spRel expr offset =
--------------------------------
-- |Construct a
stack_get :: WordOff
-> CmmReg
-> LocalReg
-> WordOff
-> CmmStmt
stack_get spRel reg offset =
CmmAssign reg (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (cmmRegRep reg))
CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg))
global_put :: CmmExpr -> GlobalReg -> CmmStmt
global_put expr global = CmmAssign (CmmGlobal global) expr
global_get :: CmmReg -> GlobalReg -> CmmStmt
global_get reg global = CmmAssign reg (CmmReg (CmmGlobal global))
global_get :: LocalReg -> GlobalReg -> CmmStmt
global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
......@@ -2,7 +2,7 @@ module CmmLive (
CmmLive,
BlockEntryLiveness,
cmmLiveness,
cmmFormalsToLiveLocals,
cmmHintFormalsToLiveLocals,
) where
#include "HsVersions.h"
......@@ -156,10 +156,8 @@ addKilled new_killed live = live `minusUniqSet` new_killed
--------------------------------
-- Liveness of a CmmStmt
--------------------------------
cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg]
cmmFormalsToLiveLocals [] = []
cmmFormalsToLiveLocals ((CmmGlobal _,_):args) = cmmFormalsToLiveLocals args
cmmFormalsToLiveLocals ((CmmLocal r,_):args) = r:cmmFormalsToLiveLocals args
cmmHintFormalsToLiveLocals :: CmmHintFormals -> [LocalReg]
cmmHintFormalsToLiveLocals formals = map fst formals
cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
cmmStmtLive _ (CmmNop) = id
......@@ -175,7 +173,7 @@ cmmStmtLive _ (CmmStore expr1 expr2) =
cmmStmtLive _ (CmmCall target results arguments) =
target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) .
addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
target_liveness =
case target of
(CmmForeignCall target _) -> cmmExprLive target
......
......@@ -93,7 +93,7 @@ cmmMiniInline blocks = map do_inline blocks
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _ _)) expr) : stmts)
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
......@@ -109,7 +109,7 @@ cmmMiniInlineStmts uses (stmt:stmts)
-- Try to inline a temporary assignment. We can skip over assignments to
-- other tempoararies, because we know that expressions aren't side-effecting
-- and temporaries are single-assignment.
lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
| u /= u'
= case lookupUFM (getExprUses rhs) u of
Just 1 -> Just (inlineStmt u expr stmt : rest)
......@@ -150,8 +150,8 @@ getStmtUses (CmmJump e _) = getExprUses e
getStmtUses _ = emptyUFM
getExprUses :: CmmExpr -> UniqFM Int
getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
getExprUses (CmmReg (CmmLocal (LocalReg u _ _))) = unitUFM u 1
getExprUses (CmmRegOff (CmmLocal (LocalReg u _ _)) _) = unitUFM u 1
getExprUses (CmmLoad e _) = getExprUses e
getExprUses (CmmMachOp _ es) = getExprsUses es
getExprUses _other = emptyUFM
......@@ -172,10 +172,10 @@ inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
inlineStmt u a other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _ _)))
| u == u' = a
| otherwise = e
inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep _)) off)
| u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
| otherwise = e
inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
......
......@@ -244,7 +244,10 @@ body :: { ExtCode }
| stmt body { do $1; $2 }
decl :: { ExtCode }
: type names ';' { mapM_ (newLocal $1) $2 }
: type names ';' { mapM_ (newLocal defaultKind $1) $2 }
| STRING type names ';' {% do k <- parseKind $1;
return $ mapM_ (newLocal k $2) $3 }
| 'import' names ';' { return () } -- ignore imports
| 'export' names ';' { return () } -- ignore exports
......@@ -401,21 +404,32 @@ reg :: { ExtFCode CmmExpr }
: NAME { lookupName $1 }
| GLOBALREG { return (CmmReg (CmmGlobal $1)) }
maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
| hint_lregs '=' { $1 }
hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
| hint_lregs { $1 }
hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
: hint_lreg ',' { [$1] }
| hint_lreg { [$1] }
| hint_lreg ',' hint_lregs { $1 : $3 }
hint_lreg :: { ExtFCode (CmmReg, MachHint) }
: lreg { do e <- $1; return (e, inferHint (CmmReg e)) }
| STRING lreg {% do h <- parseHint $1;
hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
: local_lreg { do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
| STRING local_lreg {% do h <- parseHint $1;
return $ do
e <- $2; return (e,h) }
local_lreg :: { ExtFCode LocalReg }
: NAME { do e <- lookupName $1;
return $
case e of
CmmReg (CmmLocal r) -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
lreg :: { ExtFCode CmmReg }
: NAME { do e <- lookupName $1;
return $
......@@ -580,6 +594,13 @@ parseHint "signed" = return SignedHint
parseHint "float" = return FloatHint
parseHint str = fail ("unrecognised hint: " ++ str)
parseKind :: String -> P Kind
parseKind "ptr" = return KindPtr
parseKind str = fail ("unrecognized kin: " ++ str)
defaultKind :: Kind
defaultKind = KindNonPtr
-- labels are always pointers, so we might as well infer the hint
inferHint :: CmmExpr -> MachHint
inferHint (CmmLit (CmmLabel _)) = PtrHint
......@@ -694,10 +715,12 @@ addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
addLabel :: FastString -> BlockId -> ExtCode
addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
newLocal :: MachRep -> FastString -> ExtCode
newLocal ty name = do
newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
newLocal kind ty name = do
u <- code newUnique
addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
let reg = LocalReg u ty kind
addVarDecl name (CmmReg (CmmLocal reg))
return reg
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
......@@ -792,7 +815,7 @@ staticClosure cl_label info payload
foreignCall
:: String
-> [ExtFCode (CmmReg,MachHint)]
-> [ExtFCode (CmmFormal,MachHint)]
-> ExtFCode CmmExpr
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
......@@ -809,7 +832,7 @@ foreignCall conv_string results_code expr_code args_code vols
(CmmForeignCall expr convention) args vols) where
primCall
:: [ExtFCode (CmmReg,MachHint)]
:: [ExtFCode (CmmFormal,MachHint)]
-> FastString
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
......
......@@ -206,7 +206,7 @@ pprStmt stmt = case stmt of
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
_other -> parens (cCast (pprCFunType cconv results args) fn)
_ -> parens (cCast (pprCFunType cconv results args) fn)
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
......@@ -229,7 +229,7 @@ pprStmt stmt = case stmt of
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
pprCFunType cconv ress args
= hcat [
res_type ress,
......@@ -238,7 +238,7 @@ pprCFunType cconv ress args
]
where
res_type [] = ptext SLIT("void")
res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
......@@ -713,12 +713,12 @@ pprGlobalReg gr = case gr of
GCFun -> ptext SLIT("stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals
-> SDoc
pprCall ppr_fn cconv results args
......@@ -741,17 +741,9 @@ pprCall ppr_fn cconv results args
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
| Just ty <- strangeRegType reg
= ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
-- BaseReg is special, sometimes it isn't an lvalue and we
-- can't assign to it.
ppr_assign [(one,hint)] rhs
| Just ty <- strangeRegType one
= pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
| otherwise
= pprReg one <> ptext SLIT(" = ")
<> pprUnHint hint (cmmRegRep one) <> rhs
= pprLocalReg one <> ptext SLIT(" = ")
<> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
......@@ -792,7 +784,7 @@ pprDataExterns statics
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
pprTempDecl l@(LocalReg _uniq rep)
pprTempDecl l@(LocalReg _ rep _)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
......@@ -847,7 +839,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_Reg.fst) rs >>
te_Stmt (CmmCall _ rs es) = mapM_ (te_temp.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
......
......@@ -425,10 +425,14 @@ pprReg r
-- We only print the type of the local reg if it isn't wordRep
--
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq rep)
= hcat [ char '_', ppr uniq,
(if rep == wordRep
then empty else dcolon <> ppr rep) ]
pprLocalReg (LocalReg uniq rep follow)
= hcat [ char '_', ppr uniq, ty ] where
ty = if rep == wordRep && follow == KindNonPtr
then empty
else dcolon <> ptr <> ppr rep
ptr = if follow == KindNonPtr
then empty
else doubleQuotes (text "ptr")
-- needs to be kept in syn with Cmm.hs.GlobalReg
--
......
......@@ -22,7 +22,7 @@ module CgBindery (
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp,
bindNewToTemp,
getArgAmode, getArgAmodes,
getCgIdInfo,
getCAddrModeIfVolatile, getVolatileRegs,
......@@ -391,13 +391,16 @@ bindNewToNode id offset lf_info
-- Create a new temporary whose unique is that in the id,
-- bind the id to it, and return the addressing mode for the
-- temporary.
bindNewToTemp :: Id -> FCode CmmReg
bindNewToTemp :: Id -> FCode LocalReg
bindNewToTemp id
= do addBindC id (regIdInfo id temp_reg lf_info)
= do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
return temp_reg
where
uniq = getUnique id
temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
kind = if isFollowableArg (idCgRep id)
then KindPtr
else KindNonPtr
lf_info = mkLFArgument id -- Always used of things we
-- know nothing about
......
......@@ -108,8 +108,8 @@ cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
alt_type@(PrimAlt tycon) alts
= do { tmp_reg <- bindNewToTemp bndr
; cm_lit <- cgLit lit
; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
; cgPrimAlts NoGC alt_type tmp_reg alts }
; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
\end{code}
Special case #2: scrutinising a primitive-typed variable. No
......@@ -129,8 +129,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
v_info <- getCgIdInfo v
; amode <- idInfoToAmode v_info
; tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign tmp_reg amode)
; cgPrimAlts NoGC alt_type tmp_reg alts }
; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
\end{code}
Special case #3: inline PrimOps and foreign calls.
......@@ -285,7 +285,7 @@ cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
= do { -- PRIMITIVE ALTS, with non-void result
tmp_reg <- bindNewToTemp bndr
; cgPrimOp [tmp_reg] primop args live_in_alts
; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
= ASSERT( isSingleton alts )
......@@ -315,7 +315,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
; this_pkg <- getThisPackage
; whenC (not (isDeadBinder bndr))
(do { tmp_reg <- bindNewToTemp bndr
; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) })
; stmtC (CmmAssign
(CmmLocal tmp_reg)
(tagToClosure this_pkg tycon tag_amode)) })
-- Compile the alts
; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
......@@ -332,9 +334,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
(_,e) <- getArgAmode arg
return e
do_enum_primop primop
= do tmp <- newTemp wordRep
= do tmp <- newNonPtrTemp wordRep
cgPrimOp [tmp] primop args live_in_alts
returnFC (CmmReg tmp)
returnFC (CmmReg (CmmLocal tmp))
cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
= pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
......
......@@ -117,17 +117,21 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
reps_n_amodes <- getArgAmodes stg_args
let
-- Get the *non-void* args, and jiggle them with shimForeignCall
arg_exprs = [ shimForeignCallArg stg_arg expr
arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg)
| (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
nonVoidArg rep]
arg_tmps <- mapM assignTemp arg_exprs
arg_tmps <- sequence [
if isFollowableArg (typeCgRep (stgArgType stg_arg))
then assignPtrTemp arg
else assignNonPtrTemp arg
| (arg, stg_arg) <- arg_exprs]
let arg_hints = zip 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 res_regs)) $
ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
emitForeignCall (zip res_regs res_hints) fcall
arg_hints emptyVarSet{-no live vars-}
......@@ -136,8 +140,11 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty)
= ASSERT(isEnumerationTyCon tycon)
do { (_,amode) <- getArgAmode arg
; amode' <- assignTemp amode -- We're going to use it twice,
do { (rep,amode) <- getArgAmode arg
; amode' <- if isFollowableArg rep
then assignPtrTemp amode
else assignNonPtrTemp amode
-- We're going to use it twice,
-- so save in a temp if non-trivial
; this_pkg <- getThisPackage
; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode'))
......@@ -160,21 +167,27 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
performReturn emitReturnInstr
| ReturnsPrim rep <- result_info
= do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)]
primop args emptyVarSet
= do res <- if isFollowableArg (typeCgRep res_ty)
then newPtrTemp (argMachRep (typeCgRep res_ty))
else newNonPtrTemp (argMachRep (typeCgRep res_ty))
cgPrimOp [res] primop args emptyVarSet
performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
| ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
= do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
cgPrimOp regs primop args emptyVarSet{-no live vars-}
returnUnboxedTuple (zip reps (map CmmReg regs))
returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
| ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...)
= do tag_reg <- newTemp wordRep
= do tag_reg <- if isFollowableArg (typeCgRep res_ty)
then newPtrTemp wordRep
else newNonPtrTemp wordRep
this_pkg <- getThisPackage
cgPrimOp [tag_reg] primop args emptyVarSet
stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg)))
stmtC (CmmAssign nodeReg
(tagToClosure this_pkg tycon
(CmmReg (CmmLocal tag_reg))))
performReturn emitReturnInstr
where
result_info = getPrimOpResultInfo primop
......@@ -438,14 +451,17 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
Little helper for primitives that return unboxed tuples.
\begin{code}
newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [MachHint])
newUnboxedTupleRegs res_ty =
let
ty_args = tyConAppArgs (repType res_ty)
(reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
(reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
let rep = typeCgRep ty,
nonVoidArg rep ]
make_new_temp rep = if isFollowableArg rep
then newPtrTemp (argMachRep rep)
else newNonPtrTemp (argMachRep rep)
in do
regs <- mapM (newTemp . argMachRep) reps
regs <- mapM make_new_temp reps
return (reps,regs,hints)
\end{code}
......@@ -48,7 +48,7 @@ import Control.Monad
-- Code generation for Foreign Calls
cgForeignCall
:: [(CmmReg,MachHint)] -- where to put the results
:: CmmHintFormals -- where to put the results
-> ForeignCall -- the op
-> [StgArg] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -68,7 +68,7 @@ cgForeignCall results fcall stg_args live
emitForeignCall
:: [(CmmReg,MachHint)] -- where to put the results
:: CmmHintFormals -- where to put the results
-> ForeignCall -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -103,7 +103,7 @@ emitForeignCall results (DNCall _) args live
-- alternative entry point, used by CmmParse
emitForeignCall'
:: Safety
-> [(CmmReg,MachHint)] -- where to put the results
-> CmmHintFormals -- where to put the results
-> CmmCallTarget -- the op
-> [(CmmExpr,MachHint)] -- arguments
-> Maybe [GlobalReg] -- live vars, in case we need to save them
......@@ -117,24 +117,27 @@ emitForeignCall' safety results target args vols
stmtsC caller_load
| otherwise = do
id <- newTemp wordRep
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS only objects and are not subject to garbage collection
id <- newNonPtrTemp wordRep
new_base <- newNonPtrTemp (cmmRegRep (CmmGlobal BaseReg))
temp_args <- load_args_into_temps args
temp_target <- load_target_into_temp target
let (caller_save, caller_load) = callerSaveVolatileRegs vols
emitSaveThreadState
stmtsC caller_save
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[(id,PtrHint)]
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
)
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) ]
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
stmtsC caller_load
emitLoadThreadState
......@@ -157,17 +160,18 @@ load_args_into_temps = mapM arg_assign_temp
load_target_into_temp (CmmForeignCall expr conv) = do
tmp <- maybe_assign_temp expr
return (CmmForeignCall tmp conv)
load_target_info_temp other_target =
load_target_into_temp other_target =
return other_target
maybe_assign_temp e
| hasNoGlobalRegs e = return e
| otherwise = do
-- don't use assignTemp, it uses its own notion of "trivial"
-- expressions, which are wrong here
reg <- newTemp (cmmExprRep e)
stmtC (CmmAssign reg e)
return (CmmReg reg)
-- expressions, which are wrong here.
-- this is a NonPtr because it only duplicates an existing
reg <- newNonPtrTemp (cmmExprRep e) --TODO FIXME NOW
stmtC (CmmAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO
......@@ -187,22 +191,22 @@ emitSaveThreadState = do
emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
emitLoadThreadState = do
tso <- newTemp wordRep
tso <- newNonPtrTemp wordRep -- TODO FIXME NOW
stmtsC [
-- tso = CurrentTSO;
CmmAssign tso stgCurrentTSO,
CmmAssign (CmmLocal tso) stgCurrentTSO,
-- Sp = tso->sp;
CmmAssign sp (CmmLoad (cmmOffset (CmmReg tso) tso_SP)
CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
wordRep),
-- SpLim = tso->stack + RESERVED_STACK_WORDS;
CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg tso) tso_STACK)
CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
rESERVED_STACK_WORDS)
]
emitOpenNursery
-- and load the current cost centre stack from the TSO when profiling:
when opt_SccProfilingOn $
stmtC (CmmStore curCCSAddr
(CmmLoad (cmmOffset (CmmReg tso) tso_CCCS) wordRep))
(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) wordRep))
emitOpenNursery = stmtsC [
-- Hp = CurrentNursery->free - 1;
......
......@@ -56,7 +56,7 @@ hpcTable this_mod (NoHpcInfo) = error "TODO: impossible"
initHpc :: Module -> HpcInfo -> Code
initHpc this_mod (HpcInfo tickCount hashNo)
= do { id <- newTemp wordRep
= do { id <- newNonPtrTemp wordRep -- TODO FIXME NOW
; emitForeignCall'
PlayRisky
[(id,NoHint)]
......
......@@ -34,7 +34,7 @@ import Outputable
-- ---------------------------------------------------------------------------
-- Code generation for PrimOps
cgPrimOp :: [CmmReg] -- where to put the results
cgPrimOp :: CmmFormals -- where to put the results
-> PrimOp -- the op
-> [StgArg] -- arguments
-> StgLiveVars -- live vars, in case we need to save them
......@@ -46,7 +46,7 @@ cgPrimOp results op args live
emitPrimOp results op non_void_args live