summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/cmm/Bitmap.hs14
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs6
-rw-r--r--compiler/cmm/CmmInfo.hs6
-rw-r--r--compiler/cmm/CmmParse.y7
-rw-r--r--compiler/cmm/CmmUtils.hs6
-rw-r--r--compiler/cmm/SMRep.lhs33
-rw-r--r--compiler/codeGen/CgCallConv.hs12
-rw-r--r--compiler/codeGen/CgHeapery.lhs2
-rw-r--r--compiler/codeGen/CgParallel.hs6
-rw-r--r--compiler/codeGen/CgProf.hs18
-rw-r--r--compiler/codeGen/CgUtils.hs6
-rw-r--r--compiler/codeGen/ClosureInfo.lhs8
-rw-r--r--compiler/codeGen/StgCmmClosure.hs8
-rw-r--r--compiler/codeGen/StgCmmProf.hs18
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs8
-rw-r--r--compiler/ghci/ByteCodeInstr.lhs2
-rw-r--r--compiler/ghci/DebuggerUtils.hs15
17 files changed, 105 insertions, 70 deletions
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs
index 93217d5192..d48ab93093 100644
--- a/compiler/cmm/Bitmap.hs
+++ b/compiler/cmm/Bitmap.hs
@@ -39,12 +39,12 @@ type Bitmap = [StgWord]
-- | Make a bitmap from a sequence of bits
mkBitmap :: DynFlags -> [Bool] -> Bitmap
mkBitmap _ [] = []
-mkBitmap dflags stuff = chunkToBitmap chunk : mkBitmap dflags rest
+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest
where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
-chunkToBitmap :: [Bool] -> StgWord
-chunkToBitmap chunk =
- foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
+chunkToBitmap :: DynFlags -> [Bool] -> StgWord
+chunkToBitmap dflags chunk =
+ foldr (.|.) (toStgWord dflags 0) [ toStgWord dflags 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.
-- eg. @[0,1,3], size 4 ==> 0xb@.
@@ -54,7 +54,7 @@ intsToBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
- (foldr (.|.) 0 (map (1 `shiftL`) these)) :
+ (foldr (.|.) (toStgWord dflags 0) (map (toStgWord dflags 1 `shiftL`) these)) :
intsToBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
(map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
@@ -68,12 +68,12 @@ intsToReverseBitmap :: DynFlags -> Int -> [Int] -> Bitmap
intsToReverseBitmap dflags size slots{- must be sorted -}
| size <= 0 = []
| otherwise =
- (foldr xor init (map (1 `shiftL`) these)) :
+ (foldr xor (toStgWord dflags init) (map (toStgWord dflags 1 `shiftL`) these)) :
intsToReverseBitmap dflags (size - wORD_SIZE_IN_BITS dflags)
(map (\x -> x - wORD_SIZE_IN_BITS dflags) rest)
where (these,rest) = span (< wORD_SIZE_IN_BITS dflags) slots
init
- | size >= wORD_SIZE_IN_BITS dflags = complement 0
+ | size >= wORD_SIZE_IN_BITS dflags = -1
| otherwise = (1 `shiftL` size) - 1
{- |
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index fe8c599ef6..d587d60f95 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -228,17 +228,17 @@ maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT dflags top_srt off len bmp
- | len > maxBmpSize dflags || bmp == [fromInteger (fromStgHalfWord (srt_escape dflags))]
+ | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))]
= do id <- getUniqueM
let srt_desc_lbl = mkLargeSRTLabel id
tbl = CmmData RelocatableReadOnlyData $
Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW dflags top_srt off
- : mkWordCLit dflags (fromIntegral len)
+ : mkWordCLit dflags (toStgWord dflags (fromIntegral len))
: map (mkWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 (srt_escape dflags))
| otherwise
- = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (toInteger (head bmp))))
+ = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
-- The fromIntegral converts to StgHalfWord
-- Gather CAF info for a procedure, but only if the procedure
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 4dd74438ac..9d335c6f7b 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -321,13 +321,13 @@ mkLivenessBits dflags liveness
bitmap = mkBitmap dflags liveness
small_bitmap = case bitmap of
- [] -> 0
+ [] -> toStgWord dflags 0
[b] -> b
_ -> panic "mkLiveness"
- bitmap_word = fromIntegral n_bits
+ bitmap_word = toStgWord dflags (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
- lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap
+ lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index e064149630..8c3559b774 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -312,12 +312,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
- | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' stgHalfWord ',' STRING ',' STRING ')'
+ | 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% withThisPackage $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
- ty = ThunkSelector (fromIntegral $5)
+ ty = ThunkSelector $5
rep = mkRTSRep $7 $
mkHeapRep dflags False 0 0 ty
return (mkCmmEntryLabel pkg $3,
@@ -614,6 +614,9 @@ typenot8 :: { CmmType }
| 'float64' { f64 }
| 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
+stgWord :: { StgWord }
+ : INT {% do dflags <- getDynFlags; return $ toStgWord dflags $1 }
+
stgHalfWord :: { StgHalfWord }
: INT {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 }
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index fab384cd3c..cde5bd1d20 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -156,7 +156,7 @@ mkRODataLits lbl lits
needsRelocation _ = False
mkWordCLit :: DynFlags -> StgWord -> CmmLit
-mkWordCLit dflags wd = CmmInt (fromIntegral wd) (wordWidth dflags)
+mkWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
-- Make a single word literal in which the lower_half_word is
@@ -168,8 +168,8 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
= if wORDS_BIGENDIAN dflags
then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS) .|. u)
else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS))
- where l = fromInteger (fromStgHalfWord lower_half_word)
- u = fromInteger (fromStgHalfWord upper_half_word)
+ where l = toStgWord dflags (fromStgHalfWord lower_half_word)
+ u = toStgWord dflags (fromStgHalfWord upper_half_word)
---------------------------------------------------
--
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index 4443158f89..bf30374092 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -9,9 +9,11 @@ This is here, rather than in ClosureInfo, just to keep nhc happy.
Other modules should access this info through ClosureInfo.
\begin{code}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module SMRep (
-- * Words and bytes
- StgWord,
+ StgWord, fromStgWord, toStgWord,
StgHalfWord, fromStgHalfWord, toStgHalfWord,
hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
WordOff, ByteOff,
@@ -50,6 +52,7 @@ import Outputable
import Platform
import FastString
+import Data.Array.Base
import Data.Char( ord )
import Data.Word
import Data.Bits
@@ -73,6 +76,30 @@ roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZ
StgWord is a type representing an StgWord on the target platform.
\begin{code}
+newtype StgWord = StgWord Word64
+ deriving (Eq,
+#if __GLASGOW_HASKELL__ < 706
+ Num,
+#endif
+ Bits, IArray UArray)
+
+fromStgWord :: StgWord -> Integer
+fromStgWord (StgWord i) = toInteger i
+
+toStgWord :: DynFlags -> Integer -> StgWord
+toStgWord dflags i
+ = case platformWordSize (targetPlatform dflags) of
+ -- These conversions mean that things like toStgWord (-1)
+ -- do the right thing
+ 4 -> StgWord (fromIntegral (fromInteger i :: Word32))
+ 8 -> StgWord (fromInteger i :: Word64)
+ w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)
+
+instance Outputable StgWord where
+ ppr (StgWord i) = integer (toInteger i)
+
+--
+
newtype StgHalfWord = StgHalfWord Integer
deriving Eq
@@ -92,13 +119,11 @@ instance Outputable StgHalfWord where
ppr (StgHalfWord i) = integer i
#if SIZEOF_HSWORD == 4
-type StgWord = Word32
hALF_WORD_SIZE :: ByteOff
hALF_WORD_SIZE = 2
hALF_WORD_SIZE_IN_BITS :: Int
hALF_WORD_SIZE_IN_BITS = 16
#elif SIZEOF_HSWORD == 8
-type StgWord = Word64
hALF_WORD_SIZE :: ByteOff
hALF_WORD_SIZE = 4
hALF_WORD_SIZE_IN_BITS :: Int
@@ -396,7 +421,7 @@ pprTypeInfo (Fun arity args)
, ptext (sLit ("fun_type:")) <+> ppr args ])
pprTypeInfo (ThunkSelector offset)
- = ptext (sLit "ThunkSel") <+> integer (toInteger offset)
+ = ptext (sLit "ThunkSel") <+> ppr offset
pprTypeInfo Thunk = ptext (sLit "Thunk")
pprTypeInfo BlackHole = ptext (sLit "BlackHole")
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index e468936a7a..1f5b711d86 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -121,13 +121,13 @@ stdPattern dflags reps
-- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
-------------------------------------------------------------------------
-mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord
-mkRegLiveness regs ptrs nptrs
- = (fromIntegral nptrs `shiftL` 16) .|.
- (fromIntegral ptrs `shiftL` 24) .|.
- all_non_ptrs `xor` reg_bits regs
+mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord
+mkRegLiveness dflags regs ptrs nptrs
+ = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|.
+ (toStgWord dflags (toInteger ptrs) `shiftL` 24) .|.
+ all_non_ptrs `xor` toStgWord dflags (reg_bits regs)
where
- all_non_ptrs = 0xff
+ all_non_ptrs = toStgWord dflags 0xff
reg_bits [] = 0
reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index c7f6f294ce..965abf0db8 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -416,7 +416,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
; 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
+ liveness = mkRegLiveness dflags 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
diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs
index c86ef9e34a..fdc9846694 100644
--- a/compiler/codeGen/CgParallel.hs
+++ b/compiler/codeGen/CgParallel.hs
@@ -51,12 +51,11 @@ granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers
-- Emit code for simulating a fetch and then reschedule.
granFetchAndReschedule regs node_reqd
= do dflags <- getDynFlags
+ let liveness = mkRegLiveness dflags regs 0 0
when (dopt Opt_GranMacros dflags &&
(node `elem` map snd regs || node_reqd)) $
do fetch
reschedule liveness node_reqd
- where
- liveness = mkRegLiveness regs 0 0
fetch :: FCode ()
fetch = panic "granFetch"
@@ -90,9 +89,8 @@ granYield :: [(Id,GlobalReg)] -- Live registers
granYield regs node_reqd
= do dflags <- getDynFlags
+ let liveness = mkRegLiveness dflags regs 0 0
when (dopt Opt_GranMacros dflags && node_reqd) $ yield liveness
- where
- liveness = mkRegLiveness regs 0 0
yield :: StgWord -> Code
yield _liveness = panic "granYield"
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 1c78dd8ec6..9848d345e9 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -266,7 +266,7 @@ 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)
+ CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
]
--
@@ -297,8 +297,8 @@ ldvEnter cl_ptr = do
-- don't forget to substract node's tag
ldv_wd = ldvWord dflags cl_ptr
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)))
+ (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
+ (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
ifProfiling $
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -321,12 +321,12 @@ lDV_SHIFT :: Int
lDV_SHIFT = LDV_SHIFT
--lDV_STATE_MASK :: StgWord
--lDV_STATE_MASK = LDV_STATE_MASK
-lDV_CREATE_MASK :: StgWord
-lDV_CREATE_MASK = LDV_CREATE_MASK
+lDV_CREATE_MASK :: DynFlags -> StgWord
+lDV_CREATE_MASK dflags = toStgWord dflags LDV_CREATE_MASK
--lDV_LAST_MASK :: StgWord
--lDV_LAST_MASK = LDV_LAST_MASK
-lDV_STATE_CREATE :: StgWord
-lDV_STATE_CREATE = LDV_STATE_CREATE
-lDV_STATE_USE :: StgWord
-lDV_STATE_USE = LDV_STATE_USE
+lDV_STATE_CREATE :: DynFlags -> StgWord
+lDV_STATE_CREATE dflags = toStgWord dflags LDV_STATE_CREATE
+lDV_STATE_USE :: DynFlags -> StgWord
+lDV_STATE_USE dflags = toStgWord dflags LDV_STATE_USE
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 2abdb0e589..aee4c7b5b3 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -795,17 +795,17 @@ getSRTInfo = do
NoSRT -> return NoC_SRT
SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
SRT off len bmp
- | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromInteger (fromStgHalfWord (srt_escape dflags))]
+ | len > hALF_WORD_SIZE_IN_BITS || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))]
-> do id <- newUnique
let srt_desc_lbl = mkLargeSRTLabel id
emitRODataLits "getSRTInfo" srt_desc_lbl
( cmmLabelOffW dflags srt_lbl off
- : mkWordCLit dflags (fromIntegral len)
+ : mkWordCLit dflags (toStgWord dflags (toInteger len))
: map (mkWordCLit dflags) bmp)
return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
| otherwise
- -> return (C_SRT srt_lbl off (toStgHalfWord dflags (toInteger (head bmp))))
+ -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp))))
-- The fromIntegral converts to StgHalfWord
srt_escape :: DynFlags -> StgHalfWord
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index f06ee7840c..740bfab845 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -530,12 +530,12 @@ lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
(dataConIdentity con)
-lfClosureType _ (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
+lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel
lfClosureType _ _ = panic "lfClosureType"
-thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
-thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
-thunkClosureType _ = Thunk
+thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
+thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
+thunkClosureType _ _ = Thunk
-- We *do* get non-updatable top-level thunks sometimes. eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 2d767a6c6d..4be5bd3d0c 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -357,12 +357,12 @@ lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
lfClosureType dflags (LFCon con) = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
(dataConIdentity con)
-lfClosureType _ (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
+lfClosureType dflags (LFThunk _ _ _ is_sel _) = thunkClosureType dflags is_sel
lfClosureType _ _ = panic "lfClosureType"
-thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
-thunkClosureType (SelectorThunk off) = ThunkSelector (fromIntegral off)
-thunkClosureType _ = Thunk
+thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
+thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
+thunkClosureType _ _ = Thunk
-- We *do* get non-updatable top-level thunks sometimes. eg. f = g
-- gets compiled to a jump to g (if g has non-zero arity), instead of
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index d2f4984538..30ced9a1ff 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -329,7 +329,7 @@ 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)
+ CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
]
--
@@ -358,8 +358,8 @@ ldvEnter cl_ptr = do
let -- don't forget to substract node's tag
ldv_wd = ldvWord dflags cl_ptr
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)))
+ (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
+ (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
ifProfiling $
-- if (era > 0) {
-- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -384,12 +384,12 @@ lDV_SHIFT :: Int
lDV_SHIFT = LDV_SHIFT
--lDV_STATE_MASK :: StgWord
--lDV_STATE_MASK = LDV_STATE_MASK
-lDV_CREATE_MASK :: StgWord
-lDV_CREATE_MASK = LDV_CREATE_MASK
+lDV_CREATE_MASK :: DynFlags -> StgWord
+lDV_CREATE_MASK dflags = toStgWord dflags LDV_CREATE_MASK
--lDV_LAST_MASK :: StgWord
--lDV_LAST_MASK = LDV_LAST_MASK
-lDV_STATE_CREATE :: StgWord
-lDV_STATE_CREATE = LDV_STATE_CREATE
-lDV_STATE_USE :: StgWord
-lDV_STATE_USE = LDV_STATE_USE
+lDV_STATE_CREATE :: DynFlags -> StgWord
+lDV_STATE_CREATE dflags = toStgWord dflags LDV_STATE_CREATE
+lDV_STATE_USE :: DynFlags -> StgWord
+lDV_STATE_USE dflags = toStgWord dflags LDV_STATE_USE
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 15c41d044e..f00e45c6b6 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -166,7 +166,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
insns_arr = listArray (0, n_insns - 1) asm_insns
!insns_barr = barr insns_arr
- bitmap_arr = mkBitmapArray bsize bitmap
+ bitmap_arr = mkBitmapArray dflags bsize bitmap
!bitmap_barr = barr bitmap_arr
ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
@@ -178,9 +178,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
return ul_bco
-mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord
-mkBitmapArray bsize bitmap
- = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
+mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArray Int StgWord
+mkBitmapArray dflags bsize bitmap
+ = listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap)
-- instrs nonptrs ptrs
type AsmState = (SizedSeq Word16,
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index ada0be6f0f..ed49960709 100644
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -178,7 +178,7 @@ instance Outputable a => Outputable (ProtoBCO a) where
Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
(map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
Right rhs -> pprCoreExprShort (deAnnotate rhs))
- $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap))
+ $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
$$ nest 3 (vcat (map ppr instrs))
-- Print enough of the Core expression to enable the reader to find
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index ab7fcd1764..b1688d85f8 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -9,11 +9,11 @@ import TcRnTypes
import TcRnMonad
import IfaceEnv
import CgInfoTbls
-import SMRep
import Module
import OccName
import Name
import Outputable
+import Platform
import Util
import Data.Char
@@ -93,8 +93,17 @@ dataConInfoPtrToName x = do
getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
getConDescAddress dflags ptr
| ghciTablesNextToCode = do
- offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE dflags)
- return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+ let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)
+ -- offsetToString is really an StgWord, but we have to jump
+ -- through some hoops due to the way that our StgWord Haskell
+ -- type is the same on 32 and 64bit platforms
+ offsetToString <- case platformWordSize (targetPlatform dflags) of
+ 4 -> do w <- peek ptr'
+ return (fromIntegral (w :: Word32))
+ 8 -> do w <- peek ptr'
+ return (fromIntegral (w :: Word64))
+ w -> panic ("getConDescAddress: Unknown platformWordSize: " ++ show w)
+ return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` offsetToString
| otherwise =
peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
-- parsing names is a little bit fiddly because we have a string in the form:
View Lorry Controller Status