summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs2
-rw-r--r--compiler/ghci/ByteCodeGen.lhs31
-rw-r--r--compiler/ghci/ByteCodeItbls.lhs27
-rw-r--r--compiler/ghci/DebuggerUtils.hs13
4 files changed, 40 insertions, 33 deletions
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 5e5a5f0c62..73724c007e 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -121,7 +121,7 @@ instance Outputable UnlinkedBCO where
-- Top level assembler fn.
assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
assembleBCOs dflags proto_bcos tycons
- = do itblenv <- mkITbls tycons
+ = do itblenv <- mkITbls dflags tycons
bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index a19d2ecf0b..b277a1ed30 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -84,8 +84,8 @@ byteCodeGen dflags this_mod binds tycs modBreaks
| (bndr, rhs) <- flattenBinds binds]
us <- mkSplitUniqSupply 'y'
- (BcM_State _us _this_mod _final_ctr mallocd _, proto_bcos)
- <- runBc us this_mod modBreaks (mapM schemeTopBind flatBinds)
+ (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
+ <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -115,8 +115,8 @@ coreExprToBCOs dflags this_mod expr
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
- (BcM_State _us _this_mod _final_ctr mallocd _ , proto_bco)
- <- runBc us this_mod emptyModBreaks $
+ (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
+ <- runBc dflags us this_mod emptyModBreaks $
schemeTopBind (invented_id, freeVars expr)
when (notNull mallocd)
@@ -942,13 +942,15 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- contains.
Just t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
- -> do rest <- pargs (d + fromIntegral addr_sizeW) az
- code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
+ -> do dflags <- getDynFlags
+ 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 rest <- pargs (d + fromIntegral addr_sizeW) az
- code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
+ -> do dflags <- getDynFlags
+ rest <- pargs (d + fromIntegral addr_sizeW) az
+ code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
-- Default case: push taggedly, but otherwise intact.
@@ -1526,7 +1528,8 @@ type BcPtr = Either ItblPtr (Ptr ())
data BcM_State
= BcM_State
- { uniqSupply :: UniqSupply -- for generating fresh variable names
+ { bcm_dflags :: DynFlags
+ , uniqSupply :: UniqSupply -- for generating fresh variable names
, thisModule :: Module -- current module (for breakpoints)
, nextlabel :: Word16 -- for generating local labels
, malloced :: [BcPtr] -- thunks malloced for current BCO
@@ -1541,9 +1544,10 @@ ioToBc io = BcM $ \st -> do
x <- io
return (st, x)
-runBc :: UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us this_mod modBreaks (BcM m)
- = m (BcM_State us this_mod 0 [] breakArray)
+runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
+ -> IO (BcM_State, r)
+runBc dflags us this_mod modBreaks (BcM m)
+ = m (BcM_State dflags us this_mod 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
@@ -1568,6 +1572,9 @@ instance Monad BcM where
(>>) = thenBc_
return = returnBc
+instance HasDynFlags BcM where
+ getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+
emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
emitBc bco
= BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
index 7378141e3d..9b22ec8cd6 100644
--- a/compiler/ghci/ByteCodeItbls.lhs
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -20,6 +20,7 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
#include "HsVersions.h"
+import DynFlags
import Name ( Name, getName )
import NameEnv
import ClosureInfo
@@ -66,31 +67,31 @@ mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
-- Make info tables for the data decls in this module
-mkITbls :: [TyCon] -> IO ItblEnv
-mkITbls [] = return emptyNameEnv
-mkITbls (tc:tcs) = do itbls <- mkITbl tc
- itbls2 <- mkITbls tcs
- return (itbls `plusNameEnv` itbls2)
-
-mkITbl :: TyCon -> IO ItblEnv
-mkITbl tc
+mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv
+mkITbls _ [] = return emptyNameEnv
+mkITbls dflags (tc:tcs) = do itbls <- mkITbl dflags tc
+ itbls2 <- mkITbls dflags tcs
+ return (itbls `plusNameEnv` itbls2)
+
+mkITbl :: DynFlags -> TyCon -> IO ItblEnv
+mkITbl dflags tc
| not (isDataTyCon tc)
= return emptyNameEnv
| dcs `lengthIs` n -- paranoia; this is an assertion.
- = make_constr_itbls dcs
+ = make_constr_itbls dflags dcs
where
dcs = tyConDataCons tc
n = tyConFamilySize tc
-mkITbl _ = error "Unmatched patter in mkITbl: assertion failed!"
+mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!"
#include "../includes/rts/storage/ClosureTypes.h"
cONSTR :: Int -- Defined in ClosureTypes.h
cONSTR = CONSTR
-- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: [DataCon] -> IO ItblEnv
-make_constr_itbls cons
+make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv
+make_constr_itbls dflags cons
= do is <- mapM mk_dirret_itbl (zip cons [0..])
return (mkItblEnv is)
where
@@ -100,7 +101,7 @@ make_constr_itbls cons
mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
mk_itbl dcon conNo entry_addr = do
let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
- (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
+ (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
ptrs' = ptr_wds
nptrs' = tot_wds - ptr_wds
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index 331c294973..19a3cbb721 100644
--- a/compiler/ghci/DebuggerUtils.hs
+++ b/compiler/ghci/DebuggerUtils.hs
@@ -36,9 +36,10 @@ import Data.List
--
dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
dataConInfoPtrToName x = do
+ dflags <- getDynFlags
theString <- liftIO $ do
let ptr = castPtr x :: Ptr StgInfoTable
- conDescAddress <- getConDescAddress ptr
+ conDescAddress <- getConDescAddress dflags ptr
peekArray0 0 conDescAddress
let (pkg, mod, occ) = parse theString
pkgFS = mkFastStringByteList pkg
@@ -46,7 +47,6 @@ dataConInfoPtrToName x = do
occFS = mkFastStringByteList occ
occName = mkOccNameFS OccName.dataName occFS
modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
- dflags <- getDynFlags
return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
`recoverM` (Right `fmap` lookupOrig modName occName)
@@ -92,14 +92,13 @@ dataConInfoPtrToName x = do
in the memory location: info_table_ptr + info_table_size
-}
- getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
- getConDescAddress ptr
+ getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
+ getConDescAddress dflags ptr
| ghciTablesNextToCode = do
offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
- return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+ return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord))
| otherwise =
- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
-
+ peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
-- parsing names is a little bit fiddly because we have a string in the form:
-- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
-- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
View Lorry Controller Status