diff options
| -rw-r--r-- | compiler/cmm/Cmm.hs | 29 | ||||
| -rw-r--r-- | compiler/cmm/CmmBrokenBlock.hs | 4 | ||||
| -rw-r--r-- | compiler/cmm/CmmCPS.hs | 22 | ||||
| -rw-r--r-- | compiler/cmm/CmmLive.hs | 10 | ||||
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 12 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 45 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 26 | ||||
| -rw-r--r-- | compiler/cmm/PprCmm.hs | 12 | ||||
| -rw-r--r-- | compiler/codeGen/CgBindery.lhs | 11 | ||||
| -rw-r--r-- | compiler/codeGen/CgCase.lhs | 18 | ||||
| -rw-r--r-- | compiler/codeGen/CgExpr.lhs | 42 | ||||
| -rw-r--r-- | compiler/codeGen/CgForeignCall.hs | 44 | ||||
| -rw-r--r-- | compiler/codeGen/CgHpc.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 46 | ||||
| -rw-r--r-- | compiler/codeGen/CgProf.hs | 26 | ||||
| -rw-r--r-- | compiler/codeGen/CgTicky.hs | 10 | ||||
| -rw-r--r-- | compiler/codeGen/CgUtils.hs | 59 | ||||
| -rw-r--r-- | compiler/codeGen/SMRep.lhs | 7 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 2 | ||||
| -rw-r--r-- | 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 986f486cc7..cae1633366 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 49c41bb7bc..1d07631755 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 4d90a4d432..9a9f8a9fb2 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 b379f2db3c..40d7b7c82e 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 aa5a788d5e..aa0c821809 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 6048c44d12..567dd606ad 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 d9bdca5b83..bda191cb5f 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 4ade7a4028..ee8f0f3040 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 d7f2579e76..66ac9bf491 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 abda4dda31..a473e9158e 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 7452de038d..43f69906e6 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 c4af511b84..48015fa45a 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 f70d159739..e457e4c944 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 3993f19197..17ecfa0856 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 bc5473a6e5..3ba9d059fe 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 f5524d2865..8742610026 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 2da6005c42..a4d2338e52 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 c2a2a44e5c..6c57a4ee67 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 f909d24335..585ea8bf9f 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 39e0ac6c42..792bbcecfa 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 |