summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2012-09-12 16:32:34 +0100
committerIan Lynagh <ian@well-typed.com>2012-09-12 16:32:34 +0100
commit2b7319a67de0771d31626091e43dd3b60827a0ea (patch)
treecb1542cb4e9e7e6826e06f2fb94fd590dca2f834 /compiler/codeGen
parent44b5f471a314d964948c38684ce74b7a87df4ed8 (diff)
downloadhaskell-2b7319a67de0771d31626091e43dd3b60827a0ea.tar.gz
Pass DynFlags down to wordWidth
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/CgClosure.lhs11
-rw-r--r--compiler/codeGen/CgCon.lhs2
-rw-r--r--compiler/codeGen/CgForeignCall.hs10
-rw-r--r--compiler/codeGen/CgHeapery.lhs67
-rw-r--r--compiler/codeGen/CgInfoTbls.hs10
-rw-r--r--compiler/codeGen/CgPrimOp.hs496
-rw-r--r--compiler/codeGen/CgProf.hs60
-rw-r--r--compiler/codeGen/CgTailCall.lhs6
-rw-r--r--compiler/codeGen/CgTicky.hs18
-rw-r--r--compiler/codeGen/CgUtils.hs70
-rw-r--r--compiler/codeGen/StgCmmBind.hs8
-rw-r--r--compiler/codeGen/StgCmmExpr.hs6
-rw-r--r--compiler/codeGen/StgCmmForeign.hs8
-rw-r--r--compiler/codeGen/StgCmmHeap.hs79
-rw-r--r--compiler/codeGen/StgCmmLayout.hs4
-rw-r--r--compiler/codeGen/StgCmmMonad.hs18
-rw-r--r--compiler/codeGen/StgCmmPrim.hs502
-rw-r--r--compiler/codeGen/StgCmmProf.hs82
-rw-r--r--compiler/codeGen/StgCmmTicky.hs18
-rw-r--r--compiler/codeGen/StgCmmUtils.hs58
20 files changed, 779 insertions, 754 deletions
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index f8062cfbf5..fce910489e 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -320,10 +320,11 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
-- Do the business
; funWrapper cl_info reg_args reg_save_code $ do
- { tickyEnterFun cl_info
+ { dflags <- getDynFlags
+ ; tickyEnterFun cl_info
; enterCostCentreFun cc
- (CmmMachOp mo_wordSub [ CmmReg nodeReg
- , mkIntExpr (funTag cl_info) ])
+ (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg
+ , mkIntExpr dflags (funTag cl_info) ])
(node : map snd reg_args) -- live regs
; cgExpr body }
@@ -429,7 +430,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do
; whenC (tag /= 0 && node_points) $ do
l <- newLabelC
stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
- mkIntExpr tag)]) l)
+ mkIntExpr dflags tag)]) l)
stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0))
labelC l
-}
@@ -598,7 +599,7 @@ link_caf cl_info _is_upd = do
-- node is live, so save it.
-- see Note [atomic CAF entry] in rts/sm/Storage.c
- ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), zeroExpr]) $
+ ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $
-- re-enter R1. Doing this directly is slightly dodgy; we're
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 146f28461f..57fd10d4e4 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -355,7 +355,7 @@ cgReturnDataCon con amodes = do
where
node_live = Just [node]
enter_it dflags
- = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
+ = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)),
CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg)
node_live
]
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 213745d59d..b835e784e1 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -152,7 +152,7 @@ emitForeignCall' safety results target args vols _srt ret
stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
- , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
+ , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint]
ret)
stmtC (CmmCall temp_target results temp_args ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv)
@@ -243,7 +243,7 @@ emitLoadThreadState = do
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
- CmmAssign hpAlloc (CmmLit zeroCLit)
+ CmmAssign hpAlloc (CmmLit (zeroCLit dflags))
]
emitOpenNursery
-- and load the current cost centre stack from the TSO when profiling:
@@ -264,10 +264,10 @@ emitOpenNursery =
(cmmOffsetExpr dflags
(CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
(cmmOffset dflags
- (CmmMachOp mo_wordMul [
- CmmMachOp (MO_SS_Conv W32 wordWidth)
+ (CmmMachOp (mo_wordMul dflags) [
+ CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
[CmmLoad (nursery_bdescr_blocks dflags) b32],
- mkIntExpr bLOCK_SIZE
+ mkIntExpr dflags bLOCK_SIZE
])
(-1)
)
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index daca30c25a..e37783cf11 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -208,22 +208,22 @@ mkStaticClosureFields dflags cl_info ccs caf_refs payload
padding_wds
| not is_caf = []
- | otherwise = ASSERT(null payload) [mkIntCLit 0]
+ | otherwise = ASSERT(null payload) [mkIntCLit dflags 0]
static_link_field
| is_caf || staticClosureNeedsLink cl_info = [static_link_value]
| otherwise = []
saved_info_field
- | is_caf = [mkIntCLit 0]
+ | is_caf = [mkIntCLit dflags 0]
| otherwise = []
-- for a static constructor which has NoCafRefs, we set the
-- static link field to a non-zero value so the garbage
-- collector will ignore it.
static_link_value
- | caf_refs = mkIntCLit 0
- | otherwise = mkIntCLit 1
+ | caf_refs = mkIntCLit dflags 0
+ | otherwise = mkIntCLit dflags 1
mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
-> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
@@ -412,18 +412,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
| ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
| otherwise
= initHeapUsage $ \ hpHw -> do
- { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+ { dflags <- getDynFlags
+ ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
+ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
+ (CmmLit (mkWordCLit dflags liveness))
+ liveness = mkRegLiveness regs ptrs nptrs
+ live = Just $ map snd regs
+ rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
+ ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw
full_fail_code rts_label live
; tickyAllocHeap hpHw }
; setRealHp hpHw
; code }
- where
- full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
- assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho!
- (CmmLit (mkWordCLit liveness))
- liveness = mkRegLiveness regs ptrs nptrs
- live = Just $ map snd regs
- rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
\end{code}
@@ -462,15 +462,27 @@ do_checks _ hp _ _ _
"structures in the code."])
do_checks stk hp reg_save_code rts_lbl live
- = do_checks' (mkIntExpr (stk*wORD_SIZE))
- (mkIntExpr (hp*wORD_SIZE))
- (stk /= 0) (hp /= 0) reg_save_code rts_lbl live
+ = do dflags <- getDynFlags
+ do_checks' (mkIntExpr dflags (stk*wORD_SIZE))
+ (mkIntExpr dflags (hp*wORD_SIZE))
+ (stk /= 0) (hp /= 0) reg_save_code rts_lbl live
-- The offsets are now in *bytes*
do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr
-> Maybe [GlobalReg] -> Code
do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
= do { dflags <- getDynFlags
+
+ -- Stk overflow if (Sp - stk_bytes < SpLim)
+ ; let stk_oflo = CmmMachOp (mo_wordULt dflags)
+ [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr],
+ CmmReg (CmmGlobal SpLim)]
+
+ -- Hp overflow if (Hp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp (mo_wordUGt dflags)
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
; doGranAllocate hp_expr
@@ -506,17 +518,6 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
-- with slop at the end of the current block, which can
-- confuse the LDV profiler.
}
- where
- -- Stk overflow if (Sp - stk_bytes < SpLim)
- stk_oflo = CmmMachOp mo_wordULt
- [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr],
- CmmReg (CmmGlobal SpLim)]
-
- -- Hp overflow if (Hp > HpLim)
- -- (Hp has been incremented by now)
- -- HpLim points to the LAST WORD of valid allocation space.
- hp_oflo = CmmMachOp mo_wordUGt
- [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
\end{code}
%************************************************************************
@@ -532,15 +533,16 @@ hpChkGen bytes liveness reentry
let platform = targetPlatform dflags
assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness,
mk_vanilla_assignment dflags 10 reentry ]
- do_checks' zeroExpr bytes False True assigns
+ do_checks' (zeroExpr dflags) bytes False True assigns
stg_gc_gen (Just (activeStgRegs platform))
-- a heap check where R1 points to the closure to enter on return, and
-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
hpChkNodePointsAssignSp0 bytes sp0
- = do_checks' zeroExpr bytes False True assign
- stg_gc_enter1 (Just [node])
+ = do dflags <- getDynFlags
+ do_checks' (zeroExpr dflags) bytes False True assign
+ stg_gc_enter1 (Just [node])
where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
@@ -549,7 +551,7 @@ stkChkGen bytes liveness reentry
let platform = targetPlatform dflags
assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness,
mk_vanilla_assignment dflags 10 reentry ]
- do_checks' bytes zeroExpr True False assigns
+ do_checks' bytes (zeroExpr dflags) True False assigns
stg_gc_gen (Just (activeStgRegs platform))
mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt
@@ -558,8 +560,9 @@ mk_vanilla_assignment dflags n e
stkChkNodePoints :: CmmExpr -> Code
stkChkNodePoints bytes
- = do_checks' bytes zeroExpr True False noStmts
- stg_gc_enter1 (Just [node])
+ = do dflags <- getDynFlags
+ do_checks' bytes (zeroExpr dflags) True False noStmts
+ stg_gc_enter1 (Just [node])
stg_gc_gen :: CmmExpr
stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 68cbe0f0da..18e3532db9 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -214,15 +214,15 @@ emitAlgReturnTarget
-> FCode (CLabel, SemiTaggingStuff)
emitAlgReturnTarget name branches mb_deflt fam_sz
- = do { blks <- getCgStmts $
+ = do { blks <- getCgStmts $ do
-- is the constructor tag in the node reg?
+ dflags <- getDynFlags
if isSmallFamily fam_sz
then do -- yes, node has constr. tag
- let tag_expr = cmmConstrTag1 (CmmReg nodeReg)
+ let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg)
branches' = [(tag+1,branch)|(tag,branch)<-branches]
emitSwitch tag_expr branches' mb_deflt 1 fam_sz
else do -- no, get tag from info table
- dflags <- getDynFlags
let -- Note that ptr _always_ has tag 1
-- when the family size is big enough
untagged_ptr = cmmRegOffB nodeReg (-1)
@@ -296,7 +296,7 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableConstrTag dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
@@ -304,7 +304,7 @@ cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableClosureType dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index aaa97a2132..1accdbe213 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -62,7 +62,7 @@ emitPrimOp :: DynFlags
-- First we handle various awkward cases specially. The remaining
-- easy cases are then handled by translateOp, defined below.
-emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] _
+emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _
{-
With some bit-twiddling, we can define int{Add,Sub}Czh portably in
C, and without needing any comparisons. This may not be the
@@ -84,19 +84,19 @@ emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] _
-}
= stmtsC [
- CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
+ CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [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 (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr dflags) [
+ CmmMachOp (mo_wordAnd dflags) [
+ CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
+ CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr (wORD_SIZE_IN_BITS - 1)
+ mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
]
]
-emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] _
+emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _
{- Similarly:
#define subIntCzh(r,c,a,b) \
{ r = ((I_)(a)) - ((I_)(b)); \
@@ -107,14 +107,14 @@ emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] _
c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
-}
= stmtsC [
- CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
+ CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
CmmAssign (CmmLocal res_c) $
- CmmMachOp mo_wordUShr [
- CmmMachOp mo_wordAnd [
- CmmMachOp mo_wordXor [aa,bb],
- CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr dflags) [
+ CmmMachOp (mo_wordAnd dflags) [
+ CmmMachOp (mo_wordXor dflags) [aa,bb],
+ CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr (wORD_SIZE_IN_BITS - 1)
+ mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
]
]
@@ -160,8 +160,8 @@ emitPrimOp dflags [res] GetCCSOfOp [arg] _live
= stmtC (CmmAssign (CmmLocal res) val)
where
val
- | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg)
- | otherwise = CmmLit zeroCLit
+ | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
+ | otherwise = CmmLit (zeroCLit dflags)
emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live
= stmtC (CmmAssign (CmmLocal res) curCCS)
@@ -210,14 +210,14 @@ emitPrimOp dflags [res] StableNameToIntOp [arg] _
-- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _
- = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [
+ = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
]))
-emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
- = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
+emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
+ = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]))
-- #define addrToHValuezh(r,a) r=(P_)a
emitPrimOp _ [res] AddrToAnyOp [arg] _
@@ -226,7 +226,7 @@ emitPrimOp _ [res] AddrToAnyOp [arg] _
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- Note: argument may be tagged!
emitPrimOp dflags [res] DataToTagOp [arg] _
- = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)))
+ = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)))
{- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
@@ -296,116 +296,116 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live
-- IndexXXXoffAddr
-emitPrimOp _ res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _ res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp _ res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args
-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
-emitPrimOp _ res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _ res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp _ res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args
-- IndexXXXArray
-emitPrimOp _ res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _ res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args
-emitPrimOp _ res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args
-- ReadXXXArray, identical to IndexXXXArray.
-emitPrimOp _ res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _ res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args
-emitPrimOp _ res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args
-- WriteXXXoffAddr
-emitPrimOp _ res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args
emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args
emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _ res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args
-emitPrimOp _ res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args
-emitPrimOp _ res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args
-emitPrimOp _ res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args
-- WriteXXXArray
-emitPrimOp _ res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args
emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args
emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _ res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args
-emitPrimOp _ res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args
-emitPrimOp _ res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args
-emitPrimOp _ res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args
-emitPrimOp _ res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args
-- Copying and setting byte arrays
@@ -422,27 +422,27 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live =
-- to the correct width before calling the primop. Otherwise this can result
-- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the
-- argument is <=0xff.
-emitPrimOp _ [res] PopCnt8Op [w] live =
- emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 live
-emitPrimOp _ [res] PopCnt16Op [w] live =
- emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 live
-emitPrimOp _ [res] PopCnt32Op [w] live =
- emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 live
-emitPrimOp _ [res] PopCnt64Op [w] live =
- emitPopCntCall res (CmmMachOp mo_WordTo64 [w]) W64 live
-emitPrimOp _ [res] PopCntOp [w] live =
- emitPopCntCall res w wordWidth live
+emitPrimOp dflags [res] PopCnt8Op [w] live =
+ emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live
+emitPrimOp dflags [res] PopCnt16Op [w] live =
+ emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live
+emitPrimOp dflags [res] PopCnt32Op [w] live =
+ emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live
+emitPrimOp dflags [res] PopCnt64Op [w] live =
+ emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live
+emitPrimOp dflags [res] PopCntOp [w] live =
+ emitPopCntCall res w (wordWidth dflags) live
-- The rest just translate straightforwardly
-emitPrimOp _ [res] op [arg] _
+emitPrimOp dflags [res] op [arg] _
| nopOp op
= stmtC (CmmAssign (CmmLocal res) arg)
| Just (mop,rep) <- narrowOp op
= stmtC (CmmAssign (CmmLocal res) $
- CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
+ CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]])
-emitPrimOp _ [res] op args live
+emitPrimOp dflags [res] op args live
| Just prim <- callishOp op
= do vols <- getVolatileRegs live
emitForeignCall' PlayRisky
@@ -453,30 +453,30 @@ emitPrimOp _ [res] op args live
NoC_SRT -- No SRT b/c we do PlayRisky
CmmMayReturn
- | Just mop <- translateOp op
+ | Just mop <- translateOp dflags op
= let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
stmtC stmt
-emitPrimOp _ [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
+emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
= let genericImpl
= [CmmAssign (CmmLocal res_q)
- (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]),
+ (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]),
CmmAssign (CmmLocal res_r)
- (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])]
- stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl))
+ (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])]
+ stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
[CmmHinted arg_x NoHint,
CmmHinted arg_y NoHint]
CmmMayReturn
in stmtC stmt
-emitPrimOp _ [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
+emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
= let genericImpl
= [CmmAssign (CmmLocal res_q)
- (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]),
+ (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]),
CmmAssign (CmmLocal res_r)
- (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])]
- stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl))
+ (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])]
+ stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
[CmmHinted arg_x NoHint,
@@ -485,17 +485,17 @@ emitPrimOp _ [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
in stmtC stmt
emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
= do let ty = cmmExprType dflags arg_x_high
- shl x i = CmmMachOp (MO_Shl wordWidth) [x, i]
- shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
- ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y]
- ne x y = CmmMachOp (MO_Ne wordWidth) [x, y]
- minus x y = CmmMachOp (MO_Sub wordWidth) [x, y]
- times x y = CmmMachOp (MO_Mul wordWidth) [x, y]
+ shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i]
+ shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+ ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y]
+ ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y]
+ minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y]
+ times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
zero = lit 0
one = lit 1
- negone = lit (fromIntegral (widthInBits wordWidth) - 1)
- lit i = CmmLit (CmmInt i wordWidth)
+ negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
+ lit i = CmmLit (CmmInt i (wordWidth dflags))
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt]
f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc,
CmmAssign (CmmLocal res_r) high]
@@ -526,8 +526,8 @@ emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
(CmmReg (CmmLocal rhigh''))
(CmmReg (CmmLocal rlow'))
return (this ++ rest)
- genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low
- let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl))
+ genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
+ let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
[CmmHinted arg_x_high NoHint,
@@ -552,15 +552,15 @@ emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
CmmAssign (CmmLocal res_l)
(or (toTopHalf (CmmReg (CmmLocal r2)))
(bottomHalf (CmmReg (CmmLocal r1))))]
- where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
- bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
- add x y = CmmMachOp (MO_Add wordWidth) [x, y]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+ where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- wordWidth)
- hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth)
- stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl))
+ (wordWidth dflags))
+ hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+ stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl))
[CmmHinted res_h NoHint,
CmmHinted res_l NoHint]
[CmmHinted arg_x NoHint,
@@ -594,17 +594,17 @@ emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _
topHalf (CmmReg xhyl),
topHalf (CmmReg xlyh),
topHalf (CmmReg r)])]
- where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
- bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
- add x y = CmmMachOp (MO_Add wordWidth) [x, y]
+ where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
sum = foldl1 add
- mul x y = CmmMachOp (MO_Mul wordWidth) [x, y]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+ mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- wordWidth)
- hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth)
- stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl))
+ (wordWidth dflags))
+ hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+ stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl))
[CmmHinted res_h NoHint,
CmmHinted res_l NoHint]
[CmmHinted arg_x NoHint,
@@ -643,125 +643,125 @@ narrowOp _ = Nothing
-- Native word signless ops
-translateOp :: PrimOp -> Maybe MachOp
-translateOp IntAddOp = Just mo_wordAdd
-translateOp IntSubOp = Just mo_wordSub
-translateOp WordAddOp = Just mo_wordAdd
-translateOp WordSubOp = Just mo_wordSub
-translateOp AddrAddOp = Just mo_wordAdd
-translateOp AddrSubOp = Just mo_wordSub
-
-translateOp IntEqOp = Just mo_wordEq
-translateOp IntNeOp = Just mo_wordNe
-translateOp WordEqOp = Just mo_wordEq
-translateOp WordNeOp = Just mo_wordNe
-translateOp AddrEqOp = Just mo_wordEq
-translateOp AddrNeOp = Just mo_wordNe
-
-translateOp AndOp = Just mo_wordAnd
-translateOp OrOp = Just mo_wordOr
-translateOp XorOp = Just mo_wordXor
-translateOp NotOp = Just mo_wordNot
-translateOp SllOp = Just mo_wordShl
-translateOp SrlOp = Just mo_wordUShr
-
-translateOp AddrRemOp = Just mo_wordURem
+translateOp :: DynFlags -> PrimOp -> Maybe MachOp
+translateOp dflags IntAddOp = Just (mo_wordAdd dflags)
+translateOp dflags IntSubOp = Just (mo_wordSub dflags)
+translateOp dflags WordAddOp = Just (mo_wordAdd dflags)
+translateOp dflags WordSubOp = Just (mo_wordSub dflags)
+translateOp dflags AddrAddOp = Just (mo_wordAdd dflags)
+translateOp dflags AddrSubOp = Just (mo_wordSub dflags)
+
+translateOp dflags IntEqOp = Just (mo_wordEq dflags)
+translateOp dflags IntNeOp = Just (mo_wordNe dflags)
+translateOp dflags WordEqOp = Just (mo_wordEq dflags)
+translateOp dflags WordNeOp = Just (mo_wordNe dflags)
+translateOp dflags AddrEqOp = Just (mo_wordEq dflags)
+translateOp dflags AddrNeOp = Just (mo_wordNe dflags)
+
+translateOp dflags AndOp = Just (mo_wordAnd dflags)
+translateOp dflags OrOp = Just (mo_wordOr dflags)
+translateOp dflags XorOp = Just (mo_wordXor dflags)
+translateOp dflags NotOp = Just (mo_wordNot dflags)
+translateOp dflags SllOp = Just (mo_wordShl dflags)
+translateOp dflags SrlOp = Just (mo_wordUShr dflags)
+
+translateOp dflags AddrRemOp = Just (mo_wordURem dflags)
-- Native word signed ops
-translateOp IntMulOp = Just mo_wordMul
-translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
-translateOp IntQuotOp = Just mo_wordSQuot
-translateOp IntRemOp = Just mo_wordSRem
-translateOp IntNegOp = Just mo_wordSNeg
+translateOp dflags IntMulOp = Just (mo_wordMul dflags)
+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
+translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags)
+translateOp dflags IntRemOp = Just (mo_wordSRem dflags)
+translateOp dflags IntNegOp = Just (mo_wordSNeg dflags)
-translateOp IntGeOp = Just mo_wordSGe
-translateOp IntLeOp = Just mo_wordSLe
-translateOp IntGtOp = Just mo_wordSGt
-translateOp IntLtOp = Just mo_wordSLt
+translateOp dflags IntGeOp = Just (mo_wordSGe dflags)
+translateOp dflags IntLeOp = Just (mo_wordSLe dflags)
+translateOp dflags IntGtOp = Just (mo_wordSGt dflags)
+translateOp dflags IntLtOp = Just (mo_wordSLt dflags)
-translateOp ISllOp = Just mo_wordShl
-translateOp ISraOp = Just mo_wordSShr
-translateOp ISrlOp = Just mo_wordUShr
+translateOp dflags ISllOp = Just (mo_wordShl dflags)
+translateOp dflags ISraOp = Just (mo_wordSShr dflags)
+translateOp dflags ISrlOp = Just (mo_wordUShr dflags)
-- Native word unsigned ops
-translateOp WordGeOp = Just mo_wordUGe
-translateOp WordLeOp = Just mo_wordULe
-translateOp WordGtOp = Just mo_wordUGt
-translateOp WordLtOp = Just mo_wordULt
+translateOp dflags WordGeOp = Just (mo_wordUGe dflags)
+translateOp dflags WordLeOp = Just (mo_wordULe dflags)
+translateOp dflags WordGtOp = Just (mo_wordUGt dflags)
+translateOp dflags WordLtOp = Just (mo_wordULt dflags)
-translateOp WordMulOp = Just mo_wordMul
-translateOp WordQuotOp = Just mo_wordUQuot
-translateOp WordRemOp = Just mo_wordURem
+translateOp dflags WordMulOp = Just (mo_wordMul dflags)
+translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags)
+translateOp dflags WordRemOp = Just (mo_wordURem dflags)
-translateOp AddrGeOp = Just mo_wordUGe
-translateOp AddrLeOp = Just mo_wordULe
-translateOp AddrGtOp = Just mo_wordUGt
-translateOp AddrLtOp = Just mo_wordULt
+translateOp dflags AddrGeOp = Just (mo_wordUGe dflags)
+translateOp dflags AddrLeOp = Just (mo_wordULe dflags)
+translateOp dflags AddrGtOp = Just (mo_wordUGt dflags)
+translateOp dflags AddrLtOp = Just (mo_wordULt dflags)
-- Char# ops
-translateOp CharEqOp = Just (MO_Eq wordWidth)
-translateOp CharNeOp = Just (MO_Ne wordWidth)
-translateOp CharGeOp = Just (MO_U_Ge wordWidth)
-translateOp CharLeOp = Just (MO_U_Le wordWidth)
-translateOp CharGtOp = Just (MO_U_Gt wordWidth)
-translateOp CharLtOp = Just (MO_U_Lt wordWidth)
+translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags))
+translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags))
+translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags))
+translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags))
+translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags))
+translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags))
-- Double ops
-translateOp DoubleEqOp = Just (MO_F_Eq W64)
-translateOp DoubleNeOp = Just (MO_F_Ne W64)
-translateOp DoubleGeOp = Just (MO_F_Ge W64)
-translateOp DoubleLeOp = Just (MO_F_Le W64)
-translateOp DoubleGtOp = Just (MO_F_Gt W64)
-translateOp DoubleLtOp = Just (MO_F_Lt W64)
+translateOp _ DoubleEqOp = Just (MO_F_Eq W64)
+translateOp _ DoubleNeOp = Just (MO_F_Ne W64)
+translateOp _ DoubleGeOp = Just (MO_F_Ge W64)
+translateOp _ DoubleLeOp = Just (MO_F_Le W64)
+translateOp _ DoubleGtOp = Just (MO_F_Gt W64)
+translateOp _ DoubleLtOp = Just (MO_F_Lt W64)
-translateOp DoubleAddOp = Just (MO_F_Add W64)
-translateOp DoubleSubOp = Just (MO_F_Sub W64)
-translateOp DoubleMulOp = Just (MO_F_Mul W64)
-translateOp DoubleDivOp = Just (MO_F_Quot W64)
-translateOp DoubleNegOp = Just (MO_F_Neg W64)
+translateOp _ DoubleAddOp = Just (MO_F_Add W64)
+translateOp _ DoubleSubOp = Just (MO_F_Sub W64)
+translateOp _ DoubleMulOp = Just (MO_F_Mul W64)
+translateOp _ DoubleDivOp = Just (MO_F_Quot W64)
+translateOp _ DoubleNegOp = Just (MO_F_Neg W64)
-- Float ops
-translateOp FloatEqOp = Just (MO_F_Eq W32)
-translateOp FloatNeOp = Just (MO_F_Ne W32)
-translateOp FloatGeOp = Just (MO_F_Ge W32)
-translateOp FloatLeOp = Just (MO_F_Le W32)
-translateOp FloatGtOp = Just (MO_F_Gt W32)
-translateOp FloatLtOp = Just (MO_F_Lt W32)
+translateOp _ FloatEqOp = Just (MO_F_Eq W32)
+translateOp _ FloatNeOp = Just (MO_F_Ne W32)
+translateOp _ FloatGeOp = Just (MO_F_Ge W32)
+translateOp _ FloatLeOp = Just (MO_F_Le W32)
+translateOp _ FloatGtOp = Just (MO_F_Gt W32)
+translateOp _ FloatLtOp = Just (MO_F_Lt W32)
-translateOp FloatAddOp = Just (MO_F_Add W32)
-translateOp FloatSubOp = Just (MO_F_Sub W32)
-translateOp FloatMulOp = Just (MO_F_Mul W32)
-translateOp FloatDivOp = Just (MO_F_Quot W32)
-translateOp FloatNegOp = Just (MO_F_Neg W32)
+translateOp _ FloatAddOp = Just (MO_F_Add W32)
+translateOp _ FloatSubOp = Just (MO_F_Sub W32)
+translateOp _ FloatMulOp = Just (MO_F_Mul W32)
+translateOp _ FloatDivOp = Just (MO_F_Quot W32)
+translateOp _ FloatNegOp = Just (MO_F_Neg W32)
-- Conversions
-translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64)
-translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth)
+translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64)
+translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags))
-translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32)
-translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth)
+translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32)
+translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags))
-translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
-translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
+translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64)
+translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32)
-- Word comparisons masquerading as more exotic things.
-translateOp SameMutVarOp = Just mo_wordEq
-translateOp SameMVarOp = Just mo_wordEq
-translateOp SameMutableArrayOp = Just mo_wordEq
-translateOp SameMutableByteArrayOp = Just mo_wordEq
-translateOp SameMutableArrayArrayOp= Just mo_wordEq
-translateOp SameTVarOp = Just mo_wordEq
-translateOp EqStablePtrOp = Just mo_wordEq
+translateOp dflags SameMutVarOp = Just (mo_wordEq dflags)
+translateOp dflags SameMVarOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameTVarOp = Just (mo_wordEq dflags)
+translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags)
-translateOp _ = Nothing
+translateOp _ _ = Nothing
-- These primops are implemented by CallishMachOps, because they sometimes
-- turn into foreign calls depending on the backend.
@@ -846,7 +846,7 @@ doWritePtrArrayOp addr idx val
cmmOffsetExpr dflags
(cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
(loadArrPtrsSize dflags addr))
- (card idx)
+ (card dflags idx)
) (CmmLit (CmmInt 1 W8))
loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
@@ -900,7 +900,8 @@ doCopyByteArrayOp = emitCopyByteArray copy
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst dst_p src_p bytes live =
- emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live
+ do dflags <- getDynFlags
+ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live
-- | Takes a source 'MutableByteArray#', an offset in the source
-- array, a destination 'MutableByteArray#', an offset into the
@@ -915,9 +916,10 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes live =
- emitIfThenElse (cmmEqWord src dst)
- (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live)
- (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live)
+ do dflags <- getDynFlags
+ emitIfThenElse (cmmEqWord dflags src dst)
+ (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
+ (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code)
@@ -941,7 +943,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
doSetByteArrayOp ba off len c live
= do dflags <- getDynFlags
p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
- emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live
+ emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live
-- ----------------------------------------------------------------------------
-- Copying pointer arrays
@@ -964,7 +966,8 @@ doCopyArrayOp = emitCopyArray copy
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst dst_p src_p bytes live =
- emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live
+ do dflags <- getDynFlags
+ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live
-- | Takes a source 'MutableArray#', an offset in the source array, a
-- destination 'MutableArray#', an offset into the destination array,
@@ -978,9 +981,10 @@ doCopyMutableArrayOp = emitCopyArray copy
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes live =
- emitIfThenElse (cmmEqWord src dst)
- (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live)
- (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live)
+ do dflags <- getDynFlags
+ emitIfThenElse (cmmEqWord dflags src dst)
+ (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live)
+ (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live)
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code)
@@ -1003,7 +1007,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off
src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
- bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
+ bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags wORD_SIZE))
copy src dst dst_p src_p bytes live
@@ -1020,20 +1024,24 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
-> StgLiveVars -> Code
emitCloneArray info_p res_r src0 src_off0 n0 live = do
dflags <- getDynFlags
+ let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags +
+ (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+ myCapability = cmmSubWord dflags (CmmReg baseReg)
+ (CmmLit (mkIntCLit dflags oFFSET_Capability_r))
-- Assign the arguments to temporaries so the code generator can
-- calculate liveness for us.
src <- assignTemp_ src0
src_off <- assignTemp_ src_off0
n <- assignTemp_ n0
- card_bytes <- assignTemp $ cardRoundUp n
- size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
- words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size
+ card_bytes <- assignTemp $ cardRoundUp dflags n
+ size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes)
+ words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size
arr_r <- newTemp (bWord dflags)
emitAllocateCall arr_r myCapability words live
- tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize)
- (CmmLit $ mkIntCLit 0)
+ tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags))
+ (CmmLit $ mkIntCLit dflags 0)
let arr = CmmReg (CmmLocal arr_r)
emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
@@ -1046,47 +1054,45 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags))
src_off
- emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize)
- (CmmLit (mkIntCLit wORD_SIZE)) live
+ emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags))
+ (CmmLit (mkIntCLit dflags wORD_SIZE)) live
emitMemsetCall (cmmOffsetExprW dflags dst_p n)
- (CmmLit (mkIntCLit 1))
+ (CmmLit (mkIntCLit dflags 1))
card_bytes
- (CmmLit (mkIntCLit wORD_SIZE))
+ (CmmLit (mkIntCLit dflags wORD_SIZE))
live
stmtC $ CmmAssign (CmmLocal res_r) arr
- where
- arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags +
- (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
- myCapability = CmmReg baseReg `cmmSubWord`
- CmmLit (mkIntCLit oFFSET_Capability_r)
-- | Takes and offset in the destination array, the base address of
-- the card table, and the number of elements affected (*not* the
-- number of cards). Marks the relevant cards as dirty.
emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
emitSetCards dst_start dst_cards_start n live = do
- start_card <- assignTemp $ card dst_start
- emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
- (CmmLit (mkIntCLit 1))
- (cardRoundUp n)
- (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
+ dflags <- getDynFlags
+ start_card <- assignTemp $ card dflags dst_start
+ emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
+ (CmmLit (mkIntCLit dflags 1))
+ (cardRoundUp dflags n)
+ (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte)
live
-- Convert an element index to a card index
-card :: CmmExpr -> CmmExpr
-card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+card :: DynFlags -> CmmExpr -> CmmExpr
+card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags mUT_ARR_PTRS_CARD_BITS))
-- Convert a number of elements to a number of cards, rounding up
-cardRoundUp :: CmmExpr -> CmmExpr
-cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
+cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr
+cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
-bytesToWordsRoundUp :: CmmExpr -> CmmExpr
-bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
- `cmmQuotWord` wordSize
+bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr
+bytesToWordsRoundUp dflags e
+ = cmmQuotWord dflags
+ (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE - 1))))
+ (wordSize dflags)
-wordSize :: CmmExpr
-wordSize = CmmLit (mkIntCLit wORD_SIZE)
+wordSize :: DynFlags -> CmmExpr
+wordSize dflags = CmmLit (mkIntCLit dflags wORD_SIZE)
-- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 975787e492..87c13ee3f8 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -80,11 +80,11 @@ staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
-- The profiling header words in a static closure
-- Was SET_STATIC_PROF_HDR
staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs,
- staticLdvInit]
+ staticLdvInit dflags]
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
-- Profiling header words in a dynamic closure
-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
initUpdFrameProf :: CmmExpr -> Code
-- Initialise the profiling field of an update frame
@@ -104,7 +104,7 @@ profDynAlloc :: ClosureInfo -> CmmExpr -> Code
profDynAlloc cl_info ccs
= ifProfiling $
do dflags <- getDynFlags
- profAlloc (mkIntExpr (closureSize dflags cl_info)) ccs
+ profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs
-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
@@ -118,9 +118,9 @@ profAlloc words ccs
do dflags <- getDynFlags
stmtC (addToMemE alloc_rep
(cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc)
- (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
- [CmmMachOp mo_wordSub [words,
- mkIntExpr (profHdrSize dflags)]]))
+ (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $
+ [CmmMachOp (mo_wordSub dflags) [words,
+ mkIntExpr dflags (profHdrSize dflags)]]))
-- subtract the "profiling overhead", which is the
-- profiling header in a closure.
where
@@ -175,20 +175,19 @@ emitCostCentreDecl cc = do
showPpr dflags (costCentreSrcSpan cc)
-- XXX going via FastString to get UTF-8 encoding is silly
; let
- lits = [ zero, -- StgInt ccID,
+ is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
+ | otherwise = zero dflags
+ lits = [ zero dflags, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
- zero, -- StgWord time_ticks
+ zero dflags, -- StgWord time_ticks
is_caf, -- StgInt is_caf
- zero -- struct _CostCentre *link
+ zero dflags -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
- where
- is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
- | otherwise = zero
emitCostCentreStackDecl
@@ -196,20 +195,21 @@ emitCostCentreStackDecl
-> Code
emitCostCentreStackDecl ccs
| Just cc <- maybeSingletonCCS ccs = do
- { let
+ { dflags <- getDynFlags
+ ; let
-- Note: to avoid making any assumptions about how the
-- C compiler (that compiles the RTS, in particular) does
-- layouts of structs containing long-longs, simply
-- pad out the struct with zero words until we hit the
-- size of the overall struct (which we get via DerivedConstants.h)
--
- lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
+ lits = zero dflags : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) (zero dflags)
; emitDataLits (mkCCSLabel ccs) lits
}
| otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
-zero :: CmmLit
-zero = mkIntCLit 0
+zero :: DynFlags -> CmmLit
+zero dflags = mkIntCLit dflags 0
zero64 :: CmmLit
zero64 = CmmInt 0 W64
@@ -255,17 +255,17 @@ bumpSccCount dflags ccs
--
-- Initial value for the LDV field in a static closure
--
-staticLdvInit :: CmmLit
+staticLdvInit :: DynFlags -> CmmLit
staticLdvInit = zeroCLit
--
-- Initial value of the LDV field in a dynamic closure
--
-dynLdvInit :: CmmExpr
-dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
- CmmMachOp mo_wordOr [
- CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ],
- CmmLit (mkWordCLit lDV_STATE_CREATE)
+dynLdvInit :: DynFlags -> CmmExpr
+dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
+ CmmMachOp (mo_wordOr dflags) [
+ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ],
+ CmmLit (mkWordCLit dflags lDV_STATE_CREATE)
]
--
@@ -273,7 +273,7 @@ dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
--
ldvRecordCreate :: CmmExpr -> Code
ldvRecordCreate closure = do dflags <- getDynFlags
- stmtC $ CmmStore (ldvWord dflags closure) dynLdvInit
+ stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags)
--
-- Called when a closure is entered, marks the closure as having been "used".
@@ -295,19 +295,19 @@ ldvEnter cl_ptr = do
let
-- don't forget to substract node's tag
ldv_wd = ldvWord dflags cl_ptr
- new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd (bWord dflags))
- (CmmLit (mkWordCLit lDV_CREATE_MASK)))
- (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
+ new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
+ (CmmLit (mkWordCLit dflags lDV_CREATE_MASK)))
+ (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE)))
ifProfiling $
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-- era | LDV_STATE_USE }
- emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
+ emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
(stmtC (CmmStore ldv_wd new_ldv_wd))
-loadEra :: CmmExpr
-loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
- [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
+loadEra :: DynFlags -> CmmExpr
+loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
+ [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index b82e3080f3..5f5ff90e54 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -193,7 +193,7 @@ performTailCall fun_info arg_amodes pending_assts
fun_name = idName fun_id
lf_info = cgIdInfoLF fun_info
fun_has_cafs = idCafInfo fun_id
- untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
+ untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg))
-- Test if closure is a constructor
maybeSwitchOnCons dflags enterClosure eob
| EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
@@ -203,7 +203,7 @@ performTailCall fun_info arg_amodes pending_assts
= do { is_constr <- newLabelC
-- Is the pointer tagged?
-- Yes, jump to switch statement
- ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg))
+ ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg))
is_constr)
-- No, enter the closure.
; enterClosure
@@ -232,7 +232,7 @@ performTailCall fun_info arg_amodes pending_assts
-}
-- No case expression involved, enter the closure.
| otherwise
- = do { stmtC untag_node
+ = do { stmtC $ untag_node dflags
; enterClosure
}
where
diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
index bc9a94c8bd..85b07a070c 100644
--- a/compiler/codeGen/CgTicky.hs
+++ b/compiler/codeGen/CgTicky.hs
@@ -98,14 +98,14 @@ emitTickyCounter cl_info args on_stk
-- krc: note that all the fields are I32 now; some were I16 before,
-- but the code generator wasn't handling that properly and it led to chaos,
-- panic and disorder.
- [ mkIntCLit 0,
- mkIntCLit (length args),-- Arity
- mkIntCLit on_stk, -- Words passed on stack
+ [ mkIntCLit dflags 0,
+ mkIntCLit dflags (length args),-- Arity
+ mkIntCLit dflags on_stk, -- Words passed on stack
fun_descr_lit,
arg_descr_lit,
- zeroCLit, -- Entry count
- zeroCLit, -- Allocs
- zeroCLit -- Link
+ zeroCLit dflags, -- Entry count
+ zeroCLit dflags, -- Allocs
+ zeroCLit dflags -- Link
] }
where
name = closureName cl_info
@@ -179,17 +179,17 @@ registerTickyCtr :: CLabel -> Code
registerTickyCtr ctr_lbl
= do dflags <- getDynFlags
let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
- test = CmmMachOp (MO_Eq wordWidth)
+ test = CmmMachOp (MO_Eq (wordWidth dflags))
[CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp)) (bWord dflags),
- CmmLit (mkIntCLit 0)]
+ CmmLit (mkIntCLit dflags 0)]
register_stmts
= [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
(CmmLoad ticky_entry_ctrs (bWord dflags))
, CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
, CmmStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
- (CmmLit (mkIntCLit 1)) ]
+ (CmmLit (mkIntCLit dflags 1)) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
emitIf test (stmtsC register_stmts)
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index ca03dfa484..2ed464b766 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -93,33 +93,34 @@ addIdReps ids = [(idCgRep id, id) | id <- ids]
cgLit :: Literal -> FCode CmmLit
cgLit (MachStr s) = newByteStringCLit (bytesFB s)
-cgLit other_lit = return (mkSimpleLit other_lit)
-
-mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
-mkSimpleLit MachNullAddr = zeroCLit
-mkSimpleLit (MachInt i) = CmmInt i wordWidth
-mkSimpleLit (MachInt64 i) = CmmInt i W64
-mkSimpleLit (MachWord i) = CmmInt i wordWidth
-mkSimpleLit (MachWord64 i) = CmmInt i W64
-mkSimpleLit (MachFloat r) = CmmFloat r W32
-mkSimpleLit (MachDouble r) = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod)
+cgLit other_lit = do dflags <- getDynFlags
+ return (mkSimpleLit dflags other_lit)
+
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
+mkSimpleLit dflags MachNullAddr = zeroCLit dflags
+mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (MachInt64 i) = CmmInt i W64
+mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (MachWord64 i) = CmmInt i W64
+mkSimpleLit _ (MachFloat r) = CmmFloat r W32
+mkSimpleLit _ (MachDouble r) = CmmFloat r W64
+mkSimpleLit _ (MachLabel fs ms fod)
= CmmLabel (mkForeignLabel fs ms labelSrc fod)
where
-- TODO: Literal labels might not actually be in the current package...
labelSrc = ForeignLabelInThisPackage
-mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr"
+mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr"
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
-mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger"
+mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger"
mkLtOp :: DynFlags -> Literal -> MachOp
-- On signed literals we must do a signed comparison
-mkLtOp _ (MachInt _) = MO_S_Lt wordWidth
+mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags)
mkLtOp _ (MachFloat _) = MO_F_Lt W32
mkLtOp _ (MachDouble _) = MO_F_Lt W64
-mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit)))
+mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit)))
---------------------------------------------------
@@ -478,12 +479,13 @@ mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C
-- can't happen, so no need to test
-- SINGLETON BRANCH: one equality check to do
-mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C
- = return (CmmCondBranch cond deflt `consCgStmt` stmts)
- where
- cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
+mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do
+ dflags <- getDynFlags
+ let
+ cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag))
-- We have lo_tag < hi_tag, but there's only one branch,
-- so there must be a default
+ return (CmmCondBranch cond deflt `consCgStmt` stmts)
-- ToDo: we might want to check for the two branch case, where one of
-- the branches is the tag 0, because comparing '== 0' is likely to be
@@ -521,8 +523,9 @@ 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
- ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
+ = do { dflags <- getDynFlags
+ ; (assign_tag, tag_expr') <- assignTemp' tag_expr
+ ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
lowest_branch hi_tag via_C
@@ -530,8 +533,9 @@ 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
- ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
+ = do { dflags <- getDynFlags
+ ; (assign_tag, tag_expr') <- assignTemp' tag_expr
+ ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
lo_tag highest_branch via_C
@@ -539,14 +543,15 @@ 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 { dflags <- getDynFlags
+ ; (assign_tag, tag_expr') <- assignTemp' tag_expr
-- To avoid duplication
; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
lo_tag (mid_tag-1) via_C
; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
mid_tag hi_tag via_C
; hi_id <- forkCgStmts hi_stmts
- ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
+ ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag))
branch_stmt = CmmCondBranch cond hi_id
; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
}
@@ -632,7 +637,7 @@ mk_lit_switch :: CmmExpr -> BlockId
-> FCode CgStmts
mk_lit_switch scrut deflt_blk_id [(lit,blk)]
= do dflags <- getDynFlags
- let cmm_lit = mkSimpleLit lit
+ let cmm_lit = mkSimpleLit dflags lit
rep = cmmLitType dflags cmm_lit
ne = if isFloatType rep then MO_F_Ne else MO_Ne
cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
@@ -655,7 +660,7 @@ mk_lit_switch scrut deflt_blk_id branches
is_lo (t,_) = t < mid_lit
cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
- [scrut, CmmLit (mkSimpleLit mid_lit)]
+ [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
-------------------------------------------------------------------------
--
@@ -782,6 +787,7 @@ possiblySameLoc _ _ _ _ = True -- Conservative
getSRTInfo :: FCode C_SRT
getSRTInfo = do
+ dflags <- getDynFlags
srt_lbl <- getSRTLabel
srt <- getSRT
case srt of
@@ -795,8 +801,8 @@ getSRTInfo = do
let srt_desc_lbl = mkLargeSRTLabel id
emitRODataLits "getSRTInfo" srt_desc_lbl
( cmmLabelOffW srt_lbl off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
+ : mkWordCLit dflags (fromIntegral len)
+ : map (mkWordCLit dflags) bmp)
return (C_SRT srt_desc_lbl 0 srt_escape)
| otherwise
@@ -914,10 +920,10 @@ fixStgRegExpr dflags expr
-- expand it and defer to the above code.
case reg `elem` activeStgRegs platform of
True -> expr
- False -> fixStgRegExpr dflags (CmmMachOp (MO_Add wordWidth) [
+ False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
CmmReg (CmmGlobal reg),
CmmLit (CmmInt (fromIntegral offset)
- wordWidth)])
+ (wordWidth dflags))])
-- CmmLit, CmmReg (CmmLocal), CmmStackSlot
_other -> expr
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index b3a3fc8de8..e3383bb97b 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -458,9 +458,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
node' = if node_points then Just node else Nothing
; tickyEnterFun cl_info
; enterCostCentreFun cc
- (CmmMachOp mo_wordSub
+ (CmmMachOp (mo_wordSub dflags)
[ CmmReg nodeReg
- , mkIntExpr (funTag cl_info) ])
+ , mkIntExpr dflags (funTag cl_info) ])
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
@@ -508,7 +508,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
jump = mkDirectJump dflags
(mkLblExpr fast_lbl)
(map (CmmReg . CmmLocal) arg_regs)
- initUpdFrameOff
+ (initUpdFrameOff dflags)
emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
| otherwise = return ()
@@ -716,7 +716,7 @@ link_caf node _is_upd = do
-- see Note [atomic CAF entry] in rts/sm/Storage.c
; updfr <- getUpdFrameOff
; emit =<< mkCmmIfThen
- (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit])
+ (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), CmmLit (zeroCLit dflags)])
-- re-enter R1. Doing this directly is slightly dodgy; we're
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index a87bef110c..ccd7d96231 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -515,7 +515,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
; if isSmallFamily fam_sz
then do
let -- Yes, bndr_reg has constr. tag in ls bits
- tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
+ tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
branches' = [(tag+1,branch) | (tag,branch) <- branches]
emitSwitch tag_expr branches' mb_deflt 1 fam_sz
return AssignedDirectly
@@ -688,7 +688,7 @@ emitEnter fun = do
Return _ -> do
{ let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg
; emit $ mkForeignJump dflags NativeNodeCall entry
- [cmmUntag fun] updfr_off
+ [cmmUntag dflags fun] updfr_off
; return AssignedDirectly
}
@@ -732,7 +732,7 @@ emitEnter fun = do
the_call = toCall entry (Just lret) updfr_off off outArgs regs
; emit $
copyout <*>
- mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*>
+ mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*>
outOfLine lcall the_call <*>
mkLabel lret <*>
copyin
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 0a6b6b9e5a..d6a9b92bfd 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -222,7 +222,7 @@ emitForeignCall safety results target args _ret
let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
-- see Note [safe foreign call convention]
emit $
- ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
+ ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall { tgt = temp_target
, res = results
@@ -337,10 +337,10 @@ openNursery dflags = catAGraphs [
(cmmOffsetExpr dflags
(CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
(cmmOffset dflags
- (CmmMachOp mo_wordMul [
- CmmMachOp (MO_SS_Conv W32 wordWidth)
+ (CmmMachOp (mo_wordMul dflags) [
+ CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
[CmmLoad (nursery_bdescr_blocks dflags) b32],
- mkIntExpr bLOCK_SIZE
+ mkIntExpr dflags bLOCK_SIZE
])
(-1)
)
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 27d4244e35..a19810b6fb 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -181,7 +181,7 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
padding
| not is_caf = []
- | otherwise = ASSERT(null payload) [mkIntCLit 0]
+ | otherwise = ASSERT(null payload) [mkIntCLit dflags 0]
static_link_field
| is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
@@ -190,15 +190,15 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload
= []
saved_info_field
- | is_caf = [mkIntCLit 0]
+ | is_caf = [mkIntCLit dflags 0]
| otherwise = []
-- For a static constructor which has NoCafRefs, we set the
-- static link field to a non-zero value so the garbage
-- collector will ignore it.
static_link_value
- | mayHaveCafRefs caf_refs = mkIntCLit 0
- | otherwise = mkIntCLit 1 -- No CAF refs
+ | mayHaveCafRefs caf_refs = mkIntCLit dflags 0
+ | otherwise = mkIntCLit dflags 1 -- No CAF refs
mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
@@ -401,9 +401,9 @@ entryHeapCheck cl_info nodeSet arity args code
W32 -> Just (sLit "stg_gc_f1")
W64 -> Just (sLit "stg_gc_d1")
_other -> Nothing
- | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1")
- | width == W64 = Just (mkGcLabel "stg_gc_l1")
- | otherwise = Nothing
+ | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1")
+ | width == W64 = Just (mkGcLabel "stg_gc_l1")
+ | otherwise = Nothing
where
ty = localRegType reg
width = typeWidth ty
@@ -437,11 +437,11 @@ entryHeapCheck cl_info nodeSet arity args code
-- else we do a normal call to stg_gc_noregs
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
-altHeapCheck regs code
- = case cannedGCEntryPoint regs of
+altHeapCheck regs code = do
+ dflags <- getDynFlags
+ case cannedGCEntryPoint dflags regs of
Nothing -> genericGC code
Just gc -> do
- dflags <- getDynFlags
lret <- newLabelC
let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
lcont <- newLabelC
@@ -451,9 +451,10 @@ altHeapCheck regs code
altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
altHeapCheckReturnsTo regs lret off code
- = case cannedGCEntryPoint regs of
- Nothing -> genericGC code
- Just gc -> cannedGCReturnsTo True gc regs lret off code
+ = do dflags <- getDynFlags
+ case cannedGCEntryPoint dflags regs of
+ Nothing -> genericGC code
+ Just gc -> cannedGCReturnsTo True gc regs lret off code
cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
-> FCode a
@@ -478,8 +479,8 @@ genericGC code
call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[])
heapCheck False (call <*> mkBranch lretry) code
-cannedGCEntryPoint :: [LocalReg] -> Maybe CmmExpr
-cannedGCEntryPoint regs
+cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
+cannedGCEntryPoint dflags regs
= case regs of
[] -> Just (mkGcLabel "stg_gc_noregs")
[reg]
@@ -489,9 +490,9 @@ cannedGCEntryPoint regs
W64 -> Just (mkGcLabel "stg_gc_d1")
_ -> Nothing
- | width == wordWidth -> Just (mkGcLabel "stg_gc_unbx_r1")
- | width == W64 -> Just (mkGcLabel "stg_gc_l1")
- | otherwise -> Nothing
+ | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
+ | width == W64 -> Just (mkGcLabel "stg_gc_l1")
+ | otherwise -> Nothing
where
ty = localRegType reg
width = typeWidth ty
@@ -540,15 +541,31 @@ do_checks :: Bool -- Should we check the stack?
-> CmmAGraph -- What to do on failure
-> FCode ()
do_checks checkStack alloc do_gc = do
+ dflags <- getDynFlags
+ let
+ alloc_lit = mkIntExpr dflags (alloc*wORD_SIZE) -- Bytes
+ bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
+
+ -- Sp overflow if (Sp - CmmHighStack < SpLim)
+ sp_oflo = CmmMachOp (mo_wordULt dflags)
+ [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
+ [CmmReg spReg, CmmLit CmmHighStackMark],
+ CmmReg spLimReg]
+
+ -- Hp overflow if (Hp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp (mo_wordUGt dflags)
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+
+ alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
gc_id <- newLabelC
when checkStack $ do
- dflags <- getDynFlags
- emit =<< mkCmmIfGoto (sp_oflo dflags) gc_id
+ emit =<< mkCmmIfGoto sp_oflo gc_id
when (alloc /= 0) $ do
- dflags <- getDynFlags
- emitAssign hpReg (bump_hp dflags)
+ emitAssign hpReg bump_hp
emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
emitOutOfLine gc_id $
@@ -560,24 +577,6 @@ do_checks checkStack alloc do_gc = do
-- stack check succeeds. Otherwise we might end up
-- with slop at the end of the current block, which can
-- confuse the LDV profiler.
- where
- alloc_lit = mkIntExpr (alloc*wORD_SIZE) -- Bytes
- bump_hp dflags = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
-
- -- Sp overflow if (Sp - CmmHighStack < SpLim)
- sp_oflo dflags
- = CmmMachOp mo_wordULt
- [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
- [CmmReg spReg, CmmLit CmmHighStackMark],
- CmmReg spLimReg]
-
- -- Hp overflow if (Hp > HpLim)
- -- (Hp has been incremented by now)
- -- HpLim points to the LAST WORD of valid allocation space.
- hp_oflo = CmmMachOp mo_wordUGt
- [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
-
- alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
{-
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index b670b2401e..1469554a8b 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -608,7 +608,7 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableConstrTag dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
@@ -616,7 +616,7 @@ cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the closure type
-- obtained from the info table
cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableClosureType dflags info_table]
+ = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
where
info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 39bd1feef1..fb290d8e96 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -283,15 +283,15 @@ initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags,
cgd_mod = mod,
cgd_statics = emptyVarEnv,
- cgd_updfr_off = initUpdFrameOff,
+ cgd_updfr_off = initUpdFrameOff dflags,
cgd_ticky = mkTopTickyCtrLabel,
cgd_sequel = initSequel }
initSequel :: Sequel
initSequel = Return False
-initUpdFrameOff :: UpdFrameOffset
-initUpdFrameOff = widthInBytes wordWidth -- space for the RA
+initUpdFrameOff :: DynFlags -> UpdFrameOffset
+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
--------------------------------------------------------
@@ -518,11 +518,12 @@ forkClosureBody :: FCode () -> FCode ()
-- C-- from the fork is incorporated.
forkClosureBody body_code
- = do { info <- getInfoDown
+ = do { dflags <- getDynFlags
+ ; info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let body_info_down = info { cgd_sequel = initSequel
- , cgd_updfr_off = initUpdFrameOff }
+ , cgd_updfr_off = initUpdFrameOff dflags }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out)
= doFCode body_code body_info_down fork_state_in
@@ -534,12 +535,13 @@ forkStatics :: FCode a -> FCode a
-- The Abstract~C returned is attached to the current state, but the
-- bindings and usage information is otherwise unchanged.
forkStatics body_code
- = do { info <- getInfoDown
+ = do { dflags <- getDynFlags
+ ; info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let rhs_info_down = info { cgd_statics = cgs_binds state
, cgd_sequel = initSequel
- , cgd_updfr_off = initUpdFrameOff }
+ , cgd_updfr_off = initUpdFrameOff dflags }
(result, fork_state_out) = doFCode body_code rhs_info_down
(initCgState us)
; setState (state `addCodeBlocksFrom` fork_state_out)
@@ -680,7 +682,7 @@ emitProcWithConvention conv mb_info lbl args blocks
; us <- newUniqSupply
; let (offset, entry) = mkCallEntry dflags conv args
blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
- ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
+ ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)}
tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
proc_block = CmmProc tinfo lbl blks
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index e16557e09f..4efb272ee9 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -158,7 +158,7 @@ emitPrimOp :: DynFlags
-- First we handle various awkward cases specially. The remaining
-- easy cases are then handled by translateOp, defined below.
-emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb]
+emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb]
{-
With some bit-twiddling, we can define int{Add,Sub}Czh portably in
C, and without needing any comparisons. This may not be the
@@ -180,19 +180,19 @@ emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb]
-}
= emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp mo_wordUShr [
- CmmMachOp mo_wordAnd [
- CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
- CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr dflags) [
+ CmmMachOp (mo_wordAnd dflags) [
+ CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
+ CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr (wORD_SIZE_IN_BITS - 1)
+ mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
]
]
-emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb]
+emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb]
{- Similarly:
#define subIntCzh(r,c,a,b) \
{ r = ((I_)(a)) - ((I_)(b)); \
@@ -203,14 +203,14 @@ emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb]
c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
-}
= emit $ catAGraphs [
- mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
+ mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
mkAssign (CmmLocal res_c) $
- CmmMachOp mo_wordUShr [
- CmmMachOp mo_wordAnd [
- CmmMachOp mo_wordXor [aa,bb],
- CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
+ CmmMachOp (mo_wordUShr dflags) [
+ CmmMachOp (mo_wordAnd dflags) [
+ CmmMachOp (mo_wordXor dflags) [aa,bb],
+ CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
],
- mkIntExpr (wORD_SIZE_IN_BITS - 1)
+ mkIntExpr dflags (wORD_SIZE_IN_BITS - 1)
]
]
@@ -241,8 +241,8 @@ emitPrimOp dflags [res] GetCCSOfOp [arg]
= emitAssign (CmmLocal res) val
where
val
- | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg)
- | otherwise = CmmLit zeroCLit
+ | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
+ | otherwise = CmmLit (zeroCLit dflags)
emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
= emitAssign (CmmLocal res) curCCS
@@ -283,14 +283,14 @@ emitPrimOp dflags [res] StableNameToIntOp [arg]
-- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
- = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [
+ = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
])
-emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
- = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])
+emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
+ = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
-- #define addrToHValuezh(r,a) r=(P_)a
emitPrimOp _ [res] AddrToAnyOp [arg]
@@ -299,7 +299,7 @@ emitPrimOp _ [res] AddrToAnyOp [arg]
-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
-- Note: argument may be tagged!
emitPrimOp dflags [res] DataToTagOp [arg]
- = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))
+ = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))
{- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
@@ -372,116 +372,116 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
-- IndexXXXoffAddr
-emitPrimOp _ res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _ res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp _ res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args
-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
-emitPrimOp _ res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args
emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args
emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args
emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _ res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp _ res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args
-- IndexXXXArray
-emitPrimOp _ res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _ res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args
-emitPrimOp _ res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args
-- ReadXXXArray, identical to IndexXXXArray.
-emitPrimOp _ res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args
emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args
emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args
emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _ res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args
-emitPrimOp _ res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args
-emitPrimOp _ res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
-emitPrimOp _ res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args
-emitPrimOp _ res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args
-- WriteXXXoffAddr
-emitPrimOp _ res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args
emitPrimOp _ res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args
emitPrimOp _ res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args
emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args
emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args
emitPrimOp _ res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args
-emitPrimOp _ res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just mo_WordTo16) res args
-emitPrimOp _ res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
+emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args
-emitPrimOp _ res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just mo_WordTo16) res args
-emitPrimOp _ res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
+emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args
-- WriteXXXArray
-emitPrimOp _ res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args
emitPrimOp _ res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args
emitPrimOp _ res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args
emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args
emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args
emitPrimOp _ res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
-emitPrimOp _ res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just mo_WordTo16) res args
-emitPrimOp _ res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
+emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args
-emitPrimOp _ res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just mo_WordTo8) res args
-emitPrimOp _ res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_WordTo16) res args
-emitPrimOp _ res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args
+emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args
+emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
+emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args
-- Copying and setting byte arrays
@@ -493,31 +493,31 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] =
doSetByteArrayOp ba off len c
-- Population count
-emitPrimOp _ [res] PopCnt8Op [w] =
- emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8
-emitPrimOp _ [res] PopCnt16Op [w] =
- emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16
-emitPrimOp _ [res] PopCnt32Op [w] =
- emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32
+emitPrimOp dflags [res] PopCnt8Op [w] =
+ emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8
+emitPrimOp dflags [res] PopCnt16Op [w] =
+ emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16
+emitPrimOp dflags [res] PopCnt32Op [w] =
+ emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32
emitPrimOp _ [res] PopCnt64Op [w] =
emitPopCntCall res w W64 -- arg always has type W64, no need to narrow
-emitPrimOp _ [res] PopCntOp [w] =
- emitPopCntCall res w wordWidth
+emitPrimOp dflags [res] PopCntOp [w] =
+ emitPopCntCall res w (wordWidth dflags)
-- The rest just translate straightforwardly
-emitPrimOp _s [res] op [arg]
+emitPrimOp dflags [res] op [arg]
| nopOp op
= emitAssign (CmmLocal res) arg
| Just (mop,rep) <- narrowOp op
= emitAssign (CmmLocal res) $
- CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]
+ CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
-emitPrimOp _ r@[res] op args
+emitPrimOp dflags r@[res] op args
| Just prim <- callishOp op
= do emitPrimCall r prim args
- | Just mop <- translateOp op
+ | Just mop <- translateOp dflags op
= let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
emit stmt
@@ -531,19 +531,19 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
callishPrimOpSupported dflags op
= case op of
- IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth)
- | otherwise -> Right genericIntQuotRemOp
+ IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem (wordWidth dflags))
+ | otherwise -> Right (genericIntQuotRemOp dflags)
- WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth)
- | otherwise -> Right genericWordQuotRemOp
+ WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem (wordWidth dflags))
+ | otherwise -> Right (genericWordQuotRemOp dflags)
- WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth)
+ WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 (wordWidth dflags))
| otherwise -> Right (genericWordQuotRem2Op dflags)
- WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth)
+ WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags))
| otherwise -> Right genericWordAdd2Op
- WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth)
+ WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags))
| otherwise -> Right genericWordMul2Op
_ -> panic "emitPrimOp: can't translate PrimOp" (ppr op)
@@ -557,37 +557,37 @@ callishPrimOpSupported dflags op
ArchX86_64 -> True
_ -> False
-genericIntQuotRemOp :: GenericOp
-genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y]
+genericIntQuotRemOp :: DynFlags -> GenericOp
+genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
- (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*>
+ (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
- (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])
-genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp"
+ (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])
+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
-genericWordQuotRemOp :: GenericOp
-genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y]
+genericWordQuotRemOp :: DynFlags -> GenericOp
+genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
= emit $ mkAssign (CmmLocal res_q)
- (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*>
+ (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
mkAssign (CmmLocal res_r)
- (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])
-genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp"
+ (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])
+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
genericWordQuotRem2Op :: DynFlags -> GenericOp
genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
- = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low
+ = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
where ty = cmmExprType dflags arg_x_high
- shl x i = CmmMachOp (MO_Shl wordWidth) [x, i]
- shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
- ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y]
- ne x y = CmmMachOp (MO_Ne wordWidth) [x, y]
- minus x y = CmmMachOp (MO_Sub wordWidth) [x, y]
- times x y = CmmMachOp (MO_Mul wordWidth) [x, y]
+ shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i]
+ shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+ ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y]
+ ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y]
+ minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y]
+ times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
zero = lit 0
one = lit 1
- negone = lit (fromIntegral (widthInBits wordWidth) - 1)
- lit i = CmmLit (CmmInt i wordWidth)
+ negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
+ lit i = CmmLit (CmmInt i (wordWidth dflags))
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
@@ -627,14 +627,14 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
= do dflags <- getDynFlags
r1 <- newTemp (cmmExprType dflags arg_x)
r2 <- newTemp (cmmExprType dflags arg_x)
- let topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
- bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
- add x y = CmmMachOp (MO_Add wordWidth) [x, y]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+ let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- wordWidth)
- hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth)
+ (wordWidth dflags))
+ hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
emit $ catAGraphs
[mkAssign (CmmLocal r1)
(add (bottomHalf arg_x) (bottomHalf arg_y)),
@@ -658,16 +658,16 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
r <- liftM CmmLocal $ newTemp t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
- let topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww]
- toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww]
- bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm]
- add x y = CmmMachOp (MO_Add wordWidth) [x, y]
+ let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+ toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+ bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+ add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
sum = foldl1 add
- mul x y = CmmMachOp (MO_Mul wordWidth) [x, y]
- or x y = CmmMachOp (MO_Or wordWidth) [x, y]
+ mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
+ or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
- wordWidth)
- hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth)
+ (wordWidth dflags))
+ hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
emit $ catAGraphs
[mkAssign xlyl
(mul (bottomHalf arg_x) (bottomHalf arg_y)),
@@ -713,125 +713,125 @@ narrowOp _ = Nothing
-- Native word signless ops
-translateOp :: PrimOp -> Maybe MachOp
-translateOp IntAddOp = Just mo_wordAdd
-translateOp IntSubOp = Just mo_wordSub
-translateOp WordAddOp = Just mo_wordAdd
-translateOp WordSubOp = Just mo_wordSub
-translateOp AddrAddOp = Just mo_wordAdd
-translateOp AddrSubOp = Just mo_wordSub
-
-translateOp IntEqOp = Just mo_wordEq
-translateOp IntNeOp = Just mo_wordNe
-translateOp WordEqOp = Just mo_wordEq
-translateOp WordNeOp = Just mo_wordNe
-translateOp AddrEqOp = Just mo_wordEq
-translateOp AddrNeOp = Just mo_wordNe
-
-translateOp AndOp = Just mo_wordAnd
-translateOp OrOp = Just mo_wordOr
-translateOp XorOp = Just mo_wordXor
-translateOp NotOp = Just mo_wordNot
-translateOp SllOp = Just mo_wordShl
-translateOp SrlOp = Just mo_wordUShr
-
-translateOp AddrRemOp = Just mo_wordURem
+translateOp :: DynFlags -> PrimOp -> Maybe MachOp
+translateOp dflags IntAddOp = Just (mo_wordAdd dflags)
+translateOp dflags IntSubOp = Just (mo_wordSub dflags)
+translateOp dflags WordAddOp = Just (mo_wordAdd dflags)
+translateOp dflags WordSubOp = Just (mo_wordSub dflags)
+translateOp dflags AddrAddOp = Just (mo_wordAdd dflags)
+translateOp dflags AddrSubOp = Just (mo_wordSub dflags)
+
+translateOp dflags IntEqOp = Just (mo_wordEq dflags)
+translateOp dflags IntNeOp = Just (mo_wordNe dflags)
+translateOp dflags WordEqOp = Just (mo_wordEq dflags)
+translateOp dflags WordNeOp = Just (mo_wordNe dflags)
+translateOp dflags AddrEqOp = Just (mo_wordEq dflags)
+translateOp dflags AddrNeOp = Just (mo_wordNe dflags)
+
+translateOp dflags AndOp = Just (mo_wordAnd dflags)
+translateOp dflags OrOp = Just (mo_wordOr dflags)
+translateOp dflags XorOp = Just (mo_wordXor dflags)
+translateOp dflags NotOp = Just (mo_wordNot dflags)
+translateOp dflags SllOp = Just (mo_wordShl dflags)
+translateOp dflags SrlOp = Just (mo_wordUShr dflags)
+
+translateOp dflags AddrRemOp = Just (mo_wordURem dflags)
-- Native word signed ops
-translateOp IntMulOp = Just mo_wordMul
-translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
-translateOp IntQuotOp = Just mo_wordSQuot
-translateOp IntRemOp = Just mo_wordSRem
-translateOp IntNegOp = Just mo_wordSNeg
+translateOp dflags IntMulOp = Just (mo_wordMul dflags)
+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
+translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags)
+translateOp dflags IntRemOp = Just (mo_wordSRem dflags)
+translateOp dflags IntNegOp = Just (mo_wordSNeg dflags)
-translateOp IntGeOp = Just mo_wordSGe
-translateOp IntLeOp = Just mo_wordSLe
-translateOp IntGtOp = Just mo_wordSGt
-translateOp IntLtOp = Just mo_wordSLt
+translateOp dflags IntGeOp = Just (mo_wordSGe dflags)
+translateOp dflags IntLeOp = Just (mo_wordSLe dflags)
+translateOp dflags IntGtOp = Just (mo_wordSGt dflags)
+translateOp dflags IntLtOp = Just (mo_wordSLt dflags)
-translateOp ISllOp = Just mo_wordShl
-translateOp ISraOp = Just mo_wordSShr
-translateOp ISrlOp = Just mo_wordUShr
+translateOp dflags ISllOp = Just (mo_wordShl dflags)
+translateOp dflags ISraOp = Just (mo_wordSShr dflags)
+translateOp dflags ISrlOp = Just (mo_wordUShr dflags)
-- Native word unsigned ops
-translateOp WordGeOp = Just mo_wordUGe
-translateOp WordLeOp = Just mo_wordULe
-translateOp WordGtOp = Just mo_wordUGt
-translateOp WordLtOp = Just mo_wordULt
+translateOp dflags WordGeOp = Just (mo_wordUGe dflags)
+translateOp dflags WordLeOp = Just (mo_wordULe dflags)
+translateOp dflags WordGtOp = Just (mo_wordUGt dflags)
+translateOp dflags WordLtOp = Just (mo_wordULt dflags)
-translateOp WordMulOp = Just mo_wordMul
-translateOp WordQuotOp = Just mo_wordUQuot
-translateOp WordRemOp = Just mo_wordURem
+translateOp dflags WordMulOp = Just (mo_wordMul dflags)
+translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags)
+translateOp dflags WordRemOp = Just (mo_wordURem dflags)
-translateOp AddrGeOp = Just mo_wordUGe
-translateOp AddrLeOp = Just mo_wordULe
-translateOp AddrGtOp = Just mo_wordUGt
-translateOp AddrLtOp = Just mo_wordULt
+translateOp dflags AddrGeOp = Just (mo_wordUGe dflags)
+translateOp dflags AddrLeOp = Just (mo_wordULe dflags)
+translateOp dflags AddrGtOp = Just (mo_wordUGt dflags)
+translateOp dflags AddrLtOp = Just (mo_wordULt dflags)
-- Char# ops
-translateOp CharEqOp = Just (MO_Eq wordWidth)
-translateOp CharNeOp = Just (MO_Ne wordWidth)
-translateOp CharGeOp = Just (MO_U_Ge wordWidth)
-translateOp CharLeOp = Just (MO_U_Le wordWidth)
-translateOp CharGtOp = Just (MO_U_Gt wordWidth)
-translateOp CharLtOp = Just (MO_U_Lt wordWidth)
+translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags))
+translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags))
+translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags))
+translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags))
+translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags))
+translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags))
-- Double ops
-translateOp DoubleEqOp = Just (MO_F_Eq W64)
-translateOp DoubleNeOp = Just (MO_F_Ne W64)
-translateOp DoubleGeOp = Just (MO_F_Ge W64)
-translateOp DoubleLeOp = Just (MO_F_Le W64)
-translateOp DoubleGtOp = Just (MO_F_Gt W64)
-translateOp DoubleLtOp = Just (MO_F_Lt W64)
+translateOp _ DoubleEqOp = Just (MO_F_Eq W64)
+translateOp _ DoubleNeOp = Just (MO_F_Ne W64)
+translateOp _ DoubleGeOp = Just (MO_F_Ge W64)
+translateOp _ DoubleLeOp = Just (MO_F_Le W64)
+translateOp _ DoubleGtOp = Just (MO_F_Gt W64)
+translateOp _ DoubleLtOp = Just (MO_F_Lt W64)
-translateOp DoubleAddOp = Just (MO_F_Add W64)
-translateOp DoubleSubOp = Just (MO_F_Sub W64)
-translateOp DoubleMulOp = Just (MO_F_Mul W64)
-translateOp DoubleDivOp = Just (MO_F_Quot W64)
-translateOp DoubleNegOp = Just (MO_F_Neg W64)
+translateOp _ DoubleAddOp = Just (MO_F_Add W64)
+translateOp _ DoubleSubOp = Just (MO_F_Sub W64)
+translateOp _ DoubleMulOp = Just (MO_F_Mul W64)
+translateOp _ DoubleDivOp = Just (MO_F_Quot W64)
+translateOp _ DoubleNegOp = Just (MO_F_Neg W64)
-- Float ops
-translateOp FloatEqOp = Just (MO_F_Eq W32)
-translateOp FloatNeOp = Just (MO_F_Ne W32)
-translateOp FloatGeOp = Just (MO_F_Ge W32)
-translateOp FloatLeOp = Just (MO_F_Le W32)
-translateOp FloatGtOp = Just (MO_F_Gt W32)
-translateOp FloatLtOp = Just (MO_F_Lt W32)
+translateOp _ FloatEqOp = Just (MO_F_Eq W32)
+translateOp _ FloatNeOp = Just (MO_F_Ne W32)
+translateOp _ FloatGeOp = Just (MO_F_Ge W32)
+translateOp _ FloatLeOp = Just (MO_F_Le W32)
+translateOp _ FloatGtOp = Just (MO_F_Gt W32)
+translateOp _ FloatLtOp = Just (MO_F_Lt W32)
-translateOp FloatAddOp = Just (MO_F_Add W32)
-translateOp FloatSubOp = Just (MO_F_Sub W32)
-translateOp FloatMulOp = Just (MO_F_Mul W32)
-translateOp FloatDivOp = Just (MO_F_Quot W32)
-translateOp FloatNegOp = Just (MO_F_Neg W32)
+translateOp _ FloatAddOp = Just (MO_F_Add W32)
+translateOp _ FloatSubOp = Just (MO_F_Sub W32)
+translateOp _ FloatMulOp = Just (MO_F_Mul W32)
+translateOp _ FloatDivOp = Just (MO_F_Quot W32)
+translateOp _ FloatNegOp = Just (MO_F_Neg W32)
-- Conversions
-translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64)
-translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth)
+translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64)
+translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags))
-translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32)
-translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth)
+translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32)
+translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags))
-translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
-translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
+translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64)
+translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32)
-- Word comparisons masquerading as more exotic things.
-translateOp SameMutVarOp = Just mo_wordEq
-translateOp SameMVarOp = Just mo_wordEq
-translateOp SameMutableArrayOp = Just mo_wordEq
-translateOp SameMutableByteArrayOp = Just mo_wordEq
-translateOp SameMutableArrayArrayOp= Just mo_wordEq
-translateOp SameTVarOp = Just mo_wordEq
-translateOp EqStablePtrOp = Just mo_wordEq
+translateOp dflags SameMutVarOp = Just (mo_wordEq dflags)
+translateOp dflags SameMVarOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameTVarOp = Just (mo_wordEq dflags)
+translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags)
-translateOp _ = Nothing
+translateOp _ _ = Nothing
-- These primops are implemented by CallishMachOps, because they sometimes
-- turn into foreign calls depending on the backend.
@@ -913,8 +913,8 @@ doWritePtrArrayOp addr idx val
cmmOffsetExpr dflags
(cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
(loadArrPtrsSize dflags addr))
- (CmmMachOp mo_wordUShr [idx,
- mkIntExpr mUT_ARR_PTRS_CARD_BITS])
+ (CmmMachOp (mo_wordUShr dflags) [idx,
+ mkIntExpr dflags mUT_ARR_PTRS_CARD_BITS])
) (CmmLit (CmmInt 1 W8))
loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
@@ -967,7 +967,8 @@ doCopyByteArrayOp = emitCopyByteArray copy
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst dst_p src_p bytes =
- emitMemcpyCall dst_p src_p bytes (mkIntExpr 1)
+ do dflags <- getDynFlags
+ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1)
-- | Takes a source 'MutableByteArray#', an offset in the source
-- array, a destination 'MutableByteArray#', an offset into the
@@ -982,11 +983,12 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
+ dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
- getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr 1),
- getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr 1)
+ getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1),
+ getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1)
]
- emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
+ emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
@@ -1009,7 +1011,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
doSetByteArrayOp ba off len c
= do dflags <- getDynFlags
p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
- emitMemsetCall p c len (mkIntExpr 1)
+ emitMemsetCall p c len (mkIntExpr dflags 1)
-- ----------------------------------------------------------------------------
-- Copying pointer arrays
@@ -1039,7 +1041,8 @@ doCopyArrayOp = emitCopyArray copy
-- Copy data (we assume the arrays aren't overlapping since
-- they're of different types)
copy _src _dst dst_p src_p bytes =
- emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE)
+ do dflags <- getDynFlags
+ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE)
-- | Takes a source 'MutableArray#', an offset in the source array, a
@@ -1054,11 +1057,12 @@ doCopyMutableArrayOp = emitCopyArray copy
-- we were provided are the same array!
-- TODO: Optimize branch for common case of no aliasing.
copy src dst dst_p src_p bytes = do
+ dflags <- getDynFlags
[moveCall, cpyCall] <- forkAlts [
- getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr wORD_SIZE),
- getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE)
+ getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE),
+ getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE)
]
- emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
+ emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ())
@@ -1079,7 +1083,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
- bytes <- assignTempE $ cmmMulWord n (mkIntExpr wORD_SIZE)
+ bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags wORD_SIZE)
copy src dst dst_p src_p bytes
@@ -1095,20 +1099,23 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
-> FCode ()
emitCloneArray info_p res_r src0 src_off0 n0 = do
+ dflags <- getDynFlags
+ let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags +
+ (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE))
+ myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags oFFSET_Capability_r)
-- Passed as arguments (be careful)
src <- assignTempE src0
src_off <- assignTempE src_off0
n <- assignTempE n0
- card_bytes <- assignTempE $ cardRoundUp n
- size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
- dflags <- getDynFlags
- words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size
+ card_bytes <- assignTempE $ cardRoundUp dflags n
+ size <- assignTempE $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes)
+ words <- assignTempE $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size
arr_r <- newTemp (bWord dflags)
emitAllocateCall arr_r myCapability words
- tickyAllocPrim (mkIntExpr (arrPtrsHdrSize dflags)) (n `cmmMulWord` wordSize)
- zeroExpr
+ tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) (cmmMulWord dflags n (wordSize dflags))
+ (zeroExpr dflags)
let arr = CmmReg (CmmLocal arr_r)
emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
@@ -1121,43 +1128,40 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags))
src_off
- emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (mkIntExpr wORD_SIZE)
+ emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags wORD_SIZE)
emitMemsetCall (cmmOffsetExprW dflags dst_p n)
- (mkIntExpr 1)
+ (mkIntExpr dflags 1)
card_bytes
- (mkIntExpr wORD_SIZE)
+ (mkIntExpr dflags wORD_SIZE)
emit $ mkAssign (CmmLocal res_r) arr
- where
- arrPtrsHdrSizeW dflags = mkIntExpr (fixedHdrSize dflags +
- (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE))
- myCapability = CmmReg baseReg `cmmSubWord` mkIntExpr oFFSET_Capability_r
-- | Takes and offset in the destination array, the base address of
-- the card table, and the number of elements affected (*not* the
-- number of cards). Marks the relevant cards as dirty.
emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
emitSetCards dst_start dst_cards_start n = do
- start_card <- assignTempE $ card dst_start
- emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
- (mkIntExpr 1)
- (cardRoundUp n)
- (mkIntExpr 1) -- no alignment (1 byte)
+ dflags <- getDynFlags
+ start_card <- assignTempE $ card dflags dst_start
+ emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
+ (mkIntExpr dflags 1)
+ (cardRoundUp dflags n)
+ (mkIntExpr dflags 1) -- no alignment (1 byte)
-- Convert an element index to a card index
-card :: CmmExpr -> CmmExpr
-card i = i `cmmUShrWord` mkIntExpr mUT_ARR_PTRS_CARD_BITS
+card :: DynFlags -> CmmExpr -> CmmExpr
+card dflags i = cmmUShrWord dflags i (mkIntExpr dflags mUT_ARR_PTRS_CARD_BITS)
-- Convert a number of elements to a number of cards, rounding up
-cardRoundUp :: CmmExpr -> CmmExpr
-cardRoundUp i = card (i `cmmAddWord` (mkIntExpr ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1)))
+cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr
+cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1)))
-bytesToWordsRoundUp :: CmmExpr -> CmmExpr
-bytesToWordsRoundUp e = (e `cmmAddWord` mkIntExpr (wORD_SIZE - 1))
- `cmmQuotWord` wordSize
+bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr
+bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE - 1)))
+ (wordSize dflags)
-wordSize :: CmmExpr
-wordSize = mkIntExpr wORD_SIZE
+wordSize :: DynFlags -> CmmExpr
+wordSize dflags = mkIntExpr dflags wORD_SIZE
-- | Emit a call to @memcpy@.
emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index c980493de1..715bbb7415 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -94,11 +94,11 @@ staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
-- The profiling header words in a static closure
-- Was SET_STATIC_PROF_HDR
staticProfHdr dflags ccs
- = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit]
+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
-- Profiling header words in a dynamic closure
-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
initUpdFrameProf :: ByteOff -> FCode ()
-- Initialise the profiling field of an update frame
@@ -164,7 +164,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc rep ccs
= ifProfiling $
do dflags <- getDynFlags
- profAlloc (mkIntExpr (heapClosureSize dflags rep)) ccs
+ profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs
-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
@@ -175,9 +175,9 @@ profAlloc words ccs
do dflags <- getDynFlags
emit (addToMemE alloc_rep
(cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc)
- (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
- [CmmMachOp mo_wordSub [words,
- mkIntExpr (profHdrSize dflags)]]))
+ (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
+ [CmmMachOp (mo_wordSub dflags) [words,
+ mkIntExpr dflags (profHdrSize dflags)]]))
-- subtract the "profiling overhead", which is the
-- profiling header in a closure.
where
@@ -230,48 +230,48 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc = do
+ { dflags <- getDynFlags
+ ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
+ | otherwise = zero dflags
-- NB. bytesFS: we want the UTF-8 bytes here (#5559)
- { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
+ ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
$ Module.moduleName
$ cc_mod cc)
- ; dflags <- getDynFlags
; loc <- newByteStringCLit $ bytesFS $ mkFastString $
showPpr dflags (costCentreSrcSpan cc)
-- XXX going via FastString to get UTF-8 encoding is silly
; let
- lits = [ zero, -- StgInt ccID,
+ lits = [ zero dflags, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
loc, -- char *srcloc,
zero64, -- StgWord64 mem_alloc
- zero, -- StgWord time_ticks
+ zero dflags, -- StgWord time_ticks
is_caf, -- StgInt is_caf
- zero -- struct _CostCentre *link
+ zero dflags -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
- where
- is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
- | otherwise = zero
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs
= case maybeSingletonCCS ccs of
- Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
- Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
- where
- mk_lits cc = zero :
- mkCCostCentre cc :
- replicate (sizeof_ccs_words - 2) zero
- -- Note: to avoid making any assumptions about how the
- -- C compiler (that compiles the RTS, in particular) does
- -- layouts of structs containing long-longs, simply
- -- pad out the struct with zero words until we hit the
- -- size of the overall struct (which we get via DerivedConstants.h)
-
-zero :: CmmLit
-zero = mkIntCLit 0
+ Just cc ->
+ do dflags <- getDynFlags
+ let mk_lits cc = zero dflags :
+ mkCCostCentre cc :
+ replicate (sizeof_ccs_words - 2) (zero dflags)
+ -- Note: to avoid making any assumptions about how the
+ -- C compiler (that compiles the RTS, in particular) does
+ -- layouts of structs containing long-longs, simply
+ -- pad out the struct with zero words until we hit the
+ -- size of the overall struct (which we get via DerivedConstants.h)
+ emitDataLits (mkCCSLabel ccs) (mk_lits cc)
+ Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
+
+zero :: DynFlags -> CmmLit
+zero dflags = mkIntCLit dflags 0
zero64 :: CmmLit
zero64 = CmmInt 0 W64
@@ -318,17 +318,17 @@ bumpSccCount dflags ccs
--
-- Initial value for the LDV field in a static closure
--
-staticLdvInit :: CmmLit
+staticLdvInit :: DynFlags -> CmmLit
staticLdvInit = zeroCLit
--
-- Initial value of the LDV field in a dynamic closure
--
-dynLdvInit :: CmmExpr
-dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
- CmmMachOp mo_wordOr [
- CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ],
- CmmLit (mkWordCLit lDV_STATE_CREATE)
+dynLdvInit :: DynFlags -> CmmExpr
+dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
+ CmmMachOp (mo_wordOr dflags) [
+ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ],
+ CmmLit (mkWordCLit dflags lDV_STATE_CREATE)
]
--
@@ -336,7 +336,7 @@ dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure = do dflags <- getDynFlags
- emit $ mkStore (ldvWord dflags closure) dynLdvInit
+ emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
--
-- Called when a closure is entered, marks the closure as having been "used".
@@ -356,19 +356,19 @@ ldvEnter cl_ptr = do
dflags <- getDynFlags
let -- don't forget to substract node's tag
ldv_wd = ldvWord dflags cl_ptr
- new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd (bWord dflags))
- (CmmLit (mkWordCLit lDV_CREATE_MASK)))
- (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
+ new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
+ (CmmLit (mkWordCLit dflags lDV_CREATE_MASK)))
+ (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE)))
ifProfiling $
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-- era | LDV_STATE_USE }
- emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
+ emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
(mkStore ldv_wd new_ldv_wd)
mkNop
-loadEra :: CmmExpr
-loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
+loadEra :: DynFlags -> CmmExpr
+loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
[CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index e6cb6ed84b..d86d84a26c 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -106,14 +106,14 @@ emitTickyCounter cl_info args
-- krc: note that all the fields are I32 now; some were I16 before,
-- but the code generator wasn't handling that properly and it led to chaos,
-- panic and disorder.
- [ mkIntCLit 0,
- mkIntCLit (length args), -- Arity
- mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack
+ [ mkIntCLit dflags 0,
+ mkIntCLit dflags (length args), -- Arity
+ mkIntCLit dflags 0, -- XXX: we no longer know this! Words passed on stack
fun_descr_lit,
arg_descr_lit,
- zeroCLit, -- Entry count
- zeroCLit, -- Allocs
- zeroCLit -- Link
+ zeroCLit dflags, -- Entry count
+ zeroCLit dflags, -- Allocs
+ zeroCLit dflags -- Link
] }
-- When printing the name of a thing in a ticky file, we want to
@@ -183,17 +183,17 @@ registerTickyCtr ctr_lbl = do
dflags <- getDynFlags
let
-- krc: code generator doesn't handle Not, so we test for Eq 0 instead
- test = CmmMachOp (MO_Eq wordWidth)
+ test = CmmMachOp (MO_Eq (wordWidth dflags))
[CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp)) (bWord dflags),
- zeroExpr]
+ zeroExpr dflags]
register_stmts
= [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
(CmmLoad ticky_entry_ctrs (bWord dflags))
, mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
- (mkIntExpr 1) ]
+ (mkIntExpr dflags 1) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
emit =<< mkCmmIfThen test (catAGraphs register_stmts)
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index b402199ac4..1b934df9f7 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -86,31 +86,32 @@ import Data.Maybe
cgLit :: Literal -> FCode CmmLit
cgLit (MachStr s) = newByteStringCLit (bytesFB s)
-- not unpackFS; we want the UTF-8 byte stream.
-cgLit other_lit = return (mkSimpleLit other_lit)
+cgLit other_lit = do dflags <- getDynFlags
+ return (mkSimpleLit dflags other_lit)
mkLtOp :: DynFlags -> Literal -> MachOp
-- On signed literals we must do a signed comparison
-mkLtOp _ (MachInt _) = MO_S_Lt wordWidth
+mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags)
mkLtOp _ (MachFloat _) = MO_F_Lt W32
mkLtOp _ (MachDouble _) = MO_F_Lt W64
-mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit)))
+mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit)))
-- ToDo: seems terribly indirect!
-mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
-mkSimpleLit MachNullAddr = zeroCLit
-mkSimpleLit (MachInt i) = CmmInt i wordWidth
-mkSimpleLit (MachInt64 i) = CmmInt i W64
-mkSimpleLit (MachWord i) = CmmInt i wordWidth
-mkSimpleLit (MachWord64 i) = CmmInt i W64
-mkSimpleLit (MachFloat r) = CmmFloat r W32
-mkSimpleLit (MachDouble r) = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod)
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
+mkSimpleLit dflags MachNullAddr = zeroCLit dflags
+mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (MachInt64 i) = CmmInt i W64
+mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
+mkSimpleLit _ (MachWord64 i) = CmmInt i W64
+mkSimpleLit _ (MachFloat r) = CmmFloat r W32
+mkSimpleLit _ (MachDouble r) = CmmFloat r W64
+mkSimpleLit _ (MachLabel fs ms fod)
= CmmLabel (mkForeignLabel fs ms labelSrc fod)
where
-- TODO: Literal labels might not actually be in the current package...
labelSrc = ForeignLabelInThisPackage
-mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
+mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
--------------------------------------------------------------------------
--
@@ -514,11 +515,11 @@ mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
-- SINGLETON BRANCH: one equality check to do
mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
- = return (mkCbranch cond deflt lbl)
- where
- cond = cmmNeWord tag_expr (mkIntExpr tag)
- -- We have lo_tag < hi_tag, but there's only one branch,
- -- so there must be a default
+ = do dflags <- getDynFlags
+ let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag)
+ -- We have lo_tag < hi_tag, but there's only one branch,
+ -- so there must be a default
+ return (mkCbranch cond deflt lbl)
-- ToDo: we might want to check for the two branch case, where one of
-- the branches is the tag 0, because comparing '== 0' is likely to be
@@ -551,28 +552,31 @@ 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 stmts <- mk_switch tag_expr branches mb_deflt
+ = do dflags <- getDynFlags
+ stmts <- mk_switch tag_expr branches mb_deflt
lowest_branch hi_tag via_C
mkCmmIfThenElse
- (cmmULtWord tag_expr (mkIntExpr lowest_branch))
+ (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch))
(mkBranch deflt)
stmts
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
- = do stmts <- mk_switch tag_expr branches mb_deflt
+ = do dflags <- getDynFlags
+ stmts <- mk_switch tag_expr branches mb_deflt
lo_tag highest_branch via_C
mkCmmIfThenElse
- (cmmUGtWord tag_expr (mkIntExpr highest_branch))
+ (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch))
(mkBranch deflt)
stmts
| otherwise -- Use an if-tree
- = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
+ = do dflags <- getDynFlags
+ lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
lo_tag (mid_tag-1) via_C
hi_stmts <- mk_switch tag_expr hi_branches mb_deflt
mid_tag hi_tag via_C
mkCmmIfThenElse
- (cmmUGeWord tag_expr (mkIntExpr mid_tag))
+ (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag))
hi_stmts
lo_stmts
-- we test (e >= mid_tag) rather than (e < mid_tag), because
@@ -656,7 +660,7 @@ mk_lit_switch scrut deflt [(lit,blk)]
= do
dflags <- getDynFlags
let
- cmm_lit = mkSimpleLit lit
+ cmm_lit = mkSimpleLit dflags lit
cmm_ty = cmmLitType dflags cmm_lit
rep = typeWidth cmm_ty
ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
@@ -676,7 +680,7 @@ mk_lit_switch scrut deflt_blk_id branches
is_lo (t,_) = t < mid_lit
cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
- [scrut, CmmLit (mkSimpleLit mid_lit)]
+ [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
--------------
View Lorry Controller Status