summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2012-09-17 13:09:22 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2012-09-17 13:09:22 +0100
commitb0db9308017fc14b600b3a85d9c55a037f12ee9e (patch)
treeb51b0b9d26b328b5e14e9d4d681219483f9c9b1f /compiler/ghci
parent633dd5589f8625a8771ac75c5341ea225301d882 (diff)
parent8c3b9aca3aaf946a91c9af6c07fc9d2afb6bbb76 (diff)
downloadhaskell-b0db9308017fc14b600b3a85d9c55a037f12ee9e.tar.gz
Merge remote-tracking branch 'origin/master' into tc-untouchables
Conflicts: compiler/typecheck/TcMType.lhs compiler/typecheck/TcSMonad.lhs
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs67
-rw-r--r--compiler/ghci/ByteCodeGen.lhs128
-rw-r--r--compiler/ghci/ByteCodeItbls.lhs57
-rw-r--r--compiler/ghci/ByteCodeLink.lhs39
-rw-r--r--compiler/ghci/DebuggerUtils.hs3
-rw-r--r--compiler/ghci/LibFFI.hsc21
-rw-r--r--compiler/ghci/Linker.lhs25
-rw-r--r--compiler/ghci/RtClosureInspect.hs27
8 files changed, 177 insertions, 190 deletions
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 73724c007e..15c41d044e 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -27,7 +27,6 @@ import NameSet
import Literal
import TyCon
import PrimOp
-import Constants
import FastString
import SMRep
import ClosureInfo -- CgRep stuff
@@ -133,7 +132,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
-- Remember that the first insn starts at offset
-- sizeOf Word / sizeOf Word16
-- since offset 0 (eventually) will hold the total # of insns.
- initial_offset = largeArg16s
+ initial_offset = largeArg16s dflags
-- Jump instructions are variable-sized, there are long and short variants
-- depending on the magnitude of the offset. However, we can't tell what
@@ -143,9 +142,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
-- and if the final size is indeed small enough for short jumps, we are
-- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long.
- (n_insns0, lbl_map0) = inspectAsm False initial_offset asm
+ (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
((n_insns, lbl_map), long_jumps)
- | isLarge n_insns0 = (inspectAsm True initial_offset asm, True)
+ | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
| otherwise = ((n_insns0, lbl_map0), False)
env :: Word16 -> Word
@@ -154,9 +153,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
(Map.lookup lbl lbl_map)
-- pass 2: run assembler and generate instructions, literals and pointers
- let initial_insns = addListToSS emptySS $ largeArg n_insns
+ let initial_insns = addListToSS emptySS $ largeArg dflags n_insns
let initial_state = (initial_insns, emptySS, emptySS)
- (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm long_jumps env asm
+ (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm dflags long_jumps env asm
-- precomputed size should be equal to final size
ASSERT (n_insns == sizeSS final_insns) return ()
@@ -250,8 +249,8 @@ largeOp long_jumps op = case op of
Op w -> isLarge w
LabelOp _ -> long_jumps
-runAsm :: Bool -> LabelEnv -> Assembler a -> State AsmState IO a
-runAsm long_jumps e = go
+runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> State AsmState IO a
+runAsm dflags long_jumps e = go
where
go (NullAsm x) = return x
go (AllocPtr p_io k) = do
@@ -273,9 +272,9 @@ runAsm long_jumps e = go
| otherwise = w
words = concatMap expand ops
expand (SmallOp w) = [w]
- expand (LargeOp w) = largeArg w
+ expand (LargeOp w) = largeArg dflags w
expand (LabelOp w) = expand (Op (e w))
- expand (Op w) = if largeOps then largeArg w else [fromIntegral w]
+ expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
State $ \(st_i0,st_l0,st_p0) -> do
let st_i1 = addListToSS st_i0 (opcode : words)
return ((st_i1,st_l0,st_p0), ())
@@ -290,8 +289,8 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
-inspectAsm :: Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
-inspectAsm long_jumps initial_offset
+inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
+inspectAsm dflags long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
where
go s (NullAsm _) = (instrCount s, lblEnv s)
@@ -307,9 +306,9 @@ inspectAsm long_jumps initial_offset
size = sum (map count ops) + 1
largeOps = any (largeOp long_jumps) ops
count (SmallOp _) = 1
- count (LargeOp _) = largeArg16s
+ count (LargeOp _) = largeArg16s dflags
count (LabelOp _) = count (Op 0)
- count (Op _) = if largeOps then largeArg16s else 1
+ count (Op _) = if largeOps then largeArg16s dflags else 1
-- Bring in all the bci_ bytecode constants.
#include "rts/Bytecodes.h"
@@ -317,21 +316,21 @@ inspectAsm long_jumps initial_offset
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
-largeArg :: Word -> [Word16]
-largeArg w
- | wORD_SIZE_IN_BITS == 64
+largeArg :: DynFlags -> Word -> [Word16]
+largeArg dflags w
+ | wORD_SIZE_IN_BITS dflags == 64
= [fromIntegral (w `shiftR` 48),
fromIntegral (w `shiftR` 32),
fromIntegral (w `shiftR` 16),
fromIntegral w]
- | wORD_SIZE_IN_BITS == 32
+ | wORD_SIZE_IN_BITS dflags == 32
= [fromIntegral (w `shiftR` 16),
fromIntegral w]
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-largeArg16s :: Word
-largeArg16s | wORD_SIZE_IN_BITS == 64 = 4
- | otherwise = 2
+largeArg16s :: DynFlags -> Word
+largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
+ | otherwise = 2
assembleI :: DynFlags
-> BCInstr
@@ -432,9 +431,9 @@ assembleI dflags i = case i of
litlabel fs = lit [BCONPtrLbl fs]
addr = words . mkLitPtr
float = words . mkLitF
- double = words . mkLitD
+ double = words . mkLitD dflags
int = words . mkLitI
- int64 = words . mkLitI64
+ int64 = words . mkLitI64 dflags
words ws = lit (map BCONPtrWord ws)
word w = words [w]
@@ -460,11 +459,11 @@ return_ubx PtrArg = bci_RETURN_P
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
-mkLitI :: Int -> [Word]
-mkLitF :: Float -> [Word]
-mkLitD :: Double -> [Word]
-mkLitPtr :: Ptr () -> [Word]
-mkLitI64 :: Int64 -> [Word]
+mkLitI :: Int -> [Word]
+mkLitF :: Float -> [Word]
+mkLitD :: DynFlags -> Double -> [Word]
+mkLitPtr :: Ptr () -> [Word]
+mkLitI64 :: DynFlags -> Int64 -> [Word]
mkLitF f
= runST (do
@@ -475,8 +474,8 @@ mkLitF f
return [w0 :: Word]
)
-mkLitD d
- | wORD_SIZE == 4
+mkLitD dflags d
+ | wORD_SIZE dflags == 4
= runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 d
@@ -485,7 +484,7 @@ mkLitD d
w1 <- readArray d_arr 1
return [w0 :: Word, w1]
)
- | wORD_SIZE == 8
+ | wORD_SIZE dflags == 8
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 d
@@ -496,8 +495,8 @@ mkLitD d
| otherwise
= panic "mkLitD: Bad wORD_SIZE"
-mkLitI64 ii
- | wORD_SIZE == 4
+mkLitI64 dflags ii
+ | wORD_SIZE dflags == 4
= runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 ii
@@ -506,7 +505,7 @@ mkLitI64 ii
w1 <- readArray d_arr 1
return [w0 :: Word,w1]
)
- | wORD_SIZE == 8
+ | wORD_SIZE dflags == 8
= runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 ii
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index b277a1ed30..af7a06876d 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -22,7 +22,9 @@ import ByteCodeAsm
import ByteCodeLink
import LibFFI
+import DynFlags
import Outputable
+import Platform
import Name
import MkId
import Id
@@ -40,7 +42,6 @@ import TyCon
import Util
import VarSet
import TysPrim
-import DynFlags
import ErrUtils
import Unique
import FastString
@@ -49,7 +50,6 @@ import SMRep
import ClosureInfo
import Bitmap
import OrdList
-import Constants
import Data.List
import Foreign
@@ -152,7 +152,8 @@ ppBCEnv p
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO
- :: name
+ :: DynFlags
+ -> name
-> BCInstrList
-> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
-> Int
@@ -161,7 +162,7 @@ mkProtoBCO
-> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
@@ -180,7 +181,7 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
- | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+ | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
-- don't do stack checks at return points,
-- everything is aggregated up to the top BCO
-- (which must be a function).
@@ -206,11 +207,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
peep []
= []
-argBits :: [CgRep] -> [Bool]
-argBits [] = []
-argBits (rep : args)
- | isFollowableArg rep = False : argBits args
- | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
+argBits :: DynFlags -> [CgRep] -> [Bool]
+argBits _ [] = []
+argBits dflags (rep : args)
+ | isFollowableArg rep = False : argBits dflags args
+ | otherwise = take (cgRepSizeW dflags rep) (repeat True) ++ argBits dflags args
-- -----------------------------------------------------------------------------
-- schemeTopBind
@@ -223,6 +224,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
+ dflags <- getDynFlags
-- Special case for the worker of a nullary data con.
-- It'll look like this: Nil = /\a -> Nil a
-- If we feed it into schemeR, we'll get
@@ -231,7 +233,7 @@ schemeTopBind (id, rhs)
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
- emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
+ emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
@@ -281,25 +283,26 @@ collect (_, e) = go [] e
schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
- = let
+ = do
+ dflags <- getDynFlags
+ let
all_args = reverse args ++ fvs
arity = length all_args
-- all_args are the args in reverse order. We're compiling a function
-- \fv1..fvn x1..xn -> e
-- i.e. the fvs come first
- szsw_args = map (fromIntegral . idSizeW) all_args
+ szsw_args = map (fromIntegral . idSizeW dflags) all_args
szw_args = sum szsw_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
-- make the arg bitmap
- bits = argBits (reverse (map idCgRep all_args))
+ bits = argBits dflags (reverse (map idCgRep all_args))
bitmap_size = genericLength bits
- bitmap = mkBitmap bits
- in do
+ bitmap = mkBitmap dflags bits
body_code <- schemeER_wrk szw_args p_init body
- emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
+ emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
@@ -396,15 +399,16 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
-schemeE d s p (AnnLet binds (_,body))
- = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
+schemeE d s p (AnnLet binds (_,body)) = do
+ dflags <- getDynFlags
+ let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n_binds = genericLength xs
fvss = map (fvsToEnv p' . fst) rhss
-- Sizes of free vars
- sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
+ sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
-- the arity of each rhs
arities = map (genericLength . fst . collect) rhss
@@ -447,7 +451,6 @@ schemeE d s p (AnnLet binds (_,body))
| (fvs, x, rhs, size, arity, n) <-
zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
]
- in do
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
@@ -772,7 +775,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| UbxTupleRep _ <- repType (idType bndr)
= unboxedTupleException
| otherwise
- = let
+ = do
+ dflags <- getDynFlags
+ let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
@@ -787,7 +792,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise = 1
-- depth of stack after the return value has been pushed
- d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+ d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
-- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the
@@ -821,8 +826,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise =
let
(ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
- ptr_sizes = map (fromIntegral . idSizeW) ptrs
- nptrs_sizes = map (fromIntegral . idSizeW) nptrs
+ ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs
+ nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs
bind_sizes = ptr_sizes ++ nptrs_sizes
size = sum ptr_sizes + sum nptrs_sizes
-- the UNPACK instruction unpacks in reverse order...
@@ -875,7 +880,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
bitmap_size = trunc16 $ d-s
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap bitmap_size'{-size-}
+ bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
(sort (filter (< bitmap_size') rel_slots))
where
binds = Map.toList p
@@ -886,13 +891,12 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise = []
where rel_offset = trunc16 $ d - fromIntegral offset - 1
- in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
let
alt_bco_name = getName bndr
- alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
+ alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
0{-no arity-} bitmap_size bitmap True{-is alts-}
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
@@ -923,10 +927,13 @@ generateCCall :: Word -> Sequel -- stack and sequel depths
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
- = let
+ = do
+ dflags <- getDynFlags
+
+ let
-- useful constants
addr_sizeW :: Word16
- addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
+ addr_sizeW = fromIntegral (cgRepSizeW dflags NonPtrArg)
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
@@ -942,14 +949,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- contains.
Just t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
- -> do dflags <- getDynFlags
- rest <- pargs (d + fromIntegral addr_sizeW) az
+ -> do rest <- pargs (d + fromIntegral addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
- -> do dflags <- getDynFlags
- rest <- pargs (d + fromIntegral addr_sizeW) az
+ -> do rest <- pargs (d + fromIntegral addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
@@ -970,11 +975,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- header and then pretend this is an Addr#.
return (push_fo `snocOL` SWIZZLE 0 hdrSize)
- in do
code_n_reps <- pargs d0 args_r_to_l
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
- a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l))
+ a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
push_args = concatOL pushs_arg
d_after_args = d0 + a_reps_sizeW
@@ -1029,8 +1033,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
- get_target_info
- = case target of
+ get_target_info = do
+ case target of
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
@@ -1041,11 +1045,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
return (True, res)
where
stdcall_adj_target
-#ifdef mingw32_TARGET_OS
- | StdCallConv <- cconv
- = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
+ | OSMinGW32 <- platformOS (targetPlatform dflags)
+ , StdCallConv <- cconv
+ = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
mkFastString (unpackFS target ++ '@':show size)
-#endif
| otherwise
= target
@@ -1069,7 +1072,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Push the return placeholder. For a call returning nothing,
-- this is a VoidArg (tag).
- r_sizeW = fromIntegral (primRepSizeW r_rep)
+ r_sizeW = fromIntegral (primRepSizeW dflags r_rep)
d_after_r = d_after_Addr + fromIntegral r_sizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
@@ -1087,7 +1090,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- the only difference in libffi mode is that we prepare a cif
-- describing the call type by calling libffi, and we attach the
-- address of this to the CCALL instruction.
- token <- ioToBc $ prepForeignCall cconv a_reps r_rep
+ token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
let addr_of_marshaller = castPtrToFunPtr token
recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
@@ -1214,8 +1217,11 @@ pushAtom d p (AnnVar v)
= return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
- = let l = trunc16 $ d - d_v + fromIntegral sz - 2
- in return (toOL (genericReplicate sz (PUSH_L l)), sz)
+ = do dflags <- getDynFlags
+ let sz :: Word16
+ sz = fromIntegral (idSizeW dflags v)
+ l = trunc16 $ d - d_v + fromIntegral sz - 2
+ return (toOL (genericReplicate sz (PUSH_L l)), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
--
@@ -1227,17 +1233,22 @@ pushAtom d p (AnnVar v)
-- Having found the last slot, we proceed to copy the right number of
-- slots on to the top of the stack.
- | otherwise -- v must be a global variable
- = ASSERT(sz == 1)
- return (unitOL (PUSH_G (getName v)), sz)
+ | otherwise -- v must be a global variable
+ = do dflags <- getDynFlags
+ let sz :: Word16
+ sz = fromIntegral (idSizeW dflags v)
+ MASSERT(sz == 1)
+ return (unitOL (PUSH_G (getName v)), sz)
- where
- sz :: Word16
- sz = fromIntegral (idSizeW v)
+pushAtom _ _ (AnnLit lit) = do
+ dflags <- getDynFlags
+ let code rep
+ = let size_host_words = fromIntegral (cgRepSizeW dflags rep)
+ in return (unitOL (PUSH_UBX (Left lit) size_host_words),
+ size_host_words)
-pushAtom _ _ (AnnLit lit)
- = case lit of
+ case lit of
MachLabel _ _ _ -> code NonPtrArg
MachWord _ -> code NonPtrArg
MachInt _ -> code NonPtrArg
@@ -1253,11 +1264,6 @@ pushAtom _ _ (AnnLit lit)
-- representation.
LitInteger {} -> panic "pushAtom: LitInteger"
where
- code rep
- = let size_host_words = fromIntegral (cgRepSizeW rep)
- in return (unitOL (PUSH_UBX (Left lit) size_host_words),
- size_host_words)
-
pushStr s
= let getMallocvilleAddr
= case s of
@@ -1430,8 +1436,8 @@ instance Outputable Discr where
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
lookupBCEnv_maybe = Map.lookup
-idSizeW :: Id -> Int
-idSizeW = cgRepSizeW . bcIdCgRep
+idSizeW :: DynFlags -> Id -> Int
+idSizeW dflags = cgRepSizeW dflags . bcIdCgRep
bcIdCgRep :: Id -> CgRep
bcIdCgRep = primRepToCgRep . bcIdPrimRep
diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index 9b22ec8cd6..2564d4b797 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -27,7 +27,6 @@ import ClosureInfo
import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Type ( flattenRepType, repType )
-import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE )
import CgHeapery ( mkVirtHeapOffsets )
import Util
@@ -49,14 +48,14 @@ import GHC.Ptr ( Ptr(..) )
\begin{code}
newtype ItblPtr = ItblPtr (Ptr ()) deriving Show
-itblCode :: ItblPtr -> Ptr ()
-itblCode (ItblPtr ptr)
- | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB
+itblCode :: DynFlags -> ItblPtr -> Ptr ()
+itblCode dflags (ItblPtr ptr)
+ | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags
| otherwise = castPtr ptr
-- XXX bogus
-conInfoTableSizeB :: Int
-conInfoTableSizeB = 3 * wORD_SIZE
+conInfoTableSizeB :: DynFlags -> Int
+conInfoTableSizeB dflags = 3 * wORD_SIZE dflags
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
@@ -106,8 +105,8 @@ make_constr_itbls dflags cons
ptrs' = ptr_wds
nptrs' = tot_wds - ptr_wds
nptrs_really
- | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE = nptrs'
- | otherwise = mIN_PAYLOAD_SIZE - ptrs'
+ | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
+ | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
code' = mkJumpToAddr entry_addr
itbl = StgInfoTable {
#ifndef GHCI_TABLES_NEXT_TO_CODE
@@ -128,7 +127,7 @@ make_constr_itbls dflags cons
}
-- Make a piece of code to jump to "entry_label".
-- This is the only arch-dependent bit.
- addrCon <- newExec pokeConItbl conInfoTbl
+ addrCon <- newExecConItbl dflags conInfoTbl
--putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
--putStrLn ("# ptrs of itbl is " ++ show ptrs)
--putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
@@ -285,39 +284,17 @@ data StgConInfoTable = StgConInfoTable {
infoTable :: StgInfoTable
}
-instance Storable StgConInfoTable where
- sizeOf conInfoTable
+sizeOfConItbl :: StgConInfoTable -> Int
+sizeOfConItbl conInfoTable
= sum [ sizeOf (conDesc conInfoTable)
, sizeOf (infoTable conInfoTable) ]
- alignment _ = SIZEOF_VOID_P
- peek ptr
- = evalState (castPtr ptr) $ do
-#ifdef GHCI_TABLES_NEXT_TO_CODE
- desc <- load
-#endif
- itbl <- load
-#ifndef GHCI_TABLES_NEXT_TO_CODE
- desc <- load
-#endif
- return
- StgConInfoTable
- {
-#ifdef GHCI_TABLES_NEXT_TO_CODE
- conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc
-#else
- conDesc = desc
-#endif
- , infoTable = itbl
- }
- poke = error "poke(StgConInfoTable): use pokeConItbl instead"
-
-pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
-pokeConItbl wr_ptr ex_ptr itbl
+pokeConItbl dflags wr_ptr ex_ptr itbl
= evalState (castPtr wr_ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
- store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB))
+ store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags))
#endif
store (infoTable itbl)
#ifndef GHCI_TABLES_NEXT_TO_CODE
@@ -443,12 +420,12 @@ load = do addr <- advance
lift (peek addr)
-newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ())
-newExec poke_fn obj
+newExecConItbl :: DynFlags -> StgConInfoTable -> IO (FunPtr ())
+newExecConItbl dflags obj
= alloca $ \pcode -> do
- wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode
+ wr_ptr <- _allocateExec (fromIntegral (sizeOfConItbl obj)) pcode
ex_ptr <- peek pcode
- poke_fn wr_ptr ex_ptr obj
+ pokeConItbl dflags wr_ptr ex_ptr obj
return (castPtrToFunPtr ex_ptr)
foreign import ccall unsafe "allocateExec"
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
index 8ceb91cfce..8938bfe4f1 100644
--- a/compiler/ghci/ByteCodeLink.lhs
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -20,6 +20,7 @@ import ByteCodeItbls
import ByteCodeAsm
import ObjLink
+import DynFlags
import Name
import NameEnv
import PrimOp
@@ -76,9 +77,9 @@ data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
ByteArray# -- itbls :: Array Addr#
-}
-linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
-linkBCO ie ce ul_bco
- = do BCO bco# <- linkBCO' ie ce ul_bco
+linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
+linkBCO dflags ie ce ul_bco
+ = do BCO bco# <- linkBCO' dflags ie ce ul_bco
-- SDM: Why do we need mkApUpd0 here? I *think* it's because
-- otherwise top-level interpreted CAFs don't get updated
-- after evaluation. A top-level BCO will evaluate itself and
@@ -97,18 +98,18 @@ linkBCO ie ce ul_bco
else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) }
-linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
+linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
+linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
-- Raises an IO exception on failure
= do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
- linked_literals <- mapM (lookupLiteral ie) literals
+ linked_literals <- mapM (lookupLiteral dflags ie) literals
let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS
- ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+ ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs
let
!ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
@@ -126,8 +127,8 @@ linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS)
-- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue)
-mkPtrsArray ie ce n_ptrs ptrs = do
+mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue)
+mkPtrsArray dflags ie ce n_ptrs ptrs = do
let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
marr <- newArray_ ptrRange
let
@@ -138,7 +139,7 @@ mkPtrsArray ie ce n_ptrs ptrs = do
ptr <- lookupPrimOp op
unsafeWrite marr i ptr
fill (BCOPtrBCO ul_bco) i = do
- BCO bco# <- linkBCO' ie ce ul_bco
+ BCO bco# <- linkBCO' dflags ie ce ul_bco
writeArrayBCO marr i bco#
fill (BCOPtrBreakInfo brkInfo) i =
unsafeWrite marr i (HValue (unsafeCoerce# brkInfo))
@@ -180,12 +181,12 @@ newBCO instrs lits ptrs arity bitmap
(# s1, bco #) -> (# s1, BCO bco #)
-lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
-lookupLiteral _ (BCONPtrWord lit) = return lit
-lookupLiteral _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
- return (W# (int2Word# (addr2Int# a#)))
-lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm
- return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word
+lookupLiteral _ _ (BCONPtrWord lit) = return lit
+lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
+ return (W# (int2Word# (addr2Int# a#)))
+lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm
+ return (W# (int2Word# (addr2Int# a#)))
lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string
@@ -218,10 +219,10 @@ lookupName ce nm
(# a #) -> return (HValue a)
Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
-lookupIE :: ItblEnv -> Name -> IO (Ptr a)
-lookupIE ie con_nm
+lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a)
+lookupIE dflags ie con_nm
= case lookupNameEnv ie con_nm of
- Just (_, a) -> return (castPtr (itblCode a))
+ Just (_, a) -> return (castPtr (itblCode dflags a))
Nothing
-> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index 19a3cbb721..cd46ec311e 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -14,7 +14,6 @@ import Module
import OccName
import Name
import Outputable
-import Constants
import MonadUtils ()
import Util
@@ -95,7 +94,7 @@ dataConInfoPtrToName x = do
getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
getConDescAddress dflags ptr
| ghciTablesNextToCode = do
- offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE dflags)
return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord))
| otherwise =
peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc
index 9bdabda0c2..128197109b 100644
--- a/compiler/ghci/LibFFI.hsc
+++ b/compiler/ghci/LibFFI.hsc
@@ -24,7 +24,7 @@ import TyCon
import ForeignCall
import Panic
-- import Outputable
-import Constants
+import DynFlags
import Foreign
import Foreign.C
@@ -35,20 +35,21 @@ import Text.Printf
type ForeignCallToken = C_ffi_cif
prepForeignCall
- :: CCallConv
+ :: DynFlags
+ -> CCallConv
-> [PrimRep] -- arg types
-> PrimRep -- result type
-> IO (Ptr ForeignCallToken) -- token for making calls
-- (must be freed by caller)
-prepForeignCall cconv arg_types result_type
+prepForeignCall dflags cconv arg_types result_type
= do
let n_args = length arg_types
arg_arr <- mallocArray n_args
- let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty)
+ let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType dflags ty)
mapM_ init_arg (zip arg_types [0..])
cif <- mallocBytes (#const sizeof(ffi_cif))
let abi = convToABI cconv
- let res_ty = primRepToFFIType result_type
+ let res_ty = primRepToFFIType dflags result_type
r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
if (r /= fFI_OK)
then ghcError (InstallationError
@@ -64,8 +65,8 @@ convToABI StdCallConv = fFI_STDCALL
convToABI _ = fFI_DEFAULT_ABI
-- c.f. DsForeign.primTyDescChar
-primRepToFFIType :: PrimRep -> Ptr C_ffi_type
-primRepToFFIType r
+primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type
+primRepToFFIType dflags r
= case r of
VoidRep -> ffi_type_void
IntRep -> signed_word
@@ -78,9 +79,9 @@ primRepToFFIType r
_ -> panic "primRepToFFIType"
where
(signed_word, unsigned_word)
- | wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32)
- | wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64)
- | otherwise = panic "primTyDescChar"
+ | wORD_SIZE dflags == 4 = (ffi_type_sint32, ffi_type_uint32)
+ | wORD_SIZE dflags == 8 = (ffi_type_sint64, ffi_type_uint64)
+ | otherwise = panic "primTyDescChar"
data C_ffi_type
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 7a5ca901bc..565cf0b8a8 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -44,7 +44,6 @@ import BasicTypes
import Outputable
import Panic
import Util
-import StaticFlags
import ErrUtils
import SrcLoc
import qualified Maybes
@@ -264,7 +263,7 @@ showLinkerState dflags
-- @-l@ options in @v_Opt_l@,
--
-- d) Loading any @.o\/.dll@ files specified on the command line, now held
--- in @v_Ld_inputs@,
+-- in @ldInputs@,
--
-- e) Loading any MacOS frameworks.
--
@@ -298,7 +297,7 @@ reallyInitDynLinker dflags =
; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls
-- (d) Link .o files from the command-line
- ; cmdline_ld_inputs <- readIORef v_Ld_inputs
+ ; let cmdline_ld_inputs = ldInputs dflags
; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs
@@ -458,7 +457,7 @@ linkExpr hsc_env span root_ul_bco
ce = closure_env pls
-- Link the necessary packages and linkables
- ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
+ ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco]
; return (pls, root_hval)
}}}
where
@@ -666,7 +665,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
ce = closure_env pls
-- Link the necessary packages and linkables
- (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs
+ (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs
let pls2 = pls { closure_env = final_gce,
itbl_env = ie }
return (pls2, ()) --hvals)
@@ -725,7 +724,7 @@ linkModules dflags pls linkables
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs pls1 bcos
+ pls2 <- dynLinkBCOs dflags pls1 bcos
return (pls2, Succeeded)
@@ -805,8 +804,9 @@ rmDupLinkables already ls
%************************************************************************
\begin{code}
-dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState
-dynLinkBCOs pls bcos = do
+dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable]
+ -> IO PersistentLinkerState
+dynLinkBCOs dflags pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -822,7 +822,7 @@ dynLinkBCOs pls bcos = do
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos
-- XXX What happens to these linked_bcos?
let pls2 = pls1 { closure_env = final_gce,
@@ -831,7 +831,8 @@ dynLinkBCOs pls bcos = do
return pls2
-- Link a bunch of BCOs and return them + updated closure env.
-linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
+linkSomeBCOs :: DynFlags
+ -> Bool -- False <=> add _all_ BCOs to returned closure env
-- True <=> add only toplevel BCOs to closure env
-> ItblEnv
-> ClosureEnv
@@ -841,11 +842,11 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs toplevs_only ie ce_in ul_bcos
+linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos
= do let nms = map unlinkedBCOName ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
- in mapM (linkBCO ie ce_out) ul_bcos )
+ in mapM (linkBCO dflags ie ce_out) ul_bcos )
let ce_all_additions = zip nms hvals
ce_top_additions = filter (isExternalName.fst) ce_all_additions
ce_additions = if toplevs_only then ce_top_additions
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index f06d120bc4..bf49a98a3b 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -60,7 +60,6 @@ import PrelNames
import TysWiredIn
import DynFlags
import Outputable as Ppr
-import Constants ( wORD_SIZE )
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO ( IO(..) )
@@ -172,8 +171,8 @@ pAP_CODE = PAP
#undef AP
#undef PAP
-getClosureData :: a -> IO Closure
-getClosureData a =
+getClosureData :: DynFlags -> a -> IO Closure
+getClosureData dflags a =
case unpackClosure# a of
(# iptr, ptrs, nptrs #) -> do
let iptr'
@@ -185,7 +184,7 @@ getClosureData a =
-- but the Storable instance for info tables takes
-- into account the extra entry pointer when
-- !ghciTablesNextToCode, so we must adjust here:
- Ptr iptr `plusPtr` negate wORD_SIZE
+ Ptr iptr `plusPtr` negate (wORD_SIZE dflags)
itbl <- peek iptr'
let tipe = readCType (BCI.tipe itbl)
elems = fromIntegral (BCI.ptrs itbl)
@@ -224,11 +223,11 @@ isThunk ThunkSelector = True
isThunk AP = True
isThunk _ = False
-isFullyEvaluated :: a -> IO Bool
-isFullyEvaluated a = do
- closure <- getClosureData a
+isFullyEvaluated :: DynFlags -> a -> IO Bool
+isFullyEvaluated dflags a = do
+ closure <- getClosureData dflags a
case tipe closure of
- Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
+ Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)
return$ and are_subs_evaluated
_ -> return False
where amapM f = sequence . amap' f
@@ -691,6 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Type obtained: " <> ppr (termType term))
return term
where
+ dflags = hsc_dflags hsc_env
go :: Int -> Type -> Type -> HValue -> TcM Term
-- [SPJ May 11] I don't understand the difference between my_ty and old_ty
@@ -699,13 +699,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
- clos <- trIO $ getClosureData a
+ clos <- trIO $ getClosureData dflags a
return (Suspension (tipe clos) my_ty a Nothing)
go max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
- clos <- trIO $ getClosureData a
+ clos <- trIO $ getClosureData dflags a
case tipe clos of
-- Thunks we may want to force
t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
@@ -818,7 +818,8 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
t <- appArr (recurse ty) (ptrs clos) ptr_i
return (ptr_i + 1, ws, t)
_ -> do
- let (ws0, ws1) = splitAt (primRepSizeW rep) ws
+ dflags <- getDynFlags
+ let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
return (ptr_i, ws1, Prim ty ws0)
unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms)))
@@ -855,6 +856,8 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
return new_ty
where
+ dflags = hsc_dflags hsc_env
+
-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
int max_depth <> text " steps")
@@ -869,7 +872,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
go :: Type -> HValue -> TR [(Type, HValue)]
go my_ty a = do
traceTR (text "go" <+> ppr my_ty)
- clos <- trIO $ getClosureData a
+ clos <- trIO $ getClosureData dflags a
case tipe clos of
Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
Indirection _ -> go my_ty $! (ptrs clos ! 0)