diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-09-17 13:09:22 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-09-17 13:09:22 +0100 |
| commit | b0db9308017fc14b600b3a85d9c55a037f12ee9e (patch) | |
| tree | b51b0b9d26b328b5e14e9d4d681219483f9c9b1f /compiler/ghci | |
| parent | 633dd5589f8625a8771ac75c5341ea225301d882 (diff) | |
| parent | 8c3b9aca3aaf946a91c9af6c07fc9d2afb6bbb76 (diff) | |
| download | haskell-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.lhs | 67 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeGen.lhs | 128 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeItbls.lhs | 57 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeLink.lhs | 39 | ||||
| -rw-r--r-- | compiler/ghci/DebuggerUtils.hs | 3 | ||||
| -rw-r--r-- | compiler/ghci/LibFFI.hsc | 21 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 25 | ||||
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 27 |
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) |
