From 207802589da0d23c3f16195f453b24a1e46e322d Mon Sep 17 00:00:00 2001 From: "Michael D. Adams" Date: Wed, 27 Jun 2007 15:01:33 +0000 Subject: [PATCH] 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. --- compiler/cmm/Cmm.hs | 29 ++++++++++++------ compiler/cmm/CmmBrokenBlock.hs | 4 +-- compiler/cmm/CmmCPS.hs | 22 +++++++------- compiler/cmm/CmmLive.hs | 10 +++---- compiler/cmm/CmmOpt.hs | 12 ++++---- compiler/cmm/CmmParse.y | 45 +++++++++++++++++++++------- compiler/cmm/PprC.hs | 26 ++++++---------- compiler/cmm/PprCmm.hs | 12 +++++--- compiler/codeGen/CgBindery.lhs | 11 ++++--- compiler/codeGen/CgCase.lhs | 18 ++++++----- compiler/codeGen/CgExpr.lhs | 42 ++++++++++++++++++-------- compiler/codeGen/CgForeignCall.hs | 44 ++++++++++++++------------- compiler/codeGen/CgHpc.hs | 2 +- compiler/codeGen/CgPrimOp.hs | 46 ++++++++++++++--------------- compiler/codeGen/CgProf.hs | 26 ++++++++-------- compiler/codeGen/CgTicky.hs | 10 +++---- compiler/codeGen/CgUtils.hs | 59 ++++++++++++++++++++++--------------- compiler/codeGen/SMRep.lhs | 7 +---- compiler/nativeGen/AsmCodeGen.lhs | 2 ++ compiler/nativeGen/MachCodeGen.hs | 26 ++++++++-------- 20 files changed, 257 insertions(+), 196 deletions(-) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 986f486..cae1633 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -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 diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index 49c41bb..1d07631 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -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) diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 4d90a4d..9a9f8a9 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -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)) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index b379f2d..40d7b7c 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -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 diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index aa5a788..aa0c821 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -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 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 6048c44..567dd60 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index d9bdca5..bda191c 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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 diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 4ade7a4..ee8f0f3 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -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 -- diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index d7f2579..66ac9bf 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -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 diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index abda4dd..a473e91 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -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) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 7452de0..43f6990 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -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} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index c4af511..48015fa 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -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; diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index f70d159..e457e4c 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -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)] diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 3993f19..17ecfa0 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -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 -emitPrimOp :: [CmmReg] -- where to put the results +emitPrimOp :: CmmFormals -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -77,12 +77,12 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] live -} = stmtsC [ - CmmAssign res_r (CmmMachOp mo_wordAdd [aa,bb]), - CmmAssign res_c $ + CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign (CmmLocal res_c) $ CmmMachOp mo_wordUShr [ CmmMachOp mo_wordAnd [ CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg res_r] + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] ], CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) ] @@ -100,12 +100,12 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = stmtsC [ - CmmAssign res_r (CmmMachOp mo_wordSub [aa,bb]), - CmmAssign res_c $ + CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign (CmmLocal res_c) $ CmmMachOp mo_wordUShr [ CmmMachOp mo_wordAnd [ CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg res_r] + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] ], CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) ] @@ -126,7 +126,7 @@ emitPrimOp [res] ParOp [arg] live newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark"))) emitPrimOp [res] ReadMutVarOp [mutv] live - = stmtC (CmmAssign res (cmmLoadIndexW mutv fixedHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize)) emitPrimOp [] WriteMutVarOp [mutv,var] live = do @@ -143,7 +143,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live -- r = (((StgArrWords *)(a))->words * sizeof(W_)) emitPrimOp [res] SizeofByteArrayOp [arg] live = stmtC $ - CmmAssign res (CmmMachOp mo_wordMul [ + CmmAssign (CmmLocal res) (CmmMachOp mo_wordMul [ cmmLoadIndexW arg fixedHdrSize, CmmLit (mkIntCLit wORD_SIZE) ]) @@ -160,31 +160,31 @@ emitPrimOp [] TouchOp [arg] live -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] live - = stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) emitPrimOp [res] StableNameToIntOp [arg] live - = stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize)) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp [res] EqStableNameOp [arg1,arg2] live - = stmtC (CmmAssign res (CmmMachOp mo_wordEq [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ cmmLoadIndexW arg1 fixedHdrSize, cmmLoadIndexW arg2 fixedHdrSize ])) emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live - = stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2])) + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) -- #define addrToHValuezh(r,a) r=(P_)a emitPrimOp [res] AddrToHValueOp [arg] live - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) emitPrimOp [res] DataToTagOp [arg] live - = stmtC (CmmAssign res (getConstrTag arg)) + = stmtC (CmmAssign (CmmLocal res) (getConstrTag arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -198,11 +198,11 @@ emitPrimOp [res] DataToTagOp [arg] live -- } emitPrimOp [res] UnsafeFreezeArrayOp [arg] live = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), - CmmAssign res arg ] + CmmAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) -- Reading/writing pointer arrays @@ -328,10 +328,10 @@ emitPrimOp res WriteByteArrayOp_Word64 args live = doWriteByteArrayOp Nothing -- The rest just translate straightforwardly emitPrimOp [res] op [arg] live | nopOp op - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) | Just (mop,rep) <- narrowOp op - = stmtC (CmmAssign res (CmmMachOp (mop rep wordRep) [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mop rep wordRep) [ CmmMachOp (mop wordRep rep) [arg]])) emitPrimOp [res] op args live @@ -344,7 +344,7 @@ emitPrimOp [res] op args live (Just vols) | Just mop <- translateOp op - = let stmt = CmmAssign res (CmmMachOp mop args) in + = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt emitPrimOp _ op _ _ @@ -557,9 +557,9 @@ doWritePtrArrayOp addr idx val mkBasicIndexedRead off Nothing read_rep res base idx - = stmtC (CmmAssign res (cmmLoadIndexOffExpr off read_rep base idx)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) mkBasicIndexedRead off (Just cast) read_rep res base idx - = stmtC (CmmAssign res (CmmMachOp cast [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ cmmLoadIndexOffExpr off read_rep base idx])) mkBasicIndexedWrite off Nothing write_rep base idx val diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index bc5473a..3ba9d05 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -155,9 +155,9 @@ emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's) push_em ccs [] = return ccs push_em ccs (cc:rest) = do - tmp <- newTemp wordRep + tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW pushCostCentre tmp ccs cc - push_em (CmmReg tmp) rest + push_em (CmmReg (CmmLocal tmp)) rest ccsExpr :: CostCentreStack -> CmmExpr ccsExpr ccs @@ -349,14 +349,14 @@ sizeof_ccs_words emitRegisterCC :: CostCentre -> Code emitRegisterCC cc = do - { tmp <- newTemp cIntRep + { tmp <- newNonPtrTemp cIntRep ; stmtsC [ CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) (CmmLoad cC_LIST wordRep), CmmStore cC_LIST cc_lit, - CmmAssign tmp (CmmLoad cC_ID cIntRep), - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp), - CmmStore cC_ID (cmmRegOffB tmp 1) + CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cIntRep), + CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), + CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) ] } where @@ -368,14 +368,14 @@ emitRegisterCC cc = do emitRegisterCCS :: CostCentreStack -> Code emitRegisterCCS ccs = do - { tmp <- newTemp cIntRep + { tmp <- newNonPtrTemp cIntRep ; stmtsC [ CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) (CmmLoad cCS_LIST wordRep), CmmStore cCS_LIST ccs_lit, - CmmAssign tmp (CmmLoad cCS_ID cIntRep), - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp), - CmmStore cCS_ID (cmmRegOffB tmp 1) + CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cIntRep), + CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), + CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) ] } where @@ -395,14 +395,14 @@ emitSetCCC :: CostCentre -> Code emitSetCCC cc | not opt_SccProfilingOn = nopC | otherwise = do - tmp <- newTemp wordRep + tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW ASSERT( sccAbleCostCentre cc ) pushCostCentre tmp curCCS cc - stmtC (CmmStore curCCSAddr (CmmReg tmp)) + stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp))) when (isSccCountCostCentre cc) $ stmtC (bumpSccCount curCCS) -pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code +pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result PtrHint SLIT("PushCostCentre") [(ccs,PtrHint), diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index f5524d2..8742610 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -318,13 +318,13 @@ bumpHistogram lbl n bumpHistogramE :: LitString -> CmmExpr -> Code bumpHistogramE lbl n - = do t <- newTemp cLongRep - stmtC (CmmAssign t n) - emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $ - stmtC (CmmAssign t eight) + = do t <- newNonPtrTemp cLongRep + stmtC (CmmAssign (CmmLocal t) n) + emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg (CmmLocal t), eight]) $ + stmtC (CmmAssign (CmmLocal t) eight) stmtC (addToMemLong (cmmIndexExpr cLongRep (CmmLit (CmmLabel (mkRtsDataLabel lbl))) - (CmmReg t)) + (CmmReg (CmmLocal t))) 1) where eight = CmmLit (CmmInt 8 cLongRep) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2da6005..a4d2338 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -11,7 +11,8 @@ module CgUtils ( cgLit, emitDataLits, emitRODataLits, emitIf, emitIfThenElse, emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - assignTemp, newTemp, + assignNonPtrTemp, newNonPtrTemp, + assignPtrTemp, newPtrTemp, emitSimultaneously, emitSwitch, emitLitSwitch, tagToClosure, @@ -270,14 +271,14 @@ emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code emitRtsCallWithVols fun args vols = emitRtsCall' [] fun args (Just vols) -emitRtsCallWithResult :: CmmReg -> MachHint -> LitString +emitRtsCallWithResult :: LocalReg -> MachHint -> LitString -> [(CmmExpr,MachHint)] -> Code emitRtsCallWithResult res hint fun args = emitRtsCall' [(res,hint)] fun args Nothing -- Make a call to an RTS C procedure emitRtsCall' - :: [(CmmReg,MachHint)] + :: CmmHintFormals -> LitString -> [(CmmExpr,MachHint)] -> Maybe [GlobalReg] @@ -331,18 +332,29 @@ mkByteStringCLit bytes -- ------------------------------------------------------------------------- -assignTemp :: CmmExpr -> FCode CmmExpr +assignNonPtrTemp :: CmmExpr -> FCode CmmExpr -- For a non-trivial expression, e, create a local -- variable and assign the expression to it -assignTemp e +assignNonPtrTemp e | isTrivialCmmExpr e = return e - | otherwise = do { reg <- newTemp (cmmExprRep e) - ; stmtC (CmmAssign reg e) - ; return (CmmReg reg) } + | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e) + ; stmtC (CmmAssign (CmmLocal reg) e) + ; return (CmmReg (CmmLocal reg)) } +assignPtrTemp :: CmmExpr -> FCode CmmExpr +-- For a non-trivial expression, e, create a local +-- variable and assign the expression to it +assignPtrTemp e + | isTrivialCmmExpr e = return e + | otherwise = do { reg <- newPtrTemp (cmmExprRep e) + ; stmtC (CmmAssign (CmmLocal reg) e) + ; return (CmmReg (CmmLocal reg)) } -newTemp :: MachRep -> FCode CmmReg -newTemp rep = do { uniq <- newUnique; return (CmmLocal (LocalReg uniq rep)) } +newNonPtrTemp :: MachRep -> FCode LocalReg +newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) } + +newPtrTemp :: MachRep -> FCode LocalReg +newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) } ------------------------------------------------------------------------- @@ -445,7 +457,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt @@ -454,7 +466,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt @@ -463,7 +475,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | otherwise -- Use an if-tree - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr -- To avoid duplication ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) via_C @@ -528,11 +540,10 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C is_lo (t,_) = t < mid_tag -assignTemp' e +assignNonPtrTemp' e | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do { reg <- newTemp (cmmExprRep e) - ; return (CmmAssign reg e, CmmReg reg) } - + | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e) + ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) } emitLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CgStmts)] -- Tagged branches @@ -547,7 +558,7 @@ emitLitSwitch :: CmmExpr -- Tag to switch on emitLitSwitch scrut [] deflt = emitCgStmts deflt emitLitSwitch scrut branches deflt_blk - = do { scrut' <- assignTemp scrut + = do { scrut' <- assignNonPtrTemp scrut ; deflt_blk_id <- forkCgStmts deflt_blk ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches) ; emitCgStmts blk } @@ -639,13 +650,13 @@ doSimultaneously1 vertices ; stmtC from_temp } go_via_temp (CmmAssign dest src) - = do { tmp <- newTemp (cmmRegRep dest) - ; stmtC (CmmAssign tmp src) - ; return (CmmAssign dest (CmmReg tmp)) } + = do { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + ; stmtC (CmmAssign (CmmLocal tmp) src) + ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprRep src) - ; stmtC (CmmAssign tmp src) - ; return (CmmStore dest (CmmReg tmp)) } + = do { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong + ; stmtC (CmmAssign (CmmLocal tmp) src) + ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } in mapCs do_component components diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs index c2a2a44..6c57a4e 100644 --- a/compiler/codeGen/SMRep.lhs +++ b/compiler/codeGen/SMRep.lhs @@ -19,7 +19,7 @@ module SMRep ( CgRep(..), nonVoidArg, argMachRep, primRepToCgRep, primRepHint, isFollowableArg, isVoidArg, - isFloatingArg, isNonPtrArg, is64BitArg, + isFloatingArg, is64BitArg, separateByPtrFollowness, cgRepSizeW, cgRepSizeB, retAddrSizeW, @@ -200,11 +200,6 @@ isFloatingArg DoubleArg = True isFloatingArg FloatArg = True isFloatingArg _ = False -isNonPtrArg :: CgRep -> Bool --- Identify anything which is one word large and not a pointer. -isNonPtrArg NonPtrArg = True -isNonPtrArg other = False - is64BitArg :: CgRep -> Bool is64BitArg LongArg = True is64BitArg _ = False diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index f909d24..585ea8b 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -444,6 +444,7 @@ fixAssign (CmmAssign (CmmGlobal reg) src) where reg_or_addr = get_GlobalReg_reg_or_addr reg +{- fixAssign (CmmCall target results args) = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) -> returnUs (CmmCall target results' args : @@ -459,6 +460,7 @@ fixAssign (CmmCall target results args) [CmmStore baseRegAddr (CmmReg local)]) fixResult other = returnUs (other,[]) +-} fixAssign other_stmt = returnUs [other_stmt] diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index 39e0ac6..792bbce 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -188,7 +188,7 @@ assignMem_I64Code addrTree valueTree = do return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst pk _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let r_dst_lo = mkVReg u_dst I32 @@ -230,7 +230,7 @@ iselExpr64 (CmmLoad addrTree I64) = do rlo ) -iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) +iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _))) = return (ChildCode64 nilOL (mkVReg vu I32)) -- we handle addition, but rather badly @@ -399,7 +399,7 @@ iselExpr64 (CmmLoad addrTree I64) = do return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo -iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64))) +iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64 _))) = return (ChildCode64 nilOL (mkVReg vu I32)) iselExpr64 (CmmLit (CmmInt i _)) = do @@ -476,7 +476,7 @@ getSomeReg expr = do getRegisterReg :: CmmReg -> Reg -getRegisterReg (CmmLocal (LocalReg u pk)) +getRegisterReg (CmmLocal (LocalReg u pk _)) = mkVReg u pk getRegisterReg (CmmGlobal mid) @@ -2938,8 +2938,8 @@ genCondJump id bool = do genCCall :: CmmCallTarget -- function to call - -> [(CmmReg,MachHint)] -- where to put the result - -> [(CmmExpr,MachHint)] -- arguments (of mixed type) + -> CmmHintFormals -- where to put the result + -> CmmActuals -- arguments (of mixed type) -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3042,7 +3042,7 @@ genCCall (CmmPrim op) [(r,_)] args = do actuallyInlineFloatOp rep instr [(x,_)] = do res <- trivialUFCode rep instr x any <- anyReg res - return (any (getRegisterReg r)) + return (any (getRegisterReg (CmmLocal r))) genCCall target dest_regs args = do let @@ -3107,8 +3107,8 @@ genCCall target dest_regs args = do rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest)) where r_dest_hi = getHiVRegFromLo r_dest - rep = cmmRegRep dest - r_dest = getRegisterReg dest + rep = localRegRep dest + r_dest = getRegisterReg (CmmLocal dest) assign_code many = panic "genCCall.assign_code many" return (push_code `appOL` @@ -3172,23 +3172,23 @@ genCCall target dest_regs args = do #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)] +outOfLineFloatOp :: CallishMachOp -> CmmFormal -> CmmActuals -> NatM InstrBlock outOfLineFloatOp mop res args = do targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl let target = CmmForeignCall targetExpr CCallConv - if cmmRegRep res == F64 + if localRegRep res == F64 then stmtToInstrs (CmmCall target [(res,FloatHint)] args) else do uq <- getUniqueNat let - tmp = CmmLocal (LocalReg uq F64) + tmp = LocalReg uq F64 KindNonPtr -- in code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args) - code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp)) + code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where lbl = mkForeignLabel fn Nothing False -- 1.7.10.4