diff options
Diffstat (limited to 'compiler/codeGen')
| -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 |
10 files changed, 148 insertions, 117 deletions
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 |