summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeAsm.hs38
-rw-r--r--compiler/ghci/ByteCodeGen.hs570
-rw-r--r--compiler/ghci/ByteCodeInstr.hs58
-rw-r--r--compiler/ghci/ByteCodeItbls.hs2
-rw-r--r--compiler/ghci/ByteCodeLink.hs5
-rw-r--r--compiler/ghci/ByteCodeTypes.hs10
-rw-r--r--compiler/ghci/Debugger.hs20
-rw-r--r--compiler/ghci/DebuggerUtils.hs132
-rw-r--r--compiler/ghci/GHCi.hs (renamed from compiler/ghci/GHCi.hsc)44
-rw-r--r--compiler/ghci/Linker.hs339
-rw-r--r--compiler/ghci/RtClosureInspect.hs601
11 files changed, 1045 insertions, 774 deletions
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index a7395221ce..476a9b2efd 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -15,6 +15,8 @@ module ByteCodeAsm (
#include "HsVersions.h"
+import GhcPrelude
+
import ByteCodeInstr
import ByteCodeItbls
import ByteCodeTypes
@@ -123,9 +125,12 @@ mallocStrings hsc_env ulbcos = do
return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
spliceLit (BCONPtrStr _) = do
- (RemotePtr p : rest) <- get
- put rest
- return (BCONPtrWord (fromIntegral p))
+ rptrs <- get
+ case rptrs of
+ (RemotePtr p : rest) -> do
+ put rest
+ return (BCONPtrWord (fromIntegral p))
+ _ -> panic "mallocStrings:spliceLit"
spliceLit other = return other
splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
@@ -349,6 +354,12 @@ assembleI dflags i = case i of
PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
+ PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1]
+ PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1]
+ PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1]
+ PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1]
+ PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1]
+ PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1]
PUSH_G nm -> do p <- ptr (BCOPtrName nm)
emit bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
@@ -363,6 +374,15 @@ assembleI dflags i = case i of
-> do let ul_bco = assembleBCO dflags proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
+ PUSH_PAD8 -> emit bci_PUSH_PAD8 []
+ PUSH_PAD16 -> emit bci_PUSH_PAD16 []
+ PUSH_PAD32 -> emit bci_PUSH_PAD32 []
+ PUSH_UBX8 lit -> do np <- literal lit
+ emit bci_PUSH_UBX8 [Op np]
+ PUSH_UBX16 lit -> do np <- literal lit
+ emit bci_PUSH_UBX16 [Op np]
+ PUSH_UBX32 lit -> do np <- literal lit
+ emit bci_PUSH_UBX32 [Op np]
PUSH_UBX lit nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws]
@@ -427,17 +447,19 @@ assembleI dflags i = case i of
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
literal (MachLabel fs _ _) = litlabel fs
- literal (MachWord w) = int (fromIntegral w)
- literal (MachInt j) = int (fromIntegral j)
literal MachNullAddr = int 0
literal (MachFloat r) = float (fromRational r)
literal (MachDouble r) = double (fromRational r)
literal (MachChar c) = int (ord c)
- literal (MachInt64 ii) = int64 (fromIntegral ii)
- literal (MachWord64 ii) = int64 (fromIntegral ii)
literal (MachStr bs) = lit [BCONPtrStr bs]
-- MachStr requires a zero-terminator when emitted
- literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger"
+ literal (LitNumber nt i _) = case nt of
+ LitNumInt -> int (fromIntegral i)
+ LitNumWord -> int (fromIntegral i)
+ LitNumInt64 -> int64 (fromIntegral i)
+ LitNumWord64 -> int64 (fromIntegral i)
+ LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+ LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 2695a98f9e..022fe89306 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -9,6 +10,8 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
#include "HsVersions.h"
+import GhcPrelude
+
import ByteCodeInstr
import ByteCodeAsm
import ByteCodeTypes
@@ -43,8 +46,9 @@ import ErrUtils
import Unique
import FastString
import Panic
-import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW )
-import SMRep
+import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds )
+import StgCmmLayout
+import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap
import OrdList
import Maybes
@@ -68,11 +72,8 @@ import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified FiniteMap as Map
import Data.Ord
-#if MIN_VERSION_base(4,9,0)
import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
+import Data.Either ( partitionEithers )
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
@@ -89,10 +90,10 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
(const ()) $ do
-- Split top-level binds into strings and others.
-- See Note [generating code for top-level string literal bindings].
- let (strings, flatBinds) = splitEithers $ do
+ let (strings, flatBinds) = partitionEithers $ do
(bndr, rhs) <- flattenBinds binds
- return $ case rhs of
- Lit (MachStr str) -> Left (bndr, str)
+ return $ case exprIsTickedString_maybe rhs of
+ Just str -> Left (bndr, str)
_ -> Right (bndr, simpleFreeVars rhs)
stringPtrs <- allocateTopStrings hsc_env strings
@@ -209,11 +210,33 @@ simpleFreeVars = go . freeVars
type BCInstrList = OrdList BCInstr
-type Sequel = Word -- back off to this depth before ENTER
+newtype ByteOff = ByteOff Int
+ deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+newtype WordOff = WordOff Int
+ deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+wordsToBytes :: DynFlags -> WordOff -> ByteOff
+wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
+
+-- Used when we know we have a whole number of words
+bytesToWords :: DynFlags -> ByteOff -> WordOff
+bytesToWords dflags (ByteOff bytes) =
+ let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
+ in if r == 0
+ then fromIntegral q
+ else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes
+
+wordSize :: DynFlags -> ByteOff
+wordSize dflags = ByteOff (wORD_SIZE dflags)
+
+type Sequel = ByteOff -- back off to this depth before ENTER
+
+type StackDepth = ByteOff
-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
-- it after each push/pop.
-type BCEnv = Map Id Word -- To find vars on the stack
+type BCEnv = Map Id StackDepth -- To find vars on the stack
{-
ppBCEnv :: BCEnv -> SDoc
@@ -296,8 +319,6 @@ argBits dflags (rep : args)
-- Compile code for the right-hand side of a top-level binding
schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
-
-
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
@@ -358,7 +379,12 @@ collect (_, e) = go [] e
= go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk
+ :: [Id]
+ -> Id
+ -> AnnExpr Id DVarSet
+ -> ([Var], AnnExpr' Var DVarSet)
+ -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
dflags <- getDynFlags
@@ -369,27 +395,30 @@ schemeR_wrk fvs nm original_body (args, body)
-- \fv1..fvn x1..xn -> e
-- i.e. the fvs come first
- szsw_args = map (fromIntegral . idSizeW dflags) all_args
- szw_args = sum szsw_args
- p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
+ -- Stack arguments always take a whole number of words, we never pack
+ -- them unlike constructor fields.
+ szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
+ sum_szsb_args = sum szsb_args
+ p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
-- make the arg bitmap
bits = argBits dflags (reverse (map bcIdArgRep all_args))
bitmap_size = genericLength bits
bitmap = mkBitmap dflags bits
- body_code <- schemeER_wrk szw_args p_init body
+ body_code <- schemeER_wrk sum_szsb_args p_init body
emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
-schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
- = do code <- schemeE (fromIntegral d) 0 p newRhs
+ = do code <- schemeE d 0 p newRhs
cc_arr <- getCCArray
this_mod <- moduleName <$> getCurrentModule
- let idOffSets = getVarOffSets d p fvs
+ dflags <- getDynFlags
+ let idOffSets = getVarOffSets dflags d p fvs
let breakInfo = CgBreakInfo
{ cgb_vars = idOffSets
, cgb_resty = exprType (deAnnotate' newRhs)
@@ -400,10 +429,10 @@ schemeER_wrk d p rhs
| otherwise = toRemotePtr nullPtr
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
- | otherwise = schemeE (fromIntegral d) 0 p rhs
+ | otherwise = schemeE d 0 p rhs
-getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
-getVarOffSets depth env = catMaybes . map getOffSet
+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets dflags depth env = catMaybes . map getOffSet
where
getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
@@ -415,16 +444,23 @@ getVarOffSets depth env = catMaybes . map getOffSet
-- this "adjustment" is needed due to stack manipulation for
-- BRK_FUN in Interpreter.c In any case, this is used only when
-- we trigger a breakpoint.
- let adjustment = 2
- in Just (id, trunc16 $ depth - offset + adjustment)
+ let !var_depth_ws =
+ trunc16W $ bytesToWords dflags (depth - offset) + 2
+ in Just (id, var_depth_ws)
-trunc16 :: Word -> Word16
-trunc16 w
+truncIntegral16 :: Integral a => a -> Word16
+truncIntegral16 w
| w > fromIntegral (maxBound :: Word16)
= panic "stack depth overflow"
| otherwise
= fromIntegral w
+trunc16B :: ByteOff -> Word16
+trunc16B = truncIntegral16
+
+trunc16W :: WordOff -> Word16
+trunc16W = truncIntegral16
+
fvsToEnv :: BCEnv -> DVarSet -> [Id]
-- Takes the free variables of a right-hand side, and
-- delivers an ordered list of the local variables that will
@@ -441,21 +477,26 @@ fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
-- -----------------------------------------------------------------------------
-- schemeE
-returnUnboxedAtom :: Word -> Sequel -> BCEnv
- -> AnnExpr' Id DVarSet -> ArgRep
- -> BcM BCInstrList
+returnUnboxedAtom
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> AnnExpr' Id DVarSet
+ -> ArgRep
+ -> BcM BCInstrList
-- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
-returnUnboxedAtom d s p e e_rep
- = do (push, szw) <- pushAtom d p e
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX e_rep) -- go
+returnUnboxedAtom d s p e e_rep = do
+ dflags <- getDynFlags
+ (push, szb) <- pushAtom d p e
+ return (push -- value onto stack
+ `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
+ `snocOL` RETURN_UBX e_rep) -- go
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
-schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-
+schemeE
+ :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
schemeE d s p e
| Just e' <- bcView e
= schemeE d s p e'
@@ -478,7 +519,8 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- saturated constructor application.
-- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
- let !d2 = d + 1
+ dflags <- getDynFlags
+ let !d2 = d + wordSize dflags
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
@@ -493,28 +535,39 @@ schemeE d s p (AnnLet binds (_,body)) = do
fvss = map (fvsToEnv p' . fst) rhss
-- Sizes of free vars
- sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
+ size_w = trunc16W . idSizeW dflags
+ sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
- -- are ptrs, so all have size 1. d' and p' reflect the stack
+ -- are ptrs, so all have size 1 word. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
- p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
- d' = d + fromIntegral n_binds
- zipE = zipEqual "schemeE"
+ offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
+ p' = Map.insertList (zipE xs offsets) p
+ d' = d + wordsToBytes dflags n_binds
+ zipE = zipEqual "schemeE"
-- ToDo: don't build thunks for things with no free variables
+ build_thunk
+ :: StackDepth
+ -> [Id]
+ -> Word16
+ -> ProtoBCO Name
+ -> Word16
+ -> Word16
+ -> BcM BCInstrList
build_thunk _ [] size bco off arity
= return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
where
mkap | arity == 0 = MKAP
| otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
- (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
- more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
+ (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
+ more_push_code <-
+ build_thunk (dd + pushed_szb) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
@@ -532,7 +585,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
build_thunk d' fvs size bco off arity
compile_binds =
- [ compile_bind d' fvs x rhs size arity n
+ [ compile_bind d' fvs x rhs size arity (trunc16W n)
| (fvs, x, rhs, size, arity, n) <-
zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
]
@@ -661,7 +714,7 @@ schemeE _ _ _ expr
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
-schemeT :: Word -- Stack depth
+schemeT :: StackDepth -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
-> AnnExpr' Id DVarSet
@@ -669,12 +722,6 @@ schemeT :: Word -- Stack depth
schemeT d s p app
--- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
--- = panic "schemeT ?!?!"
-
--- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
--- = error "?!?!"
-
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call app
= implement_tagToId d s p arg constr_names
@@ -699,8 +746,9 @@ schemeT d s p app
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
+ dflags <- getDynFlags
return (alloc_con `appOL`
- mkSLIDE 1 (d - s) `snocOL`
+ mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
ENTER)
-- Case 4: Tail call of function
@@ -725,33 +773,48 @@ schemeT d s p app
-- Generate code to build a constructor application,
-- leaving it on top of the stack
-mkConAppCode :: Word -> Sequel -> BCEnv
- -> DataCon -- The data constructor
- -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
- -> BcM BCInstrList
-
+mkConAppCode
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
mkConAppCode _ _ _ con [] -- Nullary constructor
= ASSERT( isNullaryRepDataCon con )
return (unitOL (PUSH_G (getName (dataConWorkId con))))
-- Instead of doing a PACK, which would allocate a fresh
-- copy of this constructor, use the single shared version.
-mkConAppCode orig_d _ p con args_r_to_l
- = ASSERT( args_r_to_l `lengthIs` dataConRepArity con )
- do_pushery orig_d (non_ptr_args ++ ptr_args)
- where
- -- The args are already in reverse order, which is the way PACK
- -- expects them to be. We must push the non-ptrs after the ptrs.
- (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
+mkConAppCode orig_d _ p con args_r_to_l =
+ ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
+ where
+ app_code = do
+ dflags <- getDynFlags
- do_pushery d (arg:args)
- = do (push, arg_words) <- pushAtom d p arg
- more_push_code <- do_pushery (d + fromIntegral arg_words) args
- return (push `appOL` more_push_code)
- do_pushery d []
- = return (unitOL (PACK con n_arg_words))
- where
- n_arg_words = trunc16 $ d - orig_d
+ -- The args are initially in reverse order, but mkVirtHeapOffsets
+ -- expects them to be left-to-right.
+ let non_voids =
+ [ NonVoid (prim_rep, arg)
+ | arg <- reverse args_r_to_l
+ , let prim_rep = atomPrimRep arg
+ , not (isVoidRep prim_rep)
+ ]
+ (_, _, args_offsets) =
+ mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
+
+ do_pushery !d (arg : args) = do
+ (push, arg_bytes) <- case arg of
+ (Padding l _) -> pushPadding l
+ (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
+ more_push_code <- do_pushery (d + arg_bytes) args
+ return (push `appOL` more_push_code)
+ do_pushery !d [] = do
+ let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)
+ return (unitOL (PACK con n_arg_words))
+
+ -- Push on the stack in the reverse order.
+ do_pushery orig_d (reverse args_offsets)
-- -----------------------------------------------------------------------------
@@ -762,39 +825,41 @@ mkConAppCode orig_d _ p con args_r_to_l
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
- :: Word -> Sequel -> BCEnv
- -> AnnExpr' Id DVarSet -> BcM BCInstrList
+ :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
doTailCall
- :: Word -> Sequel -> BCEnv
- -> Id -> [AnnExpr' Id DVarSet]
- -> BcM BCInstrList
-doTailCall init_d s p fn args
- = do_pushes init_d args (map atomRep args)
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> Id
+ -> [AnnExpr' Id DVarSet]
+ -> BcM BCInstrList
+doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
where
- do_pushes d [] reps = do
+ do_pushes !d [] reps = do
ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- ASSERT( sz == 1 ) return ()
- return (push_fn `appOL` (
- mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
- unitOL ENTER))
- do_pushes d args reps = do
+ dflags <- getDynFlags
+ ASSERT( sz == wordSize dflags ) return ()
+ let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
+ return (push_fn `appOL` (slide `appOL` unitOL ENTER))
+ do_pushes !d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
(these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
- instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ dflags <- getDynFlags
+ instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
-- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
(push_code, sz) <- pushAtom d p arg
- (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
+ (final_d, more_push_code) <- push_seq (d + sz) args
return (final_d, push_code `appOL` more_push_code)
-- v. similar to CgStackery.findMatch, ToDo: merge
@@ -827,10 +892,16 @@ findPushSeq _
-- -----------------------------------------------------------------------------
-- Case expressions
-doCase :: Word -> Sequel -> BCEnv
- -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
- -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
- -> BcM BCInstrList
+doCase
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> AnnExpr Id DVarSet
+ -> Id
+ -> [AnnAlt Id DVarSet]
+ -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder,
+ -- don't enter the result
+ -> BcM BCInstrList
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| typePrimRep (idType bndr) `lengthExceeds` 1
= multiValException
@@ -846,30 +917,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl.
- ret_frame_sizeW :: Word
- ret_frame_sizeW = 2
+ ret_frame_size_b :: StackDepth
+ ret_frame_size_b = 2 * wordSize dflags
-- The extra frame we push to save/restor the CCCS when profiling
- save_ccs_sizeW | profiling = 2
- | otherwise = 0
+ save_ccs_size_b | profiling = 2 * wordSize dflags
+ | otherwise = 0
-- An unlifted value gets an extra info table pushed on top
-- when it is returned.
- unlifted_itbl_sizeW :: Word
- unlifted_itbl_sizeW | isAlgCase = 0
- | otherwise = 1
+ unlifted_itbl_size_b :: StackDepth
+ unlifted_itbl_size_b | isAlgCase = 0
+ | otherwise = wordSize dflags
-- depth of stack after the return value has been pushed
- d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
+ d_bndr =
+ d + ret_frame_size_b + wordsToBytes dflags (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
-- continuation.
- d_alts = d_bndr + unlifted_itbl_sizeW
+ d_alts = d_bndr + unlifted_itbl_size_b
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
p_alts0 = Map.insert bndr d_bndr p
+
p_alts = case is_unboxed_tuple of
Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
Nothing -> p_alts0
@@ -887,23 +960,32 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
+ -- If an alt attempts to match on an unboxed tuple or sum, we must
+ -- bail out, as the bytecode compiler can't handle them.
+ -- (See Trac #14608.)
+ | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
+ = multiValException
-- algebraic alt with some binders
| otherwise =
- let
- (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
- 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...
+ let (tot_wds, _ptrs_wds, args_offsets) =
+ mkVirtHeapOffsets dflags NoHeader
+ [ NonVoid (bcIdPrimRep id, id)
+ | NonVoid id <- nonVoidIds real_bndrs
+ ]
+ size = WordOff tot_wds
+
+ stack_bot = d_alts + wordsToBytes dflags size
+
+ -- convert offsets from Sp into offsets into the virtual stack
p' = Map.insertList
- (zip (reverse (ptrs ++ nptrs))
- (mkStackOffsets d_alts (reverse bind_sizes)))
+ [ (arg, stack_bot - ByteOff offset)
+ | (NonVoid arg, offset) <- args_offsets ]
p_alts
in do
MASSERT(isAlgCase)
- rhs_code <- schemeE (d_alts + size) s p' rhs
- return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
+ rhs_code <- schemeE stack_bot s p' rhs
+ return (my_discr alt,
+ unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
where
real_bndrs = filterOut isTyVar bndrs
@@ -914,8 +996,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
my_discr (LitAlt l, _, _)
- = case l of MachInt i -> DiscrI (fromInteger i)
- MachWord w -> DiscrW (fromInteger w)
+ = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i)
+ LitNumber LitNumWord w _ -> DiscrW (fromInteger w)
MachFloat r -> DiscrF (fromRational r)
MachDouble r -> DiscrD (fromRational r)
MachChar i -> DiscrI (ord i)
@@ -942,7 +1024,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- really want a bitmap up to depth (d-s). This affects compilation of
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
- bitmap_size = trunc16 $ d-s
+ bitmap_size = trunc16W $ bytesToWords dflags (d - s)
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
@@ -954,7 +1036,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
rel_slots = nub $ map fromIntegral $ concat (map spread binds)
spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
| otherwise = []
- where rel_offset = trunc16 $ d - fromIntegral offset
+ where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
@@ -966,8 +1048,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
- scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
- (d + ret_frame_sizeW + save_ccs_sizeW)
+ scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
+ (d + ret_frame_size_b + save_ccs_size_b)
p scrut
alt_bco' <- emitBc alt_bco
let push_alts
@@ -985,27 +1067,30 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.
-generateCCall :: Word -> Sequel -- stack and sequel depths
- -> BCEnv
- -> CCallSpec -- where to call
- -> Id -- of target, for type info
- -> [AnnExpr' Id DVarSet] -- args (atoms)
- -> BcM BCInstrList
-
+generateCCall
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id DVarSet] -- args (atoms)
+ -> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
= do
dflags <- getDynFlags
let
-- useful constants
- addr_sizeW :: Word16
- addr_sizeW = fromIntegral (argRepSizeW dflags N)
+ addr_size_b :: ByteOff
+ addr_size_b = wordSize dflags
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
-- depth to the first word of the bits for that arg, and the
-- ArgRep of what was actually pushed.
+ pargs
+ :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
pargs _ [] = return []
pargs d (a:az)
= let arg_ty = unwrapType (exprType (deAnnotate' a))
@@ -1015,31 +1100,35 @@ 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
+ -> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
| t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
- -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+ -> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
- -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+ -> do rest <- pargs (d + addr_size_b) az
code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
return ((code,AddrRep):rest)
-- Default case: push taggedly, but otherwise intact.
_
-> do (code_a, sz_a) <- pushAtom d p a
- rest <- pargs (d + fromIntegral sz_a) az
+ rest <- pargs (d + sz_a) az
return ((code_a, atomPrimRep a) : rest)
-- Do magic for Ptr/Byte arrays. Push a ptr to the array on
-- the stack but then advance it over the headers, so as to
-- point to the payload.
- parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
- -> BcM BCInstrList
+ parg_ArrayishRep
+ :: Word16
+ -> StackDepth
+ -> BCEnv
+ -> AnnExpr' Id DVarSet
+ -> BcM BCInstrList
parg_ArrayishRep hdrSize d p a
= do (push_fo, _) <- pushAtom d p a
-- The ptr points at the header. Advance it over the
@@ -1049,10 +1138,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
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 dflags) a_reps_pushed_r_to_l))
+ a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
push_args = concatOL pushs_arg
- d_after_args = d0 + a_reps_sizeW
+ !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
= panic "ByteCodeGen.generateCCall: missing or invalid World token?"
@@ -1104,6 +1193,7 @@ 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
+ maybe_static_target :: Maybe Literal
maybe_static_target =
case target of
DynamicTarget -> Nothing
@@ -1132,18 +1222,18 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- push the Addr#
(push_Addr, d_after_Addr)
| Just machlabel <- maybe_static_target
- = (toOL [PUSH_UBX machlabel addr_sizeW],
- d_after_args + fromIntegral addr_sizeW)
+ = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
| otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
-- this is a V (tag).
- r_sizeW = fromIntegral (primRepSizeW dflags r_rep)
- d_after_r = d_after_Addr + fromIntegral r_sizeW
- push_r = (if returns_void
- then nilOL
- else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
+ r_sizeW = repSizeWords dflags r_rep
+ d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
+ push_r =
+ if returns_void
+ then nilOL
+ else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
-- generate the marshalling code we're going to call
@@ -1151,7 +1241,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- instruction needs to describe the chunk of stack containing
-- the ccall args to the GC, so it needs to know how large it
-- is. See comment in Interpreter.c with the CCALL instruction.
- stk_offset = trunc16 $ d_after_r - s
+ stk_offset = trunc16W $ bytesToWords dflags (d_after_r - s)
conv = case cconv of
CCallConv -> FFICCall
@@ -1178,7 +1268,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
PlayRisky -> 0x2
-- slide and return
- wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
+ d_after_r_min_s = bytesToWords dflags (d_after_r - s)
+ wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
`snocOL` RETURN_UBX (toArgRep r_rep)
--trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
return (
@@ -1206,16 +1297,16 @@ primRepToFFIType dflags r
-- Make a dummy literal, to be used as a placeholder for FFI return
-- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
-mkDummyLiteral pr
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
= case pr of
- IntRep -> MachInt 0
- WordRep -> MachWord 0
+ IntRep -> mkMachInt dflags 0
+ WordRep -> mkMachWord dflags 0
+ Int64Rep -> mkMachInt64 0
+ Word64Rep -> mkMachWord64 0
AddrRep -> MachNullAddr
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
- Int64Rep -> MachInt64 0
- Word64Rep -> MachWord64 0
_ -> pprPanic "mkDummyLiteral" (ppr pr)
@@ -1311,18 +1402,25 @@ a 1-word null. See Trac #8383.
-}
-implement_tagToId :: Word -> Sequel -> BCEnv
- -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
+implement_tagToId
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> AnnExpr' Id DVarSet
+ -> [Name]
+ -> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId d s p arg names
= ASSERT( notNull names )
- do (push_arg, arg_words) <- pushAtom d p arg
+ do (push_arg, arg_bytes) <- pushAtom d p arg
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
+ dflags <- getDynFlags
let infos = zip4 labels (tail labels ++ [label_fail])
[0 ..] names
steps = map (mkStep label_exit) infos
+ slide_ws = bytesToWords dflags (d - s + arg_bytes)
return (push_arg
`appOL` unitOL (PUSH_UBX MachNullAddr 1)
@@ -1330,10 +1428,10 @@ implement_tagToId d s p arg names
`appOL` concatOL steps
`appOL` toOL [ LABEL label_fail, CASEFAIL,
LABEL label_exit ]
- `appOL` mkSLIDE 1 (d - s + fromIntegral arg_words + 1)
+ `appOL` mkSlideW 1 (slide_ws + 1)
-- "+1" to account for bogus word
-- (see Note [Implementing tagToEnum#])
- `appOL` unitOL ENTER)
+ `appOL` unitOL ENTER)
where
mkStep l_exit (my_label, next_label, n, name_for_n)
= toOL [LABEL my_label,
@@ -1355,8 +1453,8 @@ implement_tagToId d s p arg names
-- to 5 and not to 4. Stack locations are numbered from zero, so a
-- depth 6 stack has valid words 0 .. 5.
-pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
-
+pushAtom
+ :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
pushAtom d p e
| Just e' <- bcView e
= pushAtom d p e'
@@ -1370,22 +1468,34 @@ pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
= pushAtom d p a
-pushAtom d p (AnnVar v)
- | [] <- typePrimRep (idType v)
+pushAtom d p (AnnVar var)
+ | [] <- typePrimRep (idType var)
= return (nilOL, 0)
- | isFCallId v
- = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
+ | isFCallId var
+ = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)
- | Just primop <- isPrimOpId_maybe v
- = return (unitOL (PUSH_PRIMOP primop), 1)
+ | Just primop <- isPrimOpId_maybe var
+ = do
+ dflags <-getDynFlags
+ return (unitOL (PUSH_PRIMOP primop), wordSize dflags)
- | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
+ | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable
= do dflags <- getDynFlags
- let sz :: Word16
- sz = fromIntegral (idSizeW dflags v)
- l = trunc16 $ d - d_v + fromIntegral sz - 1
- return (toOL (genericReplicate sz (PUSH_L l)), sz)
+
+ let !szb = idSizeCon dflags var
+ with_instr instr = do
+ let !off_b = trunc16B $ d - d_v
+ return (unitOL (instr off_b), wordSize dflags)
+
+ case szb of
+ 1 -> with_instr PUSH8_W
+ 2 -> with_instr PUSH16_W
+ 4 -> with_instr PUSH32_W
+ _ -> do
+ let !szw = bytesToWords dflags szb
+ !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
+ return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
-- d - d_v offset from TOS to the first slot of the object
--
-- d - d_v + sz - 1 offset from the TOS of the last slot of the object
@@ -1393,47 +1503,78 @@ 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
+ | otherwise -- var must be a global variable
= do topStrings <- getTopStrings
- case lookupVarEnv topStrings v of
- Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
- ptrToWordPtr $ fromRemotePtr ptr
+ dflags <- getDynFlags
+ case lookupVarEnv topStrings var of
+ Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
+ fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
- dflags <- getDynFlags
- let sz :: Word16
- sz = fromIntegral (idSizeW dflags v)
- MASSERT(sz == 1)
- return (unitOL (PUSH_G (getName v)), sz)
+ let sz = idSizeCon dflags var
+ MASSERT( sz == wordSize dflags )
+ return (unitOL (PUSH_G (getName var)), sz)
pushAtom _ _ (AnnLit lit) = do
dflags <- getDynFlags
let code rep
- = let size_host_words = fromIntegral (argRepSizeW dflags rep)
- in return (unitOL (PUSH_UBX lit size_host_words),
- size_host_words)
+ = let size_words = WordOff (argRepSizeW dflags rep)
+ in return (unitOL (PUSH_UBX lit (trunc16W size_words)),
+ wordsToBytes dflags size_words)
case lit of
MachLabel _ _ _ -> code N
- MachWord _ -> code N
- MachInt _ -> code N
- MachWord64 _ -> code L
- MachInt64 _ -> code L
MachFloat _ -> code F
MachDouble _ -> code D
MachChar _ -> code N
MachNullAddr -> code N
MachStr _ -> code N
- -- No LitInteger's should be left by the time this is called.
- -- CorePrep should have converted them all to a real core
- -- representation.
- LitInteger {} -> panic "pushAtom: LitInteger"
+ LitNumber nt _ _ -> case nt of
+ LitNumInt -> code N
+ LitNumWord -> code N
+ LitNumInt64 -> code L
+ LitNumWord64 -> code L
+ -- No LitInteger's or LitNatural's should be left by the time this is
+ -- called. CorePrep should have converted them all to a real core
+ -- representation.
+ LitNumInteger -> panic "pushAtom: LitInteger"
+ LitNumNatural -> panic "pushAtom: LitNatural"
pushAtom _ _ expr
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate' expr))
+-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
+-- This is slightly different to @pushAtom@ due to the fact that we allow
+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
+pushConstrAtom
+ :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
+
+pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) =
+ return (unitOL (PUSH_UBX32 lit), 4)
+
+pushConstrAtom d p (AnnVar v)
+ | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
+ dflags <- getDynFlags
+ let !szb = idSizeCon dflags v
+ done instr = do
+ let !off = trunc16B $ d - d_v
+ return (unitOL (instr off), szb)
+ case szb of
+ 1 -> done PUSH8
+ 2 -> done PUSH16
+ 4 -> done PUSH32
+ _ -> pushAtom d p (AnnVar v)
+
+pushConstrAtom d p expr = pushAtom d p expr
+
+pushPadding :: Int -> BcM (BCInstrList, ByteOff)
+pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
+pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
+pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
+pushPadding x = panic $ "pushPadding x=" ++ show x
+
-- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
@@ -1572,11 +1713,14 @@ instance Outputable Discr where
ppr NoDiscr = text "DEF"
-lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
lookupBCEnv_maybe = Map.lookup
-idSizeW :: DynFlags -> Id -> Int
-idSizeW dflags = argRepSizeW dflags . bcIdArgRep
+idSizeW :: DynFlags -> Id -> WordOff
+idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
+
+idSizeCon :: DynFlags -> Id -> ByteOff
+idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
bcIdArgRep :: Id -> ArgRep
bcIdArgRep = toArgRep . bcIdPrimRep
@@ -1588,6 +1732,9 @@ bcIdPrimRep id
| otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+repSizeWords :: DynFlags -> PrimRep -> WordOff
+repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
+
isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
isFollowableArg _ = False
@@ -1618,19 +1765,25 @@ unsupportedCConvException = throwGhcException (ProgramError
("Error: bytecode compiler can't handle some foreign calling conventions\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
-mkSLIDE :: Word16 -> Word -> OrdList BCInstr
-mkSLIDE n d
- -- if the amount to slide doesn't fit in a word,
- -- generate multiple slide instructions
- | d > fromIntegral limit
- = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
- | d == 0
+mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr
+mkSlideB dflags !nb !db = mkSlideW n d
+ where
+ !n = trunc16W $ bytesToWords dflags nb
+ !d = bytesToWords dflags db
+
+mkSlideW :: Word16 -> WordOff -> OrdList BCInstr
+mkSlideW !n !ws
+ | ws > fromIntegral limit
+ -- If the amount to slide doesn't fit in a Word16, generate multiple slide
+ -- instructions
+ = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)
+ | ws == 0
= nilOL
| otherwise
- = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
- where
- limit :: Word16
- limit = maxBound
+ = unitOL (SLIDE n $ fromIntegral ws)
+ where
+ limit :: Word16
+ limit = maxBound
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
-- The arguments are returned in *right-to-left* order
@@ -1676,14 +1829,11 @@ atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
atomRep :: AnnExpr' Id ann -> ArgRep
atomRep e = toArgRep (atomPrimRep e)
-isPtrAtom :: AnnExpr' Id ann -> Bool
-isPtrAtom e = isFollowableArg (atomRep e)
-
--- | Let szsw be the sizes in words of some items pushed onto the stack, which
+-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
-- has initial depth @original_depth@. Return the values which the stack
-- environment should map these items to.
-mkStackOffsets :: Word -> [Word] -> [Word]
-mkStackOffsets original_depth szsw = tail (scanl' (+) original_depth szsw)
+mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
+mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
typeArgRep :: Type -> ArgRep
typeArgRep = toArgRep . typePrimRep1
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index 525280290f..07dcd2222a 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -12,6 +12,8 @@ module ByteCodeInstr (
#include "HsVersions.h"
#include "../includes/MachDeps.h"
+import GhcPrelude
+
import ByteCodeTypes
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
@@ -30,11 +32,7 @@ import PrimOp
import SMRep
import Data.Word
-#if MIN_VERSION_base(4,9,0)
import GHC.Stack.CCS (CostCentre)
-#else
-import GHC.Stack (CostCentre)
-#endif
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -64,6 +62,23 @@ data BCInstr
| PUSH_LL !Word16 !Word16{-2 offsets-}
| PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
+ -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
+ -- the stack will grow by 8, 16 or 32 bits)
+ | PUSH8 !Word16
+ | PUSH16 !Word16
+ | PUSH32 !Word16
+
+ -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
+ -- value will take the whole word on the stack (i.e., the stack will gorw by
+ -- a word)
+ -- This is useful when extracting a packed constructor field for further use.
+ -- Currently we expect all values on the stack to take full words, except for
+ -- the ones used for PACK (i.e., actually constracting new data types, in
+ -- which case we use PUSH{8,16,32})
+ | PUSH8_W !Word16
+ | PUSH16_W !Word16
+ | PUSH32_W !Word16
+
-- Push a ptr (these all map to PUSH_G really)
| PUSH_G Name
| PUSH_PRIMOP PrimOp
@@ -73,8 +88,16 @@ data BCInstr
| PUSH_ALTS (ProtoBCO Name)
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+ -- Pushing 8, 16 and 32 bits of padding (for constructors).
+ | PUSH_PAD8
+ | PUSH_PAD16
+ | PUSH_PAD32
+
-- Pushing literals
- | PUSH_UBX Literal Word16
+ | PUSH_UBX8 Literal
+ | PUSH_UBX16 Literal
+ | PUSH_UBX32 Literal
+ | PUSH_UBX Literal Word16
-- push this int/float/double/addr, on the stack. Word16
-- is # of words to copy from literal pool. Eitherness reflects
-- the difficulty of dealing with MachAddr here, mostly due to
@@ -196,6 +219,12 @@ instance Outputable BCInstr where
ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
+ ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset
+ ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset
+ ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset
+ ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset
+ ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset
+ ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
@@ -203,6 +232,13 @@ instance Outputable BCInstr where
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+ ppr PUSH_PAD8 = text "PUSH_PAD8"
+ ppr PUSH_PAD16 = text "PUSH_PAD16"
+ ppr PUSH_PAD32 = text "PUSH_PAD32"
+
+ ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit
+ ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit
+ ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit
ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
@@ -271,11 +307,23 @@ bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_LLL{} = 3
+bciStackUse PUSH8{} = 1 -- overapproximation
+bciStackUse PUSH16{} = 1 -- overapproximation
+bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch
+bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word
+bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word
+bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_PAD8) = 1 -- overapproximation
+bciStackUse (PUSH_PAD16) = 1 -- overapproximation
+bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation
+bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation
+bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch
bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index 6dc89e1d9d..7381c8f926 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -9,6 +9,8 @@ module ByteCodeItbls ( mkITbls ) where
#include "HsVersions.h"
+import GhcPrelude
+
import ByteCodeTypes
import GHCi
import DynFlags
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index e865590f2b..e7eb7108f9 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -19,9 +19,10 @@ module ByteCodeLink (
#include "HsVersions.h"
+import GhcPrelude
+
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
-import GHCi.InfoTable
import GHCi.BreakArray
import SizedSeq
@@ -97,7 +98,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
lookupIE hsc_env ie con_nm =
case lookupNameEnv ie con_nm of
- Just (_, ItblPtr a) -> return (conInfoPtr (fromRemotePtr (castRemotePtr a)))
+ Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
let sym_to_find1 = nameToCLabel con_nm "con_info"
m <- lookupSymbol hsc_env sym_to_find1
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
index 1318a47ef4..628b576ca0 100644
--- a/compiler/ghci/ByteCodeTypes.hs
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
--
-- (c) The University of Glasgow 2002-2006
--
@@ -13,6 +13,8 @@ module ByteCodeTypes
, CCostCentre
) where
+import GhcPrelude
+
import FastString
import Id
import Name
@@ -25,7 +27,6 @@ import SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
import GHCi.FFI
-import GHCi.InfoTable
import Control.DeepSeq
import Foreign
@@ -34,11 +35,8 @@ import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
-#if MIN_VERSION_base(4,9,0)
+import GHC.Exts.Heap
import GHC.Stack.CCS
-#else
-import GHC.Stack as GHC.Stack.CCS
-#endif
-- -----------------------------------------------------------------------------
-- Compiled Byte Code
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index b40dd5cd89..5942715c12 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -14,6 +14,8 @@
module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
+import GhcPrelude
+
import Linker
import RtClosureInspect
@@ -42,8 +44,6 @@ import Data.List
import Data.Maybe
import Data.IORef
-import GHC.Exts
-
-------------------------------------
-- | The :print & friends commands
-------------------------------------
@@ -118,11 +118,10 @@ bindSuspensions t = do
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
- let (names, tys, hvals) = unzip3 stuff
+ let (names, tys, fhvs) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
- fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
liftIO $ extendLinkEnv (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic }
return t'
@@ -130,7 +129,7 @@ bindSuspensions t = do
-- Processing suspensions. Give names and recopilate info
nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
- -> TermFold (IO (Term, [(Name,Type,HValue)]))
+ -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
{
fSuspension = doSuspension hsc_env freeNames
@@ -161,7 +160,7 @@ showTerm term = do
then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
else cPprTerm cPprTermBase term
where
- cPprShowable prec t@Term{ty=ty, val=val} =
+ cPprShowable prec t@Term{ty=ty, val=fhv} =
if not (isFullyEvaluatedTerm t)
then return Nothing
else do
@@ -174,13 +173,14 @@ showTerm term = do
-- does this still do what it is intended to do
-- with the changed error handling and logging?
let noop_log _ _ _ _ _ _ = return ()
- expr = "show " ++ showPpr dflags bname
+ expr = "Prelude.return (Prelude.show " ++
+ showPpr dflags bname ++
+ ") :: Prelude.IO Prelude.String"
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
- fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
txt_ <- withExtendedLinkEnv [(bname, fhv)]
- (GHC.compileExpr expr)
+ (GHC.compileExprRemote expr)
let myprec = 10 -- application precedence. TODO Infix constructors
- let txt = unsafeCoerce# txt_ :: [a]
+ txt <- liftIO $ evalString hsc_env txt_
if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
deleted file mode 100644
index 9e3d56e0d1..0000000000
--- a/compiler/ghci/DebuggerUtils.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module DebuggerUtils (
- dataConInfoPtrToName,
- ) where
-
-import GHCi.InfoTable
-import CmmInfo ( stdInfoTableSizeB )
-import DynFlags
-import FastString
-import TcRnTypes
-import TcRnMonad
-import IfaceEnv
-import Module
-import OccName
-import Name
-import Outputable
-import Util
-
-import Data.Char
-import Foreign
-import Data.List
-
-#include "HsVersions.h"
-
--- | Given a data constructor in the heap, find its Name.
--- The info tables for data constructors have a field which records
--- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
--- string). The format is:
---
--- > Package:Module.Name
---
--- We use this string to lookup the interpreter's internal representation of the name
--- using the lookupOrig.
---
-dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
-dataConInfoPtrToName x = do
- dflags <- getDynFlags
- theString <- liftIO $ do
- let ptr = castPtr x :: Ptr StgInfoTable
- conDescAddress <- getConDescAddress dflags ptr
- peekArray0 0 conDescAddress
- let (pkg, mod, occ) = parse theString
- pkgFS = mkFastStringByteList pkg
- modFS = mkFastStringByteList mod
- occFS = mkFastStringByteList occ
- occName = mkOccNameFS OccName.dataName occFS
- modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
- return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
- `recoverM` (Right `fmap` lookupOrig modName occName)
-
- where
-
- {- To find the string in the constructor's info table we need to consider
- the layout of info tables relative to the entry code for a closure.
-
- An info table can be next to the entry code for the closure, or it can
- be separate. The former (faster) is used in registerised versions of ghc,
- and the latter (portable) is for non-registerised versions.
-
- The diagrams below show where the string is to be found relative to
- the normal info table of the closure.
-
- 1) Code next to table:
-
- --------------
- | | <- pointer to the start of the string
- --------------
- | | <- the (start of the) info table structure
- | |
- | |
- --------------
- | entry code |
- | .... |
-
- In this case the pointer to the start of the string can be found in
- the memory location _one word before_ the first entry in the normal info
- table.
-
- 2) Code NOT next to table:
-
- --------------
- info table structure -> | *------------------> --------------
- | | | entry code |
- | | | .... |
- --------------
- ptr to start of str -> | |
- --------------
-
- In this case the pointer to the start of the string can be found
- in the memory location: info_table_ptr + info_table_size
- -}
-
- getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
- getConDescAddress dflags ptr
- | ghciTablesNextToCode = do
- let ptr' = ptr `plusPtr` (- wORD_SIZE dflags)
- -- NB. the offset must be read as an Int32 not a Word32, so
- -- that the sign is preserved when converting to an Int.
- offsetToString <- fromIntegral <$> (peek ptr' :: IO Int32)
- 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:
- -- 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.
- -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
- -- this is not the conventional way of writing Haskell names. We stick with
- -- convention, even though it makes the parsing code more troublesome.
- -- Warning: this code assumes that the string is well formed.
- parse :: [Word8] -> ([Word8], [Word8], [Word8])
- parse input
- = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ)
- where
- dot = fromIntegral (ord '.')
- (pkg, rest1) = break (== fromIntegral (ord ':')) input
- (mod, occ)
- = (concat $ intersperse [dot] $ reverse modWords, occWord)
- where
- (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1))
- parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
- -- We only look for dots if str could start with a module name,
- -- i.e. if it starts with an upper case character.
- -- Otherwise we might think that "X.:->" is the module name in
- -- "X.:->.+", whereas actually "X" is the module name and
- -- ":->.+" is a constructor name.
- parseModOcc acc str@(c : _)
- | isUpper $ chr $ fromIntegral c
- = case break (== dot) str of
- (top, []) -> (acc, top)
- (top, _ : bot) -> parseModOcc (top : acc) bot
- parseModOcc acc str = (acc, str)
diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hs
index d2f2f5a833..579053999f 100644
--- a/compiler/ghci/GHCi.hsc
+++ b/compiler/ghci/GHCi.hs
@@ -21,6 +21,8 @@ module GHCi
, enableBreakpoint
, breakpointStatus
, getBreakpointVar
+ , getClosure
+ , seqHValue
-- * The object-code linker
, initObjLinker
@@ -46,6 +48,8 @@ module GHCi
, fromEvalResult
) where
+import GhcPrelude
+
import GHCi.Message
#if defined(GHCI)
import GHCi.Run
@@ -75,23 +79,14 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.IORef
import Foreign hiding (void)
-#if MIN_VERSION_base(4,9,0)
+import GHC.Exts.Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
-#else
-import GHC.Stack (CostCentre,CostCentreStack)
-#endif
import System.Exit
import Data.Maybe
import GHC.IO.Handle.Types (Handle)
#if defined(mingw32_HOST_OS)
import Foreign.C
import GHC.IO.Handle.FD (fdToHandle)
-#if !MIN_VERSION_process(1,4,2)
-import System.Posix.Internals
-import Foreign.Marshal.Array
-import Foreign.C.Error
-import Foreign.Storable
-#endif
#else
import System.Posix as Posix
#endif
@@ -358,6 +353,17 @@ getBreakpointVar hsc_env ref ix =
mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
mapM (mkFinalizedHValue hsc_env) mb
+getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure hsc_env ref =
+ withForeignRef ref $ \hval -> do
+ mb <- iservCmd hsc_env (GetClosure hval)
+ mapM (mkFinalizedHValue hsc_env) mb
+
+seqHValue :: HscEnv -> ForeignHValue -> IO ()
+seqHValue hsc_env ref =
+ withForeignRef ref $ \hval ->
+ iservCmd hsc_env (Seq hval) >>= fromEvalResult
+
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker
@@ -545,22 +551,6 @@ runWithPipes createProc prog opts = do
where mkHandle :: CInt -> IO Handle
mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
-#if !MIN_VERSION_process(1,4,2)
--- This #include and the _O_BINARY below are the only reason this is hsc,
--- so we can remove that once we can depend on process 1.4.2
-#include <fcntl.h>
-
-createPipeFd :: IO (FD, FD)
-createPipeFd = do
- allocaArray 2 $ \ pfds -> do
- throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
- readfd <- peek pfds
- writefd <- peekElemOff pfds 1
- return (readfd, writefd)
-
-foreign import ccall "io.h _pipe" c__pipe ::
- Ptr CInt -> CUInt -> CInt -> IO CInt
-#endif
#else
runWithPipes createProc prog opts = do
(rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
@@ -584,7 +574,7 @@ We have the following ways to reference things in GHCi:
HValue
------
-HValue is a direct reference to an value in the local heap. Obviously
+HValue is a direct reference to a value in the local heap. Obviously
we cannot use this to refer to things in the external process.
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index aee7684157..9f1307d798 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
@@ -20,6 +21,8 @@ module Linker ( getHValue, showLinkerState,
#include "HsVersions.h"
+import GhcPrelude
+
import GHCi
import GHCi.RemoteTypes
import LoadIface
@@ -51,8 +54,8 @@ import FileCleanup
-- Standard libraries
import Control.Monad
-import Control.Applicative((<|>))
+import Data.Char (isSpace)
import Data.IORef
import Data.List
import Data.Maybe
@@ -60,10 +63,19 @@ import Control.Concurrent.MVar
import System.FilePath
import System.Directory
+import System.IO.Unsafe
+import System.Environment (lookupEnv)
+
+#if defined(mingw32_HOST_OS)
+import System.Win32.Info (getSystemDirectory)
+#endif
import Exception
-import Foreign (Ptr) -- needed for 2nd stage
+-- needed for 2nd stage
+#if STAGE >= 2
+import Foreign (Ptr)
+#endif
{- **********************************************************************
@@ -75,35 +87,45 @@ import Foreign (Ptr) -- needed for 2nd stage
The persistent linker state *must* match the actual state of the
C dynamic linker at all times, so we keep it in a private global variable.
-The global IORef used for PersistentLinkerState actually contains another MVar.
-The reason for this is that we want to allow another loaded copy of the GHC
-library to side-effect the PLS and for those changes to be reflected here.
+The global IORef used for PersistentLinkerState actually contains another MVar,
+which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure
+mutual exclusion between multiple loaded copies of the GHC library. The Maybe
+may be Nothing to indicate that the linker has not yet been initialised.
The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
-}
#if STAGE < 2
-GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
-GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
+GLOBAL_VAR_M( v_PersistentLinkerState
+ , newMVar Nothing
+ , MVar (Maybe PersistentLinkerState))
#else
SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
, getOrSetLibHSghcPersistentLinkerState
, "getOrSetLibHSghcPersistentLinkerState"
- , newMVar (panic "Dynamic linker not initialised")
- , MVar PersistentLinkerState)
--- Set True when dynamic linker is initialised
-SHARED_GLOBAL_VAR( v_InitLinkerDone
- , getOrSetLibHSghcInitLinkerDone
- , "getOrSetLibHSghcInitLinkerDone"
- , False
- , Bool)
+ , newMVar Nothing
+ , MVar (Maybe PersistentLinkerState))
#endif
+uninitialised :: a
+uninitialised = panic "Dynamic linker not initialised"
+
modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
-modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
+modifyPLS_ f = readIORef v_PersistentLinkerState
+ >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)
modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
-modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f
+modifyPLS f = readIORef v_PersistentLinkerState
+ >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)
+ where fmapFst f = fmap (\(x, y) -> (f x, y))
+
+readPLS :: IO PersistentLinkerState
+readPLS = readIORef v_PersistentLinkerState
+ >>= fmap (fromMaybe uninitialised) . readMVar
+
+modifyMbPLS_
+ :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
+modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
data PersistentLinkerState
= PersistentLinkerState {
@@ -158,10 +180,10 @@ extendLoadedPkgs pkgs =
extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
extendLinkEnv new_bindings =
- modifyPLS_ $ \pls -> do
- let ce = closure_env pls
- let new_ce = extendClosureEnv ce new_bindings
- return pls{ closure_env = new_ce }
+ modifyPLS_ $ \pls@PersistentLinkerState{..} -> do
+ let new_ce = extendClosureEnv closure_env new_bindings
+ return $! pls{ closure_env = new_ce }
+ -- strictness is important for not retaining old copies of the pls
deleteFromLinkEnv :: [Name] -> IO ()
deleteFromLinkEnv to_remove =
@@ -243,7 +265,7 @@ withExtendedLinkEnv new_env action
-- | Display the persistent linker state.
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
- = do pls <- readIORef v_PersistentLinkerState >>= readMVar
+ = do pls <- readPLS
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [text "----- Linker state -----",
@@ -278,11 +300,10 @@ showLinkerState dflags
--
initDynLinker :: HscEnv -> IO ()
initDynLinker hsc_env =
- modifyPLS_ $ \pls0 -> do
- done <- readIORef v_InitLinkerDone
- if done then return pls0
- else do writeIORef v_InitLinkerDone True
- reallyInitDynLinker hsc_env
+ modifyMbPLS_ $ \pls -> do
+ case pls of
+ Just _ -> return pls
+ Nothing -> Just <$> reallyInitDynLinker hsc_env
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
@@ -310,7 +331,8 @@ linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState
linkCmdLineLibs' hsc_env pls =
do
let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
- , libraryPaths = lib_paths}) = hsc_dflags hsc_env
+ , libraryPaths = lib_paths_base})
+ = hsc_dflags hsc_env
-- (c) Link libraries from the command-line
let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]
@@ -325,8 +347,18 @@ linkCmdLineLibs' hsc_env pls =
minus_ls = case os of
OSMinGW32 -> "pthread" : minus_ls_1
_ -> minus_ls_1
+ -- See Note [Fork/Exec Windows]
+ gcc_paths <- getGCCPaths dflags os
+
+ lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
- libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls
+ maybePutStrLn dflags "Search directories (user):"
+ maybePutStr dflags (unlines $ map (" "++) lib_paths_env)
+ maybePutStrLn dflags "Search directories (gcc):"
+ maybePutStr dflags (unlines $ map (" "++) gcc_paths)
+
+ libspecs
+ <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
-- (d) Link .o files from the command-line
classified_ld_inputs <- mapM (classifyLdInput dflags)
@@ -350,10 +382,12 @@ linkCmdLineLibs' hsc_env pls =
-- on Windows. On Unix OSes this function is a NOP.
let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)
: framework_paths
- ++ lib_paths
+ ++ lib_paths_base
++ [ takeDirectory dll | DLLPath dll <- libspecs ]
in nub $ map normalise paths
- pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
+ let lib_paths = nub $ lib_paths_base ++ gcc_paths
+ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
cmdline_lib_specs
@@ -483,9 +517,17 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
= do b <- doesFileExist name
if not b then return False
else do if dynamicGhc
- then panic "Loading archives not supported"
+ then throwGhcExceptionIO $
+ CmdLineError dynamic_msg
else loadArchive hsc_env name
return True
+ where
+ dynamic_msg = unlines
+ [ "User-specified static library could not be loaded ("
+ ++ name ++ ")"
+ , "Loading static libraries is not supported in this configuration."
+ , "Try using a dynamic library instead."
+ ]
{- **********************************************************************
@@ -722,15 +764,6 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
adjust_ul _ l@(BCOs {}) = return l
-#if !MIN_VERSION_filepath(1,4,1)
- stripExtension :: String -> FilePath -> Maybe FilePath
- stripExtension [] path = Just path
- stripExtension ext@(x:_) path = stripSuffix dotExt path
- where dotExt = if isExtSeparator x then ext else '.':ext
-
- stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
- stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys)
-#endif
@@ -895,16 +928,14 @@ dynLoadObjs hsc_env pls objs = do
-- can resolve dependencies when it loads this
-- library.
ldInputs =
- concatMap
- (\(lp, l) ->
- [ Option ("-L" ++ lp)
- , Option "-Xlinker"
- , Option "-rpath"
- , Option "-Xlinker"
- , Option lp
- , Option ("-l" ++ l)
- ])
- (temp_sos pls)
+ concatMap (\l -> [ Option ("-l" ++ l) ])
+ (nub $ snd <$> temp_sos pls)
+ ++ concatMap (\lp -> [ Option ("-L" ++ lp)
+ , Option "-Xlinker"
+ , Option "-rpath"
+ , Option "-Xlinker"
+ , Option lp ])
+ (nub $ fst <$> temp_sos pls)
++ concatMap
(\lp ->
[ Option ("-L" ++ lp)
@@ -1072,15 +1103,19 @@ unload_wkr :: HscEnv
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
-unload_wkr hsc_env keep_linkables pls = do
+unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do
+ -- NB. careful strictness here to avoid keeping the old PLS when
+ -- we're unloading some code. -fghci-leak-check with the tests in
+ -- testsuite/ghci can detect space leaks here.
+
let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
discard keep l = not (linkableInSet l keep)
(objs_to_unload, remaining_objs_loaded) =
- partition (discard objs_to_keep) (objs_loaded pls)
+ partition (discard objs_to_keep) objs_loaded
(bcos_to_unload, remaining_bcos_loaded) =
- partition (discard bcos_to_keep) (bcos_loaded pls)
+ partition (discard bcos_to_keep) bcos_loaded
mapM_ unloadObjs objs_to_unload
mapM_ unloadObjs bcos_to_unload
@@ -1091,7 +1126,7 @@ unload_wkr hsc_env keep_linkables pls = do
filter (not . null . linkableObjs) bcos_to_unload))) $
purgeLookupSymbolCache hsc_env
- let bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
+ let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
-- Note that we want to remove all *local*
-- (i.e. non-isExternal) names too (these are the
@@ -1099,13 +1134,13 @@ unload_wkr hsc_env keep_linkables pls = do
keep_name (n,_) = isExternalName n &&
nameModule n `elemModuleSet` bcos_retained
- itbl_env' = filterNameEnv keep_name (itbl_env pls)
- closure_env' = filterNameEnv keep_name (closure_env pls)
+ itbl_env' = filterNameEnv keep_name itbl_env
+ closure_env' = filterNameEnv keep_name closure_env
- new_pls = pls { itbl_env = itbl_env',
- closure_env = closure_env',
- bcos_loaded = remaining_bcos_loaded,
- objs_loaded = remaining_objs_loaded }
+ !new_pls = pls { itbl_env = itbl_env',
+ closure_env = closure_env',
+ bcos_loaded = remaining_bcos_loaded,
+ objs_loaded = remaining_objs_loaded }
return new_pls
where
@@ -1250,9 +1285,14 @@ linkPackage hsc_env pkg
then Packages.extraLibraries pkg
else Packages.extraGHCiLibraries pkg)
++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
-
- hs_classifieds <- mapM (locateLib hsc_env True dirs) hs_libs'
- extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs
+ -- See Note [Fork/Exec Windows]
+ gcc_paths <- getGCCPaths dflags (platformOS platform)
+ dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
+
+ hs_classifieds
+ <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs'
+ extra_classifieds
+ <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs
let classifieds = hs_classifieds ++ extra_classifieds
-- Complication: all the .so's must be loaded before any of the .o's.
@@ -1264,7 +1304,8 @@ linkPackage hsc_env pkg
-- Add directories to library search paths
let dll_paths = map takeDirectory known_dlls
all_paths = nub $ map normalise $ dll_paths ++ dirs
- pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths
+ all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+ pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
maybePutStr dflags
("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
@@ -1306,8 +1347,8 @@ load_dyn hsc_env dll = do
r <- loadDLL hsc_env dll
case r of
Nothing -> return ()
- Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
- ++ dll ++ " (" ++ err ++ ")" ))
+ Just err -> cmdLineErrorIO ("can't load .so/.DLL for: "
+ ++ dll ++ " (" ++ err ++ ")")
loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
loadFrameworks hsc_env platform pkg
@@ -1319,8 +1360,8 @@ loadFrameworks hsc_env platform pkg
load fw = do r <- loadFramework hsc_env fw_dirs fw
case r of
Nothing -> return ()
- Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
- ++ fw ++ " (" ++ err ++ ")" ))
+ Just err -> cmdLineErrorIO ("can't load framework: "
+ ++ fw ++ " (" ++ err ++ ")" )
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume that addDLL in the RTS can find it,
@@ -1328,25 +1369,40 @@ loadFrameworks hsc_env platform pkg
-- standard system search path.
-- For GHCi we tend to prefer dynamic libraries over static ones as
-- they are easier to load and manage, have less overhead.
-locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec
-locateLib hsc_env is_hs dirs lib
+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
+ -> IO LibrarySpec
+locateLib hsc_env is_hs lib_dirs gcc_dirs lib
| not is_hs
-- For non-Haskell libraries (e.g. gmp, iconv):
- -- first look in library-dirs for a dynamic library (libfoo.so)
+ -- first look in library-dirs for a dynamic library (on User paths only)
+ -- (libfoo.so)
+ -- then try looking for import libraries on Windows (on User paths only)
+ -- (.dll.a, .lib)
+ -- first look in library-dirs for a dynamic library (on GCC paths only)
+ -- (libfoo.so)
+ -- then check for system dynamic libraries (e.g. kernel32.dll on windows)
+ -- then try looking for import libraries on Windows (on GCC paths only)
+ -- (.dll.a, .lib)
-- then look in library-dirs for a static library (libfoo.a)
-- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
- -- then check for system dynamic libraries (e.g. kernel32.dll on windows)
-- then try looking for import libraries on Windows (.dll.a, .lib)
- -- then try "gcc --print-file-name" to search gcc's search path
-- then look in library-dirs and inplace GCC for a static library (libfoo.a)
+ -- then try "gcc --print-file-name" to search gcc's search path
-- for a dynamic library (#5289)
-- otherwise, assume loadDLL can find it
--
- = findDll `orElse`
- findSysDll `orElse`
- tryImpLib `orElse`
- tryGcc `orElse`
- findArchive `orElse`
+ -- The logic is a bit complicated, but the rationale behind it is that
+ -- loading a shared library for us is O(1) while loading an archive is
+ -- O(n). Loading an import library is also O(n) so in general we prefer
+ -- shared libraries because they are simpler and faster.
+ --
+ = findDll user `orElse`
+ tryImpLib user `orElse`
+ findDll gcc `orElse`
+ findSysDll `orElse`
+ tryImpLib gcc `orElse`
+ findArchive `orElse`
+ tryGcc `orElse`
assumeDll
| loading_dynamic_hs_libs -- search for .so libraries first.
@@ -1367,11 +1423,15 @@ locateLib hsc_env is_hs dirs lib
where
dflags = hsc_dflags hsc_env
+ dirs = lib_dirs ++ gcc_dirs
+ gcc = False
+ user = True
obj_file = lib <.> "o"
dyn_obj_file = lib <.> "dyn_o"
arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
, lib <.> "a" -- native code has no lib_tag
+ , "lib" ++ lib, lib
]
lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
@@ -1393,19 +1453,26 @@ locateLib hsc_env is_hs dirs lib
findObject = liftM (fmap Object) $ findFile dirs obj_file
findDynObject = liftM (fmap Object) $ findFile dirs dyn_obj_file
- findArchive = let local name = liftM (fmap Archive) $ findFile dirs name
- linked name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs
- check name = apply [local name, linked name]
- in apply (map check arch_files)
+ findArchive = let local name = liftM (fmap Archive) $ findFile dirs name
+ in apply (map local arch_files)
findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
- findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
- findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name
- tryGcc = let short = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
- full = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
- in liftM2 (<|>) short full
- tryImpLib = case os of
- OSMinGW32 -> let check name = liftM (fmap Archive) $ searchForLibUsingGcc dflags name dirs
- in apply (map check import_libs)
+ findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs
+ in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
+ findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $
+ findSystemLibrary hsc_env so_name
+ tryGcc = let search = searchForLibUsingGcc dflags
+ dllpath = liftM (fmap DLLPath)
+ short = dllpath $ search so_name lib_dirs
+ full = dllpath $ search lib_so_name lib_dirs
+ gcc name = liftM (fmap Archive) $ search name lib_dirs
+ files = import_libs ++ arch_files
+ in apply $ short : full : map gcc files
+ tryImpLib re = case os of
+ OSMinGW32 ->
+ let dirs' = if re == user then lib_dirs else gcc_dirs
+ implib name = liftM (fmap Archive) $
+ findFile dirs' name
+ in apply (map implib import_libs)
_ -> return Nothing
assumeDll = return (DLL lib)
@@ -1435,6 +1502,96 @@ searchForLibUsingGcc dflags so dirs = do
then return Nothing
else return (Just file)
+-- | Retrieve the list of search directory GCC and the System use to find
+-- libraries and components. See Note [Fork/Exec Windows].
+getGCCPaths :: DynFlags -> OS -> IO [FilePath]
+getGCCPaths dflags os
+ = case os of
+ OSMinGW32 ->
+ do gcc_dirs <- getGccSearchDirectory dflags "libraries"
+ sys_dirs <- getSystemDirectories
+ return $ nub $ gcc_dirs ++ sys_dirs
+ _ -> return []
+
+-- | Cache for the GCC search directories as this can't easily change
+-- during an invocation of GHC. (Maybe with some env. variable but we'll)
+-- deal with that highly unlikely scenario then.
+{-# NOINLINE gccSearchDirCache #-}
+gccSearchDirCache :: IORef [(String, [String])]
+gccSearchDirCache = unsafePerformIO $ newIORef []
+
+-- Note [Fork/Exec Windows]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we
+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
+-- So instead get a list of location that GCC would search and use findDirs
+-- which hopefully is written in an optimized mannor to take advantage of
+-- caching. At the very least we remove the overhead of the fork/exec and waits
+-- which dominate a large percentage of startup time on Windows.
+getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]
+getGccSearchDirectory dflags key = do
+ cache <- readIORef gccSearchDirCache
+ case lookup key cache of
+ Just x -> return x
+ Nothing -> do
+ str <- askLd dflags [Option "--print-search-dirs"]
+ let line = dropWhile isSpace str
+ name = key ++ ": ="
+ if null line
+ then return []
+ else do let val = split $ find name line
+ dirs <- filterM doesDirectoryExist val
+ modifyIORef' gccSearchDirCache ((key, dirs):)
+ return val
+ where split :: FilePath -> [FilePath]
+ split r = case break (==';') r of
+ (s, [] ) -> [s]
+ (s, (_:xs)) -> s : split xs
+
+ find :: String -> String -> String
+ find r x = let lst = lines x
+ val = filter (r `isPrefixOf`) lst
+ in if null val
+ then []
+ else case break (=='=') (head val) of
+ (_ , []) -> []
+ (_, (_:xs)) -> xs
+
+-- | Get a list of system search directories, this to alleviate pressure on
+-- the findSysDll function.
+getSystemDirectories :: IO [FilePath]
+#if defined(mingw32_HOST_OS)
+getSystemDirectories = fmap (:[]) getSystemDirectory
+#else
+getSystemDirectories = return []
+#endif
+
+-- | Merge the given list of paths with those in the environment variable
+-- given. If the variable does not exist then just return the identity.
+addEnvPaths :: String -> [String] -> IO [String]
+addEnvPaths name list
+ = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
+ -- working directory. Replace empty strings in the env variable with
+ -- `working_dir` (see also #14695).
+ working_dir <- getCurrentDirectory
+ values <- lookupEnv name
+ case values of
+ Nothing -> return list
+ Just arr -> return $ list ++ splitEnv working_dir arr
+ where
+ splitEnv :: FilePath -> String -> [String]
+ splitEnv working_dir value =
+ case break (== envListSep) value of
+ (x, [] ) ->
+ [if null x then working_dir else x]
+ (x, (_:xs)) ->
+ (if null x then working_dir else x) : splitEnv working_dir xs
+#if defined(mingw32_HOST_OS)
+ envListSep = ';'
+#else
+ envListSep = ':'
+#endif
+
-- ----------------------------------------------------------------------------
-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 785513b3b6..18feeb523f 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -8,28 +8,27 @@
--
-----------------------------------------------------------------------------
module RtClosureInspect(
- cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
+ -- * Entry points and types
+ cvObtainTerm,
cvReconstructType,
improveRTTIType,
-
Term(..),
- isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap,
- isFullyEvaluated, isFullyEvaluatedTerm,
- termType, mapTermType, termTyCoVars,
- foldTerm, TermFold(..), foldTermM, TermFoldM(..), idTermFold,
- pprTerm, cPprTerm, cPprTermBase, CustomTermPrinter,
--- unsafeDeepSeq,
+ -- * Utils
+ isFullyEvaluatedTerm,
+ termType, mapTermType, termTyCoVars,
+ foldTerm, TermFold(..),
+ cPprTerm, cPprTermBase,
- Closure(..), getClosureData, ClosureType(..), isConstr, isIndirection
+ constrClosToName -- exported to use in test T4891
) where
#include "HsVersions.h"
-import DebuggerUtils
-import GHCi.RemoteTypes ( HValue )
-import qualified GHCi.InfoTable as InfoTable
-import GHCi.InfoTable (StgInfoTable, peekItbl)
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
import HscTypes
import DataCon
@@ -40,12 +39,15 @@ import Var
import TcRnMonad
import TcType
import TcMType
-import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )
+import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
import TcUnify
import TcEnv
import TyCon
import Name
+import OccName
+import Module
+import IfaceEnv
import Util
import VarSet
import BasicTypes ( Boxity(..) )
@@ -54,20 +56,25 @@ import PrelNames
import TysWiredIn
import DynFlags
import Outputable as Ppr
-import GHC.Arr ( Array(..) )
+import GHC.Char
import GHC.Exts
+import GHC.Exts.Heap
import GHC.IO ( IO(..) )
+import SMRep ( roundUpTo )
import Control.Monad
-import Data.Maybe
import Data.Array.Base
-import Data.Ix
+import Data.Maybe
import Data.List
+#if defined(INTEGER_GMP)
+import GHC.Integer.GMP.Internals
+#endif
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign
import System.IO.Unsafe
+
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
@@ -77,15 +84,15 @@ data Term = Term { ty :: RttiType
-- Carries a text representation if the datacon is
-- not exported by the .hi file, which is the case
-- for private constructors in -O0 compiled libraries
- , val :: HValue
+ , val :: ForeignHValue
, subTerms :: [Term] }
| Prim { ty :: RttiType
- , value :: [Word] }
+ , valRaw :: [Word] }
| Suspension { ctype :: ClosureType
, ty :: RttiType
- , val :: HValue
+ , val :: ForeignHValue
, bound_to :: Maybe Name -- Useful for printing
}
| NewtypeWrap{ -- At runtime there are no newtypes, and hence no
@@ -99,22 +106,6 @@ data Term = Term { ty :: RttiType
ty :: RttiType
, wrapped_term :: Term }
-isTerm, isSuspension, isPrim, isFun, isFunLike, isNewtypeWrap :: Term -> Bool
-isTerm Term{} = True
-isTerm _ = False
-isSuspension Suspension{} = True
-isSuspension _ = False
-isPrim Prim{} = True
-isPrim _ = False
-isNewtypeWrap NewtypeWrap{} = True
-isNewtypeWrap _ = False
-
-isFun Suspension{ctype=Fun} = True
-isFun _ = False
-
-isFunLike s@Suspension{ty=ty} = isFun s || isFunTy ty
-isFunLike _ = False
-
termType :: Term -> RttiType
termType t = ty t
@@ -129,122 +120,33 @@ instance Outputable (Term) where
ppr t | Just doc <- cPprTerm cPprTermBase t = doc
| otherwise = panic "Outputable Term instance"
--------------------------------------------------------------------------
--- Runtime Closure Datatype and functions for retrieving closure related stuff
--------------------------------------------------------------------------
-data ClosureType = Constr
- | Fun
- | Thunk Int
- | ThunkSelector
- | Blackhole
- | AP
- | PAP
- | Indirection Int
- | MutVar Int
- | MVar Int
- | Other Int
- deriving (Show, Eq)
-
-data Closure = Closure { tipe :: ClosureType
- , infoPtr :: Ptr ()
- , infoTable :: StgInfoTable
- , ptrs :: Array Int HValue
- , nonPtrs :: [Word]
- }
+----------------------------------------
+-- Runtime Closure information functions
+----------------------------------------
-instance Outputable ClosureType where
- ppr = text . show
-
-#include "../includes/rts/storage/ClosureTypes.h"
-
-aP_CODE, pAP_CODE :: Int
-aP_CODE = AP
-pAP_CODE = PAP
-#undef AP
-#undef PAP
-
-getClosureData :: DynFlags -> a -> IO Closure
-getClosureData dflags a =
- case unpackClosure# a of
- (# iptr, ptrs, nptrs #) -> do
- let iptr0 = Ptr iptr
- let iptr1
- | ghciTablesNextToCode = iptr0
- | otherwise =
- -- the info pointer we get back from unpackClosure#
- -- is to the beginning of the standard info table,
- -- but the Storable instance for info tables takes
- -- into account the extra entry pointer when
- -- !ghciTablesNextToCode, so we must adjust here:
- iptr0 `plusPtr` negate (wORD_SIZE dflags)
- itbl <- peekItbl iptr1
- let tipe = readCType (InfoTable.tipe itbl)
- elems = fromIntegral (InfoTable.ptrs itbl)
- ptrsList = Array 0 (elems - 1) elems ptrs
- nptrs_data = [W# (indexWordArray# nptrs i)
- | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
- ASSERT(elems >= 0) return ()
- ptrsList `seq`
- return (Closure tipe iptr0 itbl ptrsList nptrs_data)
-
-readCType :: Integral a => a -> ClosureType
-readCType i
- | i >= CONSTR && i <= CONSTR_NOCAF = Constr
- | i >= FUN && i <= FUN_STATIC = Fun
- | i >= THUNK && i < THUNK_SELECTOR = Thunk i'
- | i == THUNK_SELECTOR = ThunkSelector
- | i == BLACKHOLE = Blackhole
- | i >= IND && i <= IND_STATIC = Indirection i'
- | i' == aP_CODE = AP
- | i == AP_STACK = AP
- | i' == pAP_CODE = PAP
- | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY= MutVar i'
- | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i'
- | otherwise = Other i'
- where i' = fromIntegral i
-
-isConstr, isIndirection, isThunk :: ClosureType -> Bool
-isConstr Constr = True
-isConstr _ = False
-
-isIndirection (Indirection _) = True
-isIndirection _ = False
-
-isThunk (Thunk _) = True
-isThunk ThunkSelector = True
-isThunk AP = True
+isThunk :: GenClosure a -> Bool
+isThunk ThunkClosure{} = True
+isThunk APClosure{} = True
+isThunk APStackClosure{} = True
isThunk _ = False
-isFullyEvaluated :: DynFlags -> a -> IO Bool
-isFullyEvaluated dflags a = do
- closure <- getClosureData dflags a
- case tipe closure of
- Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure)
- return$ and are_subs_evaluated
- _ -> return False
- where amapM f = sequence . amap' f
-
--- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
-{-
-unsafeDeepSeq :: a -> b -> b
-unsafeDeepSeq = unsafeDeepSeq1 2
- where unsafeDeepSeq1 0 a b = seq a $! b
- unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks
- | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
- -- | unsafePerformIO (isFullyEvaluated a) = b
- | otherwise = case unsafePerformIO (getClosureData a) of
- closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
- where tipe = unsafePerformIO (getClosureType a)
--}
+-- Lookup the name in a constructor closure
+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
+ let occName = mkOccName OccName.dataName occ
+ modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
+ Right `fmap` lookupOrigIO hsc_env modName occName
+constrClosToName _hsc_env clos =
+ return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
-----------------------------------
-- * Traversals for Terms
-----------------------------------
-type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
data TermFold a = TermFold { fTerm :: TermProcessor a a
, fPrim :: RttiType -> [Word] -> a
- , fSuspension :: ClosureType -> RttiType -> HValue
+ , fSuspension :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> a
, fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
@@ -255,7 +157,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a
data TermFoldM m a =
TermFoldM {fTermM :: TermProcessor a (m a)
, fPrimM :: RttiType -> [Word] -> m a
- , fSuspensionM :: ClosureType -> RttiType -> HValue
+ , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> m a
, fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
@@ -318,7 +220,6 @@ termTyCoVars = foldTerm TermFold {
----------------------------------
type Precedence = Int
-type TermPrinter = Precedence -> Term -> SDoc
type TermPrinterM m = Precedence -> Term -> m SDoc
app_prec,cons_prec, max_prec ::Int
@@ -326,10 +227,6 @@ max_prec = 10
app_prec = max_prec
cons_prec = 5 -- TODO Extract this info from GHC itself
-pprTerm :: TermPrinter -> TermPrinter
-pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
-pprTerm _ _ _ = panic "pprTerm"
-
pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
@@ -338,22 +235,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
return $ cparen (not (null tt) && p >= app_prec)
(text dc_tag <+> pprDeeperList fsep tt_docs)
-ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
= parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
<+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
- tt_docs' <- mapM (y app_prec) tt
- return $ sdocWithPprDebug $ \dbg ->
- -- Don't show the dictionary arguments to
- -- constructors unless -dppr-debug is on
- let tt_docs = if dbg
- then tt_docs'
- else dropList (dataConTheta dc) tt_docs'
- in if null tt_docs
- then ppr dc
- else cparen (p >= app_prec) $
- sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
+ = do { tt_docs' <- mapM (y app_prec) tt
+ ; return $ ifPprDebug (show_tm tt_docs')
+ (show_tm (dropList (dataConTheta dc) tt_docs'))
+ -- Don't show the dictionary arguments to
+ -- constructors unless -dppr-debug is on
+ }
+ where
+ show_tm tt_docs
+ | null tt_docs = ppr dc
+ | otherwise = cparen (p >= app_prec) $
+ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do
@@ -368,10 +265,10 @@ ppr_termM _ _ t = ppr_termM1 t
ppr_termM1 :: Monad m => Term -> m SDoc
-ppr_termM1 Prim{value=words, ty=ty} =
+ppr_termM1 Prim{valRaw=words, ty=ty} =
return $ repPrim (tyConAppTyCon ty) words
ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
- return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
+ return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
ppr_termM1 Suspension{ty=ty, bound_to=Just n}
-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
| otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
@@ -411,8 +308,10 @@ cPprTerm printers_ = go 0 where
go prec t = do
let default_ = Just `liftM` pprTermM go prec t
mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
- Just doc <- firstJustM mb_customDocs
- return$ cparen (prec>app_prec+1) doc
+ mdoc <- firstJustM mb_customDocs
+ case mdoc of
+ Nothing -> panic "cPprTerm"
+ Just doc -> return $ cparen (prec>app_prec+1) doc
firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
firstJustM [] = return Nothing
@@ -425,19 +324,26 @@ cPprTermBase y =
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
ppr_list
- , ifTerm (isTyCon intTyCon . ty) ppr_int
- , ifTerm (isTyCon charTyCon . ty) ppr_char
- , ifTerm (isTyCon floatTyCon . ty) ppr_float
- , ifTerm (isTyCon doubleTyCon . ty) ppr_double
- , ifTerm (isIntegerTy . ty) ppr_integer
+ , ifTerm' (isTyCon intTyCon . ty) ppr_int
+ , ifTerm' (isTyCon charTyCon . ty) ppr_char
+ , ifTerm' (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
+#if defined(INTEGER_GMP)
+ , ifTerm' (isIntegerTy . ty) ppr_integer
+#endif
]
where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
- ifTerm pred f prec t@Term{}
- | pred t = Just `liftM` f prec t
- ifTerm _ _ _ _ = return Nothing
+ ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
+
+ ifTerm' :: (Term -> Bool)
+ -> (Precedence -> Term -> m (Maybe SDoc))
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm' pred f prec t@Term{}
+ | pred t = f prec t
+ ifTerm' _ _ _ _ = return Nothing
isTupleTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
@@ -451,13 +357,67 @@ cPprTermBase y =
(tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName)
- ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
- :: Precedence -> Term -> m SDoc
- ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
- ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
- ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
- ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
- ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+ ppr_int, ppr_char, ppr_float, ppr_double
+ :: Precedence -> Term -> m (Maybe SDoc)
+ ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
+ return (Just (Ppr.int (fromIntegral w)))
+ ppr_int _ _ = return Nothing
+
+ ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
+ return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
+ ppr_char _ _ = return Nothing
+
+ ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> poke p w >> peek (castPtr p)
+ return (Just (Ppr.float f))
+ ppr_float _ _ = return Nothing
+
+ ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> poke p w >> peek (castPtr p)
+ return (Just (Ppr.double f))
+ -- let's assume that if we get two words, we're on a 32-bit
+ -- machine. There's no good way to get a DynFlags to check the word
+ -- size here.
+ ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> do
+ poke p (fromIntegral w1 :: Word32)
+ poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
+ peek (castPtr p)
+ return (Just (Ppr.double f))
+ ppr_double _ _ = return Nothing
+
+ ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
+#if defined(INTEGER_GMP)
+ -- Reconstructing Integers is a bit of a pain. This depends deeply
+ -- on the integer-gmp representation, so it'll break if that
+ -- changes (but there are several tests in
+ -- tests/ghci.debugger/scripts that will tell us if this is wrong).
+ --
+ -- data Integer
+ -- = S# Int#
+ -- | Jp# {-# UNPACK #-} !BigNat
+ -- | Jn# {-# UNPACK #-} !BigNat
+ --
+ -- data BigNat = BN# ByteArray#
+ --
+ ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
+ return (Just (Ppr.integer (S# (word2Int# w))))
+ ppr_integer _ Term{dc=Right con,
+ subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
+ -- We don't need to worry about sizes that are not an integral
+ -- number of words, because luckily GMP uses arrays of words
+ -- (see GMP_LIMB_SHIFT).
+ let
+ !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
+ constr
+ | "Jp#" <- occNameString (nameOccName (dataConName con)) = Jp#
+ | otherwise = Jn#
+ return (Just (Ppr.integer (constr (BN# arr#))))
+#endif
+ ppr_integer _ _ = return Nothing
--Note pprinting of list terms is not lazy
ppr_list :: Precedence -> Term -> m SDoc
@@ -465,10 +425,12 @@ cPprTermBase y =
let elems = h : getListTerms t
isConsLast = not (termType (last elems) `eqType` termType h)
is_string = all (isCharTy . ty) elems
+ chars = [ chr (fromIntegral w)
+ | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
print_elems <- mapM (y cons_prec) elems
if is_string
- then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ then return (Ppr.doubleQuotes (Ppr.text chars))
else if isConsLast
then return $ cparen (p >= cons_prec)
$ pprDeeperList fsep
@@ -487,7 +449,9 @@ cPprTermBase y =
repPrim :: TyCon -> [Word] -> SDoc
repPrim t = rep where
rep x
- | t == charPrimTyCon = text $ show (build x :: Char)
+ -- Char# uses native machine words, whereas Char's Storable instance uses
+ -- Int32, so we have to read it as an Int.
+ | t == charPrimTyCon = text $ show (chr (build x :: Int))
| t == intPrimTyCon = text $ show (build x :: Int)
| t == wordPrimTyCon = text $ show (build x :: Word)
| t == floatPrimTyCon = text $ show (build x :: Float)
@@ -637,13 +601,30 @@ addConstraint actual expected = do
discardResult $
captureConstraints $
do { (ty1, ty2) <- congruenceNewtypes actual expected
- ; unifyType noThing ty1 ty2 }
+ ; unifyType Nothing ty1 ty2 }
-- TOMDO: what about the coercion?
-- we should consider family instances
--- Type & Term reconstruction
-------------------------------
-cvObtainTerm :: HscEnv -> Int -> Bool -> RttiType -> HValue -> IO Term
+
+-- | Term reconstruction
+--
+-- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
+-- representation of the object. Subterms (objects in the payload) are also
+-- built up to the given `max_depth`. After `max_depth` any subterms will appear
+-- as `Suspension`s. Any thunks found while traversing the object will be forced
+-- based on `force` parameter.
+--
+-- Types of terms will be refined based on constructors we find during term
+-- reconstruction. See `cvReconstructType` for an overview of how type
+-- reconstruction works.
+--
+cvObtainTerm
+ :: HscEnv
+ -> Int -- ^ How many times to recurse for subterms
+ -> Bool -- ^ Force thunks
+ -> RttiType -- ^ Type of the object to reconstruct
+ -> ForeignHValue -- ^ Object to reconstruct
+ -> IO Term
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- we quantify existential tyvars as universal,
-- as this is needed to be able to manipulate
@@ -688,9 +669,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
+ go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
-- I believe that my_ty should not have any enclosing
-- foralls, nor any free RuntimeUnk skolems;
-- that is partly what the quantifyType stuff achieved
@@ -700,27 +679,32 @@ 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 dflags a
- return (Suspension (tipe clos) my_ty a Nothing)
+ clos <- trIO $ GHCi.getClosure hsc_env a
+ return (Suspension (tipe (info 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 dflags a
- case tipe clos of
+ clos <- trIO $ GHCi.getClosure hsc_env a
+ case clos of
-- Thunks we may want to force
- t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
- seq a (go (pred max_depth) my_ty old_ty a)
+ t | isThunk t && force -> do
+ traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
+ liftIO $ GHCi.seqHValue hsc_env a
+ go (pred max_depth) my_ty old_ty a
-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
-- showing '_' which is what we want.
- Blackhole -> do traceTR (text "Following a BLACKHOLE")
- appArr (go max_depth my_ty old_ty) (ptrs clos) 0
+ BlackholeClosure{indirectee=ind} -> do
+ traceTR (text "Following a BLACKHOLE")
+ go max_depth my_ty old_ty ind
-- We always follow indirections
- Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) )
- go max_depth my_ty old_ty $! (ptrs clos ! 0)
+ IndClosure{indirectee=ind} -> do
+ traceTR (text "Following an indirection" )
+ go max_depth my_ty old_ty ind
-- We also follow references
- MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+ MutVarClosure{var=contents}
+ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
-> do
-- Deal with the MutVar# primitive
-- It does not have a constructor at all,
@@ -728,8 +712,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- MutVar# :: contents_ty -> MutVar# s contents_ty
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
- contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
- ASSERT(isUnliftedType my_ty) return ()
+ MASSERT(isUnliftedType my_ty)
(mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
contents_ty (mkTyConApp tycon [world,contents_ty])
addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
@@ -737,12 +720,12 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
return (RefWrap my_ty x)
-- The interesting case
- Constr -> do
- traceTR (text "entering a constructor " <>
+ ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
+ traceTR (text "entering a constructor " <> ppr dArgs <+>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty)
- Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ Right dcname <- liftIO $ constrClosToName hsc_env clos
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing -> do -- This can happen for private constructors compiled -O0
@@ -753,10 +736,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
traceTR (text "Not constructor" <+> ppr dcname)
let dflags = hsc_dflags hsc_env
tag = showPpr dflags dcname
- vars <- replicateM (length$ elems$ ptrs clos)
+ vars <- replicateM (length pArgs)
(newVar liftedTypeKind)
- subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
- | (i, tv) <- zip [0..] vars]
+ subTerms <- sequence $ zipWith (\x tv ->
+ go (pred max_depth) tv tv x) pArgs vars
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
@@ -764,10 +747,18 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms)
+ -- This is to support printing of Integers. It's not a general
+ -- mechanism by any means; in particular we lose the size in
+ -- bytes of the array.
+ ArrWordsClosure{bytes=b, arrWords=ws} -> do
+ traceTR (text "ByteArray# closure, size " <> ppr b)
+ return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
+
-- The otherwise case: can be a Thunk,AP,PAP,etc.
- tipe_clos -> do
- traceTR (text "Unknown closure:" <+> ppr tipe_clos)
- return (Suspension tipe_clos my_ty a Nothing)
+ _ -> do
+ traceTR (text "Unknown closure:" <+>
+ text (show (fmap (const ()) clos)))
+ return (Suspension (tipe (info clos)) my_ty a Nothing)
-- insert NewtypeWraps around newtypes
expandNewtypes = foldTerm idTermFold { fTerm = worker } where
@@ -786,53 +777,118 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
| otherwise = Suspension ct ty hval n
-extractSubTerms :: (Type -> HValue -> TcM Term)
- -> Closure -> [Type] -> TcM [Term]
-extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
+extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+ -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thdOf3 . go 0 0
where
- go ptr_i ws [] = return (ptr_i, ws, [])
- go ptr_i ws (ty:tys)
+ array = dataArgs clos
+
+ go ptr_i arr_i [] = return (ptr_i, arr_i, [])
+ go ptr_i arr_i (ty:tys)
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
- = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
- (ptr_i, ws, terms1) <- go ptr_i ws tys
- return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+ = do (ptr_i, arr_i, terms0) <-
+ go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
+ (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+ return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
| otherwise
= case typePrimRepArgs ty of
[rep_ty] -> do
- (ptr_i, ws, term0) <- go_rep ptr_i ws ty rep_ty
- (ptr_i, ws, terms1) <- go ptr_i ws tys
- return (ptr_i, ws, term0 : terms1)
+ (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty
+ (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+ return (ptr_i, arr_i, term0 : terms1)
rep_tys -> do
- (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
- (ptr_i, ws, terms1) <- go ptr_i ws tys
- return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+ (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
+ (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+ return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
- go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
- go_unary_types ptr_i ws (rep_ty:rep_tys) = do
+ go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
+ go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
tv <- newVar liftedTypeKind
- (ptr_i, ws, term0) <- go_rep ptr_i ws tv rep_ty
- (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
- return (ptr_i, ws, term0 : terms1)
-
- go_rep ptr_i ws ty rep
- | isGcPtrRep rep
- = do t <- appArr (recurse ty) (ptrs clos) ptr_i
- return (ptr_i + 1, ws, t)
- | otherwise
- = do dflags <- getDynFlags
- let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
- return (ptr_i, ws1, Prim ty ws0)
+ (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty
+ (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
+ return (ptr_i, arr_i, term0 : terms1)
+
+ go_rep ptr_i arr_i ty rep
+ | isGcPtrRep rep = do
+ t <- recurse ty $ (ptrArgs clos)!!ptr_i
+ return (ptr_i + 1, arr_i, t)
+ | otherwise = do
+ -- This is a bit involved since we allow packing multiple fields
+ -- within a single word. See also
+ -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
+ dflags <- getDynFlags
+ let word_size = wORD_SIZE dflags
+ big_endian = wORDS_BIGENDIAN dflags
+ size_b = primRepSizeB dflags rep
+ -- Align the start offset (eg, 2-byte value should be 2-byte
+ -- aligned). But not more than to a word. The offset calculation
+ -- should be the same with the offset calculation in
+ -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
+ !aligned_idx = roundUpTo arr_i (min word_size size_b)
+ !new_arr_i = aligned_idx + size_b
+ ws | size_b < word_size =
+ [index size_b aligned_idx word_size big_endian]
+ | otherwise =
+ let (q, r) = size_b `quotRem` word_size
+ in ASSERT( r == 0 )
+ [ array!!i
+ | o <- [0.. q - 1]
+ , let i = (aligned_idx `quot` word_size) + o
+ ]
+ return (ptr_i, new_arr_i, Prim ty ws)
unboxedTupleTerm ty terms
= Term ty (Right (tupleDataCon Unboxed (length terms)))
(error "unboxedTupleTerm: no HValue for unboxed tuple") terms
-
--- Fast, breadth-first Type reconstruction
-------------------------------------------
-cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
+ -- Extract a sub-word sized field from a word
+ index item_size_b index_b word_size big_endian =
+ (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
+ where
+ mask :: Word
+ mask = case item_size_b of
+ 1 -> 0xFF
+ 2 -> 0xFFFF
+ 4 -> 0xFFFFFFFF
+ _ -> panic ("Weird byte-index: " ++ show index_b)
+ (q,r) = index_b `quotRem` word_size
+ word = array!!q
+ moveBytes = if big_endian
+ then word_size - (r + item_size_b) * 8
+ else r * 8
+
+
+-- | Fast, breadth-first Type reconstruction
+--
+-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
+-- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
+-- This is used for improving type information in debugger. For example, if we
+-- have a polymorphic function:
+--
+-- sumNumList :: Num a => [a] -> a
+-- sumNumList [] = 0
+-- sumNumList (x : xs) = x + sumList xs
+--
+-- and add a breakpoint to it:
+--
+-- ghci> break sumNumList
+-- ghci> sumNumList ([0 .. 9] :: [Int])
+--
+-- ghci shows us more precise types than just `a`s:
+--
+-- Stopped in Main.sumNumList, debugger.hs:3:23-39
+-- _result :: Int = _
+-- x :: Int = 0
+-- xs :: [Int] = _
+--
+cvReconstructType
+ :: HscEnv
+ -> Int -- ^ How many times to recurse for subterms
+ -> GhciType -- ^ Type to refine
+ -> ForeignHValue -- ^ Refine the type using this value
+ -> IO (Maybe Type)
cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI started with initial type " <> ppr old_ty)
let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
@@ -860,8 +916,6 @@ 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")
@@ -873,35 +927,33 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
-- returns unification tasks,since we are going to want a breadth-first search
- go :: Type -> HValue -> TR [(Type, HValue)]
+ go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
go my_ty a = do
traceTR (text "go" <+> ppr my_ty)
- 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)
- MutVar _ -> do
- contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ clos <- trIO $ GHCi.getClosure hsc_env a
+ case clos of
+ BlackholeClosure{indirectee=ind} -> go my_ty ind
+ IndClosure{indirectee=ind} -> go my_ty ind
+ MutVarClosure{var=contents} -> do
tv' <- newVar liftedTypeKind
world <- newVar liftedTypeKind
addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
return [(tv', contents)]
- Constr -> do
- Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ ConstrClosure{ptrArgs=pArgs} -> do
+ Right dcname <- liftIO $ constrClosToName hsc_env clos
traceTR (text "Constr1" <+> ppr dcname)
- (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+ (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
- forM (elems $ ptrs clos) $ \a -> do
+ forM pArgs $ \x -> do
tv <- newVar liftedTypeKind
- return (tv, a)
+ return (tv, x)
Just dc -> do
arg_tys <- getDataConArgTys dc my_ty
(_, itys) <- findPtrTyss 0 arg_tys
traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
- return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
- | (i,ty) <- itys]
+ return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
_ -> return []
findPtrTys :: Int -- Current pointer index
@@ -950,6 +1002,9 @@ getDataConArgTys dc con_app_ty
= do { let rep_con_app_ty = unwrapType con_app_ty
; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
$$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+ ; ASSERT( all isTyVar ex_tvs ) return ()
+ -- ex_tvs can only be tyvars as data types in source
+ -- Haskell cannot mention covar yet (Aug 2018)
; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
-- See Note [Constructor arg types]
@@ -958,7 +1013,7 @@ getDataConArgTys dc con_app_ty
; return con_arg_tys }
where
univ_tvs = dataConUnivTyVars dc
- ex_tvs = dataConExTyVars dc
+ ex_tvs = dataConExTyCoVars dc
{- Note [Constructor arg types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1186,7 +1241,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
(_, vars) <- instTyVars (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
rep_ty = unwrapType ty'
- _ <- liftTcM (unifyType noThing ty rep_ty)
+ _ <- liftTcM (unifyType Nothing ty rep_ty)
-- assumes that reptype doesn't ^^^^ touch tyconApp args
return ty'
@@ -1205,17 +1260,9 @@ zonkTerm = foldTermM (TermFoldM
zonkRttiType :: TcType -> TcM Type
-- Zonk the type, replacing any unbound Meta tyvars
--- by skolems, safely out of Meta-tyvar-land
-zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
- where
- zonk_unbound_meta tv
- = ASSERT( isTcTyVar tv )
- do { tv' <- skolemiseRuntimeUnk tv
- -- This is where RuntimeUnks are born:
- -- otherwise-unconstrained unification variables are
- -- turned into RuntimeUnks as they leave the
- -- typechecker's monad
- ; return (mkTyVarTy tv') }
+-- by RuntimeUnk skolems, safely out of Meta-tyvar-land
+zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi
+ ; zonkTcTypeToTypeX ze ty }
--------------------------------------------------------------------------------
-- Restore Class predicates out of a representation type
@@ -1267,15 +1314,3 @@ quantifyType ty = ( filter isTyVar $
, rho)
where
(_tvs, rho) = tcSplitForAllTys ty
-
--- Strict application of f at index i
-appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
-appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
- = ASSERT2(i < length(elems a), ppr(length$ elems a, i))
- case indexArray# ptrs# i# of
- (# e #) -> f e
-
-amap' :: (t -> b) -> Array Int t -> [b]
-amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
- where g (I# i#) = case indexArray# arr# i# of
- (# e #) -> f e
View Lorry Controller Status