summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
authorMichael D. Adams <t-madams@microsoft.com>2007-06-27 15:01:33 +0000
committerMichael D. Adams <t-madams@microsoft.com>2007-06-27 15:01:33 +0000
commit207802589da0d23c3f16195f453b24a1e46e322d (patch)
tree2a17423ada08e5a890b17132440dda10c4f860bc /compiler/codeGen
parentbb5c3f58b1da850b68e0745766f2786e538b5fbf (diff)
downloadhaskell-207802589da0d23c3f16195f453b24a1e46e322d.tar.gz
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.
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgBindery.lhs11
-rw-r--r--compiler/codeGen/CgCase.lhs18
-rw-r--r--compiler/codeGen/CgExpr.lhs42
-rw-r--r--compiler/codeGen/CgForeignCall.hs44
-rw-r--r--compiler/codeGen/CgHpc.hs2
-rw-r--r--compiler/codeGen/CgPrimOp.hs46
-rw-r--r--compiler/codeGen/CgProf.hs26
-rw-r--r--compiler/codeGen/CgTicky.hs10
-rw-r--r--compiler/codeGen/CgUtils.hs59
-rw-r--r--compiler/codeGen/SMRep.lhs7
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