diff options
Diffstat (limited to 'compiler')
41 files changed, 1686 insertions, 1839 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 4133eac35f..f8d4e8fe3e 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -86,8 +86,6 @@ module BasicTypes( FractionalLit(..), negateFractionalLit, integralFractionalLit, - HValue(..), - SourceText, IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit @@ -99,7 +97,6 @@ import SrcLoc ( Located,unLoc ) import StaticFlags( opt_PprStyle_Debug ) import Data.Data hiding (Fixity) import Data.Function (on) -import GHC.Exts (Any) {- ************************************************************************ @@ -1165,8 +1162,6 @@ instance Ord FractionalLit where instance Outputable FractionalLit where ppr = text . fl_text -newtype HValue = HValue Any - {- ************************************************************************ * * diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 5f3b75dafa..f1a99f7980 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -106,13 +106,13 @@ data Literal (Maybe Int) FunctionOrData -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\<x\>@ will - -- be appended to label name when emitting assembly. + -- + -- 1) The name of the symbol mentioned in the declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\<x\>@ will + -- be appended to label name when emitting assembly. | LitInteger Integer Type -- ^ Integer literals -- See Note [Integer literals] diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index c3e445a2bc..07db78a931 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -278,15 +278,16 @@ mkStringExprFS str | all safeChar chars = do unpack_id <- lookupId unpackCStringName - return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + return (App (Var unpack_id) lit) | otherwise - = do unpack_id <- lookupId unpackCStringUtf8Name - return (App (Var unpack_id) (Lit (MachStr (fastStringToByteString str)))) + = do unpack_utf8_id <- lookupId unpackCStringUtf8Name + return (App (Var unpack_utf8_id) lit) where chars = unpackFS str safeChar c = ord c >= 1 && ord c <= 0x7F + lit = Lit (MachStr (fastStringToByteString str)) {- ************************************************************************ diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 85f603fac1..958aa12eab 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -981,7 +981,9 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = - ifa (hscTarget dflags == HscInterpreted) Breakpoints $ + ifa (hscTarget dflags == HscInterpreted && + not (gopt Opt_ExternalInterpreter dflags)) Breakpoints $ + -- TODO: breakpoints don't work with -fexternal-interpreter yet ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (gopt Opt_SccProfilingOn dflags && profAuto dflags /= NoProfAuto) ProfNotes $ diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 8dc4e23efa..ae702ef788 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -64,6 +64,9 @@ Library else Build-Depends: unix + if flag(ghci) + Build-Depends: ghci + GHC-Options: -Wall -fno-warn-name-shadowing if flag(ghci) @@ -467,7 +470,6 @@ Library Pair Panic Pretty - Serialized State Stream StringBuffer @@ -578,6 +580,7 @@ Library if flag(ghci) Exposed-Modules: Convert + ByteCodeTypes ByteCodeAsm ByteCodeGen ByteCodeInstr @@ -586,6 +589,6 @@ Library Debugger LibFFI Linker - ObjLink RtClosureInspect DebuggerUtils + GHCi diff --git a/compiler/ghc.mk b/compiler/ghc.mk index dc22eb6ac5..d93b87963b 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -580,7 +580,6 @@ compiler_stage2_dll0_MODULES = \ PrimOp \ RdrName \ Rules \ - Serialized \ SrcLoc \ StaticFlags \ StringBuffer \ @@ -609,49 +608,8 @@ ifeq "$(GhcWithInterpreter)" "YES" # These files are reacheable from DynFlags # only by GHCi-enabled code (see #9552) compiler_stage2_dll0_MODULES += \ - Bitmap \ - BlockId \ - ByteCodeAsm \ - ByteCodeInstr \ - ByteCodeItbls \ - CLabel \ - Cmm \ - CmmCallConv \ - CmmExpr \ - CmmInfo \ - CmmMachOp \ - CmmNode \ - CmmSwitch \ - CmmUtils \ - CodeGen.Platform \ - CodeGen.Platform.ARM \ - CodeGen.Platform.ARM64 \ - CodeGen.Platform.NoRegs \ - CodeGen.Platform.PPC \ - CodeGen.Platform.PPC_Darwin \ - CodeGen.Platform.SPARC \ - CodeGen.Platform.X86 \ - CodeGen.Platform.X86_64 \ - Hoopl \ - Hoopl.Dataflow \ - InteractiveEvalTypes \ - MkGraph \ - PprCmm \ - PprCmmDecl \ - PprCmmExpr \ - Reg \ - RegClass \ - SMRep \ - StgCmmArgRep \ - StgCmmClosure \ - StgCmmEnv \ - StgCmmLayout \ - StgCmmMonad \ - StgCmmProf \ - StgCmmTicky \ - StgCmmUtils \ - StgSyn \ - Stream + ByteCodeTypes \ + InteractiveEvalTypes endif compiler_stage2_dll0_HS_OBJS = \ @@ -769,4 +727,3 @@ ghc/stage1/package-data.mk : compiler/stage1/inplace-pkg-config-munged endif endif - diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index c69cede7f3..875de879cb 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -8,8 +8,7 @@ module ByteCodeAsm ( assembleBCOs, assembleBCO, - CompiledByteCode(..), - UnlinkedBCO(..), BCOPtr(..), BCONPtr(..), bcoFreeNames, + bcoFreeNames, SizedSeq, sizeSS, ssElts, iNTERP_STACK_CHECK_THRESH ) where @@ -18,12 +17,13 @@ module ByteCodeAsm ( import ByteCodeInstr import ByteCodeItbls +import ByteCodeTypes +import HscTypes import Name import NameSet import Literal import TyCon -import PrimOp import FastString import StgCmmLayout ( ArgRep(..) ) import SMRep @@ -32,6 +32,9 @@ import Outputable import Platform import Util +-- From iserv +import SizedSeq + #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) #endif @@ -47,6 +50,7 @@ import Data.Array.Base ( UArray(..) ) import Data.Array.Unsafe( castSTUArray ) +import qualified Data.ByteString as B import Foreign import Data.Char ( ord ) import Data.List @@ -54,44 +58,12 @@ import Data.Map (Map) import Data.Maybe (fromMaybe) import qualified Data.Map as Map -import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld ) - -- ----------------------------------------------------------------------------- -- Unlinked BCOs -- CompiledByteCode represents the result of byte-code -- compiling a bunch of functions and data types -data CompiledByteCode - = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings - ItblEnv -- A mapping from DataCons to their itbls - -instance Outputable CompiledByteCode where - ppr (ByteCode bcos _) = ppr bcos - - -data UnlinkedBCO - = UnlinkedBCO { - unlinkedBCOName :: Name, - unlinkedBCOArity :: Int, - unlinkedBCOInstrs :: ByteArray#, -- insns - unlinkedBCOBitmap :: ByteArray#, -- bitmap - unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs - } - -data BCOPtr - = BCOPtrName Name - | BCOPtrPrimOp PrimOp - | BCOPtrBCO UnlinkedBCO - | BCOPtrBreakInfo BreakInfo - | BCOPtrArray (MutableByteArray# RealWorld) - -data BCONPtr - = BCONPtrWord Word - | BCONPtrLbl FastString - | BCONPtrItbl Name - -- | Finds external references. Remember to remove the names -- defined by this group of BCOs themselves bcoFreeNames :: UnlinkedBCO -> NameSet @@ -105,12 +77,6 @@ bcoFreeNames bco map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] ) -instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) - = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] - -- ----------------------------------------------------------------------------- -- The bytecode assembler @@ -122,11 +88,11 @@ instance Outputable UnlinkedBCO where -- bytecode address in this BCO. -- Top level assembler fn. -assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode -assembleBCOs dflags proto_bcos tycons - = do itblenv <- mkITbls dflags tycons - bcos <- mapM (assembleBCO dflags) proto_bcos - return (ByteCode bcos itblenv) +assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs hsc_env proto_bcos tycons = do + itblenv <- mkITbls hsc_env tycons + bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos + return (ByteCode bcos itblenv (concat (map protoBCOFFIs proto_bcos))) assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do @@ -161,15 +127,9 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d ASSERT(n_insns == sizeSS final_insns) return () let asm_insns = ssElts final_insns - barr a = case a of UArray _lo _hi _n b -> b - - insns_arr = Array.listArray (0, n_insns - 1) asm_insns - !insns_barr = barr insns_arr - + insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns bitmap_arr = mkBitmapArray bsize bitmap - !bitmap_barr = barr bitmap_arr - - ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until @@ -191,23 +151,6 @@ type AsmState = (SizedSeq Word16, SizedSeq BCONPtr, SizedSeq BCOPtr) -data SizedSeq a = SizedSeq !Word [a] -emptySS :: SizedSeq a -emptySS = SizedSeq 0 [] - -addToSS :: SizedSeq a -> a -> SizedSeq a -addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs) - -addListToSS :: SizedSeq a -> [a] -> SizedSeq a -addListToSS (SizedSeq n r_xs) xs - = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs) - -ssElts :: SizedSeq a -> [a] -ssElts (SizedSeq _ r_xs) = reverse r_xs - -sizeSS :: SizedSeq a -> Word -sizeSS (SizedSeq n _) = n - data Operand = Op Word | SmallOp Word16 @@ -365,9 +308,7 @@ 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_UBX (Left lit) nws -> do np <- literal lit - emit bci_PUSH_UBX [Op np, SmallOp nws] - PUSH_UBX (Right aa) nws -> do np <- addr aa + PUSH_UBX lit nws -> do np <- literal lit emit bci_PUSH_UBX [Op np, SmallOp nws] PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] @@ -437,7 +378,9 @@ assembleI dflags i = case i of literal (MachChar c) = int (ord c) literal (MachInt64 ii) = int64 (fromIntegral ii) literal (MachWord64 ii) = int64 (fromIntegral ii) - literal other = pprPanic "ByteCodeAsm.literal" (ppr other) + literal (MachStr bs) = lit [BCONPtrStr (bs `B.snoc` 0)] + -- MachStr requires a zero-terminator when emitted + literal LitInteger{} = panic "ByteCodeAsm.literal: LitInteger" litlabel fs = lit [BCONPtrLbl fs] addr = words . mkLitPtr diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index f331214892..f74b4c439a 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -9,11 +9,13 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" import ByteCodeInstr -import ByteCodeItbls import ByteCodeAsm -import ByteCodeLink -import LibFFI +import ByteCodeTypes +import GHCi +import GHCi.FFI +import GHCi.RemoteTypes +import BasicTypes import DynFlags import Outputable import Platform @@ -45,7 +47,6 @@ import OrdList import Data.List import Foreign -import Foreign.C #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) @@ -59,8 +60,6 @@ import Data.Maybe import Module import Control.Arrow ( second ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map @@ -69,42 +68,43 @@ import Data.Ord -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module -byteCodeGen :: DynFlags +byteCodeGen :: HscEnv -> Module -> CoreProgram -> [TyCon] -> ModBreaks -> IO CompiledByteCode -byteCodeGen dflags this_mod binds tycs modBreaks - = do showPass dflags "ByteCodeGen" +byteCodeGen hsc_env this_mod binds tycs modBreaks + = do let dflags = hsc_dflags hsc_env + showPass dflags "ByteCodeGen" let flatBinds = [ (bndr, simpleFreeVars rhs) | (bndr, rhs) <- flattenBinds binds] us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos) - <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds) + (BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos) + <- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds) - when (notNull mallocd) + when (notNull ffis) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - assembleBCOs dflags proto_bcos tycs - where + assembleBCOs hsc_env proto_bcos tycs -- ----------------------------------------------------------------------------- -- Generating byte code for an expression -- Returns: (the root BCO for this expression, -- a list of auxilary BCOs resulting from compiling closures) -coreExprToBCOs :: DynFlags +coreExprToBCOs :: HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO -coreExprToBCOs dflags this_mod expr - = do showPass dflags "ByteCodeGen" +coreExprToBCOs hsc_env this_mod expr + = do let dflags = hsc_dflags hsc_env + showPass dflags "ByteCodeGen" -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything @@ -115,7 +115,7 @@ coreExprToBCOs dflags this_mod expr -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco) - <- runBc dflags us this_mod emptyModBreaks $ + <- runBc hsc_env us this_mod emptyModBreaks $ schemeTopBind (invented_id, simpleFreeVars expr) when (notNull mallocd) @@ -184,9 +184,9 @@ mkProtoBCO -> Word16 -> [StgWord] -> Bool -- True <=> is a return point, rather than a function - -> [BcPtr] + -> [FFIInfo] -> ProtoBCO name -mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks +mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check, @@ -194,7 +194,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo protoBCOBitmapSize = bitmap_size, protoBCOArity = arity, protoBCOExpr = origin, - protoBCOPtrs = mallocd_blocks + protoBCOFFIs = ffis } where -- Overestimate the stack usage (in words) of this BCO, @@ -1042,27 +1042,23 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l void marshall_code ( StgWord* ptr_to_top_of_stack ) -} -- resolve static address - get_target_info = do + maybe_static_target = case target of - DynamicTarget - -> return (False, panic "ByteCodeGen.generateCCall(dyn)") - + DynamicTarget -> Nothing StaticTarget _ _ _ False -> - panic "generateCCall: unexpected FFI value import" - StaticTarget _ target _ True - -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) - return (True, res) + panic "generateCCall: unexpected FFI value import" + StaticTarget _ target _ True -> + Just (MachLabel target mb_size IsFunction) where - stdcall_adj_target + mb_size | OSMinGW32 <- platformOS (targetPlatform dflags) , StdCallConv <- cconv - = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in - mkFastString (unpackFS target ++ '@':show size) + = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags) | otherwise - = target + = Nothing - (is_static, static_target_addr) <- get_target_info let + is_static = isJust maybe_static_target -- Get the arg reps, zapping the leading Addr# in the dynamic case a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" @@ -1073,8 +1069,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- push the Addr# (push_Addr, d_after_Addr) - | is_static - = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW], + | Just machlabel <- maybe_static_target + = (toOL [PUSH_UBX machlabel addr_sizeW], d_after_args + fromIntegral addr_sizeW) | otherwise -- is already on the stack = (nilOL, d_after_args) @@ -1086,7 +1082,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l r_lit = mkDummyLiteral r_rep push_r = (if returns_void then nilOL - else unitOL (PUSH_UBX (Left r_lit) r_sizeW)) + else unitOL (PUSH_UBX r_lit r_sizeW)) -- generate the marshalling code we're going to call @@ -1096,16 +1092,26 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- is. See comment in Interpreter.c with the CCALL instruction. stk_offset = trunc16 $ d_after_r - s + conv = case cconv of + CCallConv -> FFICCall + StdCallConv -> FFIStdCall + _ -> panic "ByteCodeGen: unexpected calling convention" + -- the only difference in libffi mode is that we prepare a cif -- describing the call type by calling libffi, and we attach the -- address of this to the CCALL instruction. - token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep - let addr_of_marshaller = castPtrToFunPtr token - recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) + + let ffires = primRepToFFIType dflags r_rep + ffiargs = map (primRepToFFIType dflags) a_reps + hsc_env <- getHscEnv + rp <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) + let token = fromRemotePtr rp + recordFFIBc token + let -- do the call - do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller) + do_call = unitOL (CCALL stk_offset token (fromIntegral (fromEnum (playInterruptible safety)))) -- slide and return wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s) @@ -1116,6 +1122,24 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) +primRepToFFIType :: DynFlags -> PrimRep -> FFIType +primRepToFFIType dflags r + = case r of + VoidRep -> FFIVoid + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> FFISInt64 + Word64Rep -> FFIUInt64 + AddrRep -> FFIPointer + FloatRep -> FFIFloat + DoubleRep -> FFIDouble + _ -> panic "primRepToFFIType" + where + (signed_word, unsigned_word) + | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32) + | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64) + | otherwise = panic "primTyDescChar" + -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. mkDummyLiteral :: PrimRep -> Literal @@ -1240,7 +1264,7 @@ implement_tagToId d s p arg names steps = map (mkStep label_exit) infos return (push_arg - `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1) + `appOL` unitOL (PUSH_UBX MachNullAddr 1) -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, @@ -1319,7 +1343,7 @@ pushAtom _ _ (AnnLit lit) = do dflags <- getDynFlags let code rep = let size_host_words = fromIntegral (argRepSizeW dflags rep) - in return (unitOL (PUSH_UBX (Left lit) size_host_words), + in return (unitOL (PUSH_UBX lit size_host_words), size_host_words) case lit of @@ -1332,42 +1356,16 @@ pushAtom _ _ (AnnLit lit) = do MachDouble _ -> code D MachChar _ -> code N MachNullAddr -> code N - MachStr s -> pushStr s + 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" - where - pushStr s - = let getMallocvilleAddr - = - -- we could grab the Ptr from the ForeignPtr, - -- but then we have no way to control its lifetime. - -- In reality it'll probably stay alive long enoungh - -- by virtue of the global FastString table, but - -- to be on the safe side we copy the string into - -- a malloc'd area of memory. - do let n = BS.length s - ptr <- ioToBc (mallocBytes (n+1)) - recordMallocBc ptr - ioToBc ( - BS.unsafeUseAsCString s $ \p -> do - memcpy ptr p (fromIntegral n) - pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) - return ptr - ) - in do - addr <- getMallocvilleAddr - -- Get the addr on the stack, untaggedly - return (unitOL (PUSH_UBX (Right addr) 1), 1) pushAtom _ _ expr = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, expr))) -foreign import ccall unsafe "memcpy" - memcpy :: Ptr a -> Ptr b -> CSize -> IO () - -- ----------------------------------------------------------------------------- -- Given a bunch of alts code and their discrs, do the donkey work @@ -1627,15 +1625,13 @@ typeArgRep = toArgRep . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad -type BcPtr = Either ItblPtr (Ptr ()) - data BcM_State = BcM_State - { bcm_dflags :: DynFlags - , uniqSupply :: UniqSupply -- for generating fresh variable names - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word16 -- for generating local labels - , malloced :: [BcPtr] -- thunks malloced for current BCO + { bcm_hsc_env :: HscEnv + , uniqSupply :: UniqSupply -- for generating fresh variable names + , thisModule :: Module -- current module (for breakpoints) + , nextlabel :: Word16 -- for generating local labels + , ffis :: [FFIInfo] -- ffi info blocks, to free later -- Should be free()d when it is GCd , breakArray :: BreakArray -- array of breakpoint flags } @@ -1647,10 +1643,10 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r +runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r) -runBc dflags us this_mod modBreaks (BcM m) - = m (BcM_State dflags us this_mod 0 [] breakArray) +runBc hsc_env us this_mod modBreaks (BcM m) + = m (BcM_State hsc_env us this_mod 0 [] breakArray) where breakArray = modBreaks_flags modBreaks @@ -1684,19 +1680,18 @@ instance Monad BcM where return = pure instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, bcm_dflags st) + getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) -emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name) -emitBc bco - = BcM $ \st -> return (st{malloced=[]}, bco (malloced st)) +getHscEnv :: BcM HscEnv +getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) -recordMallocBc :: Ptr a -> BcM () -recordMallocBc a - = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ()) +emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) -recordItblMallocBc :: ItblPtr -> BcM () -recordItblMallocBc a - = BcM $ \st -> return (st{malloced = Left a : malloced st}, ()) +recordFFIBc :: Ptr () -> BcM () +recordFFIBc a + = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) getLabelBc :: BcM Word16 getLabelBc diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs index 2de4941aa6..4f2b82ba27 100644 --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -6,17 +6,15 @@ -- | ByteCodeInstrs: Bytecode instruction definitions module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) + BCInstr(..), ProtoBCO(..), bciStackUse, ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -import ByteCodeItbls ( ItblPtr ) - +import ByteCodeTypes import StgCmmLayout ( ArgRep(..) ) import PprCore -import Type import Outputable import FastString import Name @@ -28,7 +26,6 @@ import VarSet import PrimOp import SMRep -import Module (Module) import GHC.Exts import Data.Word @@ -46,7 +43,7 @@ data ProtoBCO a -- what the BCO came from protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), -- malloc'd pointers - protoBCOPtrs :: [Either ItblPtr (Ptr ())] + protoBCOFFIs :: [FFIInfo] } type LocalLabel = Word16 @@ -70,7 +67,7 @@ data BCInstr | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep -- Pushing literals - | PUSH_UBX (Either Literal (Ptr ())) Word16 + | 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 @@ -144,28 +141,13 @@ data BCInstr -- Breakpoints | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo -data BreakInfo - = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: {-# UNPACK #-} !Int - , breakInfo_vars :: [(Id,Word16)] - , breakInfo_resty :: Type - } - -instance Outputable BreakInfo where - ppr info = text "BreakInfo" <+> - parens (ppr (breakInfo_module info) <+> - ppr (breakInfo_number info) <+> - ppr (breakInfo_vars info) <+> - ppr (breakInfo_resty info)) - -- ----------------------------------------------------------------------------- -- Printing bytecode instructions instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) + ppr (ProtoBCO name instrs bitmap bsize arity origin ffis) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show malloced) <> colon) + <+> text (show ffis) <> colon) $$ nest 3 (case origin of Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' @@ -210,19 +192,18 @@ 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_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit - ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa) - ppr PUSH_APPLY_N = text "PUSH_APPLY_N" - ppr PUSH_APPLY_V = text "PUSH_APPLY_V" - ppr PUSH_APPLY_F = text "PUSH_APPLY_F" - ppr PUSH_APPLY_D = text "PUSH_APPLY_D" - ppr PUSH_APPLY_L = text "PUSH_APPLY_L" - ppr PUSH_APPLY_P = text "PUSH_APPLY_P" - ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" - ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" - ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" - ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" - ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + 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" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs index 01420f5e34..5a3e6d3e1a 100644 --- a/compiler/ghci/ByteCodeItbls.hs +++ b/compiler/ghci/ByteCodeItbls.hs @@ -5,416 +5,69 @@ -- -- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes -module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls, peekItbl - , StgInfoTable(..) - ) where +module ByteCodeItbls ( mkITbls ) where #include "HsVersions.h" +import ByteCodeTypes +import GHCi +import GHCi.RemoteTypes import DynFlags -import Panic -import Platform +import HscTypes import Name ( Name, getName ) import NameEnv import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Type ( flattenRepType, repType, typePrimRep ) import StgCmmLayout ( mkVirtHeapOffsets ) -import CmmInfo ( conInfoTableSizeB, profInfoTableSizeW ) import Util - -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Strict -import Data.Maybe -import Foreign -import Foreign.C - -import GHC.Exts ( Int(I#), addr2Int# ) -import GHC.Ptr ( FunPtr(..) ) +import Panic {- Manufacturing of info tables for DataCons -} -newtype ItblPtr = ItblPtr (Ptr ()) deriving Show - -itblCode :: DynFlags -> ItblPtr -> Ptr () -itblCode dflags (ItblPtr ptr) - | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags - | otherwise = castPtr ptr - -type ItblEnv = NameEnv (Name, ItblPtr) - -- We need the Name in the range so we know which - -- elements to filter out when unloading a module +-- Make info tables for the data decls in this module +mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv +mkITbls hsc_env tcs = + foldr plusNameEnv emptyNameEnv <$> + mapM (mkITbl hsc_env) (filter isDataTyCon tcs) + where + mkITbl :: HscEnv -> TyCon -> IO ItblEnv + mkITbl hsc_env tc + | dcs `lengthIs` n -- paranoia; this is an assertion. + = make_constr_itbls hsc_env dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + mkITbl _ _ = panic "mkITbl" mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] - --- Make info tables for the data decls in this module -mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv -mkITbls _ [] = return emptyNameEnv -mkITbls dflags (tc:tcs) = do itbls <- mkITbl dflags tc - itbls2 <- mkITbls dflags tcs - return (itbls `plusNameEnv` itbls2) - -mkITbl :: DynFlags -> TyCon -> IO ItblEnv -mkITbl dflags tc - | not (isDataTyCon tc) - = return emptyNameEnv - | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls dflags dcs - where - dcs = tyConDataCons tc - n = tyConFamilySize tc - -mkITbl _ _ = error "Unmatched patter in mkITbl: assertion failed!" - -#include "../includes/rts/storage/ClosureTypes.h" -cONSTR :: Int -- Defined in ClosureTypes.h -cONSTR = CONSTR - -- Assumes constructors are numbered from zero, not one -make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv -make_constr_itbls dflags cons - = do is <- mapM mk_dirret_itbl (zip cons [0..]) - return (mkItblEnv is) - where - mk_dirret_itbl (dcon, conNo) - = mk_itbl dcon conNo stg_interp_constr_entry - - mk_itbl :: DataCon -> Int -> EntryFunPtr -> IO (Name,ItblPtr) - mk_itbl dcon conNo entry_addr = do - let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] - (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args - - ptrs' = ptr_wds - nptrs' = tot_wds - ptr_wds - nptrs_really - | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' - | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' - code' = mkJumpToAddr dflags entry_addr - itbl = StgInfoTable { - entry = if ghciTablesNextToCode - then Nothing - else Just entry_addr, - ptrs = fromIntegral ptrs', - nptrs = fromIntegral nptrs_really, - tipe = fromIntegral cONSTR, - srtlen = fromIntegral conNo, - code = if ghciTablesNextToCode - then Just code' - else Nothing - } - - -- Make a piece of code to jump to "entry_label". - -- This is the only arch-dependent bit. - addrCon <- newExecConItbl dflags itbl (dataConIdentity dcon) - --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) - --putStrLn ("# ptrs of itbl is " ++ show ptrs) - --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) - return (getName dcon, ItblPtr (castFunPtrToPtr addrCon)) - - --- Make code which causes a jump to the given address. This is the --- only arch-dependent bit of the itbl story. - --- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc. -#include "nativeGen/NCG.h" - -type ItblCodes = Either [Word8] [Word32] - -funPtrToInt :: FunPtr a -> Int -funPtrToInt (FunPtr a#) = I# (addr2Int# a#) - -mkJumpToAddr :: DynFlags -> EntryFunPtr -> ItblCodes -mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of - ArchSPARC -> - -- After some consideration, we'll try this, where - -- 0x55555555 stands in for the address to jump to. - -- According to includes/rts/MachRegs.h, %g3 is very - -- likely indeed to be baggable. - -- - -- 0000 07155555 sethi %hi(0x55555555), %g3 - -- 0004 8610E155 or %g3, %lo(0x55555555), %g3 - -- 0008 81C0C000 jmp %g3 - -- 000c 01000000 nop - - let w32 = fromIntegral (funPtrToInt a) - - hi22, lo10 :: Word32 -> Word32 - lo10 x = x .&. 0x3FF - hi22 x = (x `shiftR` 10) .&. 0x3FFFF - - in Right [ 0x07000000 .|. (hi22 w32), - 0x8610E000 .|. (lo10 w32), - 0x81C0C000, - 0x01000000 ] - - ArchPPC -> - -- We'll use r12, for no particular reason. - -- 0xDEADBEEF stands for the address: - -- 3D80DEAD lis r12,0xDEAD - -- 618CBEEF ori r12,r12,0xBEEF - -- 7D8903A6 mtctr r12 - -- 4E800420 bctr - - let w32 = fromIntegral (funPtrToInt a) - hi16 x = (x `shiftR` 16) .&. 0xFFFF - lo16 x = x .&. 0xFFFF - in Right [ 0x3D800000 .|. hi16 w32, - 0x618C0000 .|. lo16 w32, - 0x7D8903A6, 0x4E800420 ] - - ArchX86 -> - -- Let the address to jump to be 0xWWXXYYZZ. - -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax - -- which is - -- B8 ZZ YY XX WW FF E0 - - let w32 = fromIntegral (funPtrToInt a) :: Word32 - insnBytes :: [Word8] - insnBytes - = [0xB8, byte0 w32, byte1 w32, - byte2 w32, byte3 w32, - 0xFF, 0xE0] - in - Left insnBytes - - ArchX86_64 -> - -- Generates: - -- jmpq *.L1(%rip) - -- .align 8 - -- .L1: - -- .quad <addr> - -- - -- which looks like: - -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 <f+0x10> - -- with addr at 10. - -- - -- We need a full 64-bit pointer (we can't assume the info table is - -- allocated in low memory). Assuming the info pointer is aligned to - -- an 8-byte boundary, the addr will also be aligned. - - let w64 = fromIntegral (funPtrToInt a) :: Word64 - insnBytes :: [Word8] - insnBytes - = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, - byte0 w64, byte1 w64, byte2 w64, byte3 w64, - byte4 w64, byte5 w64, byte6 w64, byte7 w64] - in - Left insnBytes - - ArchAlpha -> - let w64 = fromIntegral (funPtrToInt a) :: Word64 - in Right [ 0xc3800000 -- br at, .+4 - , 0xa79c000c -- ldq at, 12(at) - , 0x6bfc0000 -- jmp (at) # with zero hint -- oh well - , 0x47ff041f -- nop - , fromIntegral (w64 .&. 0x0000FFFF) - , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ] - - ArchARM { } -> - -- Generates Arm sequence, - -- ldr r1, [pc, #0] - -- bx r1 - -- - -- which looks like: - -- 00000000 <.addr-0x8>: - -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr> - -- 4: 11ff2fe1 bx r1 - let w32 = fromIntegral (funPtrToInt a) :: Word32 - in Left [ 0x00, 0x10, 0x9f, 0xe5 - , 0x11, 0xff, 0x2f, 0xe1 - , byte0 w32, byte1 w32, byte2 w32, byte3 w32] - - arch -> - panic ("mkJumpToAddr not defined for " ++ show arch) - -byte0 :: (Integral w) => w -> Word8 -byte0 w = fromIntegral w - -byte1, byte2, byte3, byte4, byte5, byte6, byte7 - :: (Integral w, Bits w) => w -> Word8 -byte1 w = fromIntegral (w `shiftR` 8) -byte2 w = fromIntegral (w `shiftR` 16) -byte3 w = fromIntegral (w `shiftR` 24) -byte4 w = fromIntegral (w `shiftR` 32) -byte5 w = fromIntegral (w `shiftR` 40) -byte6 w = fromIntegral (w `shiftR` 48) -byte7 w = fromIntegral (w `shiftR` 56) - --- entry point for direct returns for created constr itbls -foreign import ccall "&stg_interp_constr_entry" - stg_interp_constr_entry :: EntryFunPtr - - - - --- Ultra-minimalist version specially for constructors -#if SIZEOF_VOID_P == 8 -type HalfWord = Word32 -type FullWord = Word64 -#else -type HalfWord = Word16 -type FullWord = Word32 -#endif - -data StgConInfoTable = StgConInfoTable { - conDesc :: Ptr Word8, - infoTable :: StgInfoTable -} - -sizeOfConItbl :: DynFlags -> StgConInfoTable -> Int -sizeOfConItbl dflags conInfoTable - = sum [ fieldSz conDesc conInfoTable - , sizeOfItbl dflags (infoTable conInfoTable) ] - -pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable - -> StgConInfoTable - -> IO () -pokeConItbl dflags wr_ptr ex_ptr itbl - = flip evalStateT (castPtr wr_ptr) $ do - when ghciTablesNextToCode $ do - let con_desc = conDesc itbl `minusPtr` - (ex_ptr `plusPtr` conInfoTableSizeB dflags) - store (fromIntegral con_desc :: Word32) - when (wORD_SIZE dflags == 8) $ - store (fromIntegral con_desc :: Word32) - store' (sizeOfItbl dflags) (pokeItbl dflags) (infoTable itbl) - unless ghciTablesNextToCode $ store (conDesc itbl) - -type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ())) - -data StgInfoTable = StgInfoTable { - entry :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode - ptrs :: HalfWord, - nptrs :: HalfWord, - tipe :: HalfWord, - srtlen :: HalfWord, - code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode - } - -sizeOfItbl :: DynFlags -> StgInfoTable -> Int -sizeOfItbl dflags itbl - = sum - [ - if ghciTablesNextToCode then 0 else fieldSz (fromJust . entry) itbl, - fieldSz ptrs itbl, - fieldSz nptrs itbl, - fieldSz tipe itbl, - fieldSz srtlen itbl, - if ghciTablesNextToCode then case mkJumpToAddr dflags undefined of - Left xs -> sizeOf (head xs) * length xs - Right xs -> sizeOf (head xs) * length xs - else 0 - ] - + if rtsIsProfiled then profInfoTableSizeW * wORD_SIZE dflags - else 0 - -pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO () -pokeItbl _ a0 itbl - = flip evalStateT (castPtr a0) - $ do - case entry itbl of - Nothing -> return () - Just e -> store e - when rtsIsProfiled $ do - store (0 :: FullWord) - store (0 :: FullWord) - store (ptrs itbl) - store (nptrs itbl) - store (tipe itbl) - store (srtlen itbl) - case code itbl of - Nothing -> return () - Just (Left xs) -> mapM_ store xs - Just (Right xs) -> mapM_ store xs - -peekItbl :: DynFlags -> Ptr StgInfoTable -> IO StgInfoTable -peekItbl dflags a0 - = flip evalStateT (castPtr a0) - $ do - entry' <- if ghciTablesNextToCode - then return Nothing - else liftM Just load - when rtsIsProfiled $ do - (_ :: Ptr FullWord) <- advance - (_ :: Ptr FullWord) <- advance - return () - ptrs' <- load - nptrs' <- load - tipe' <- load - srtlen' <- load - code' <- if ghciTablesNextToCode - then liftM Just $ case mkJumpToAddr dflags undefined of - Left xs -> - liftM Left $ sequence (replicate (length xs) load) - Right xs -> - liftM Right $ sequence (replicate (length xs) load) - else return Nothing - return - StgInfoTable { - entry = entry', - ptrs = ptrs', - nptrs = nptrs', - tipe = tipe', - srtlen = srtlen' - ,code = code' - } - -fieldSz :: Storable b => (a -> b) -> a -> Int -fieldSz sel x = sizeOf (sel x) - -type PtrIO = StateT (Ptr Word8) IO - -advance :: Storable a => PtrIO (Ptr a) -advance = advance' sizeOf - -advance' :: (a -> Int) -> PtrIO (Ptr a) -advance' fSizeOf = state adv - where adv addr = case castPtr addr of - addrCast -> - (addrCast, - addr `plusPtr` sizeOfPointee fSizeOf addrCast) - -sizeOfPointee :: (a -> Int) -> Ptr a -> Int -sizeOfPointee fSizeOf addr = fSizeOf (typeHack addr) - where typeHack = undefined :: Ptr a -> a - -store :: Storable a => a -> PtrIO () -store = store' sizeOf poke - -store' :: (a -> Int) -> (Ptr a -> a -> IO ()) -> a -> PtrIO () -store' fSizeOf fPoke x = do addr <- advance' fSizeOf - lift (fPoke addr x) - -load :: Storable a => PtrIO a -load = do addr <- advance - lift (peek addr) - -newExecConItbl :: DynFlags -> StgInfoTable -> [Word8] -> IO (FunPtr ()) -newExecConItbl dflags obj con_desc - = alloca $ \pcode -> do - let lcon_desc = length con_desc + 1{- null terminator -} - dummy_cinfo = StgConInfoTable { conDesc = nullPtr, infoTable = obj } - sz = fromIntegral (sizeOfConItbl dflags dummy_cinfo) - -- Note: we need to allocate the conDesc string next to the info - -- table, because on a 64-bit platform we reference this string - -- with a 32-bit offset relative to the info table, so if we - -- allocated the string separately it might be out of range. - wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode - ex_ptr <- peek pcode - let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz - , infoTable = obj } - pokeConItbl dflags wr_ptr ex_ptr cinfo - pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc - _flushExec sz ex_ptr -- Cache flush (if needed) - return (castPtrToFunPtr ex_ptr) - -foreign import ccall unsafe "allocateExec" - _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a) - -foreign import ccall unsafe "flushExec" - _flushExec :: CUInt -> Ptr a -> IO () +make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv +make_constr_itbls hsc_env cons = + mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) + where + dflags = hsc_dflags hsc_env + + mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) + mk_itbl dcon conNo = do + let rep_args = [ (typePrimRep rep_arg,rep_arg) + | arg <- dataConRepArgTys dcon + , rep_arg <- flattenRepType (repType arg) ] + + (tot_wds, ptr_wds, _) = + mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args + + ptrs' = ptr_wds + nptrs' = tot_wds - ptr_wds + nptrs_really + | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' + | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' + + descr = dataConIdentity dcon + + r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really conNo descr) + return (getName dcon, ItblPtr (fromRemotePtr r)) diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs index b977f370d3..aa92ecc610 100644 --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -12,18 +12,21 @@ -- | ByteCodeLink: Bytecode assembler and linker module ByteCodeLink ( ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr, lookupName - ,lookupIE + linkBCO, lookupStaticPtr, + lookupIE, + nameToCLabel, linkFail ) where #include "HsVersions.h" -import ByteCodeItbls -import ByteCodeAsm -import ObjLink +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.InfoTable +import SizedSeq -import DynFlags -import BasicTypes +import GHCi +import ByteCodeTypes +import HscTypes import Name import NameEnv import PrimOp @@ -34,27 +37,21 @@ import Outputable import Util -- Standard libraries - -import Data.Array.Base - -import Control.Monad -import Control.Monad.ST ( stToIO ) - -import GHC.Arr ( Array(..), STArray(..) ) +import Data.Array.Unboxed +import Foreign.Ptr import GHC.IO ( IO(..) ) import GHC.Exts -import GHC.Ptr ( castPtr ) {- Linking interpretables into something we can run -} -type ClosureEnv = NameEnv (Name, HValue) +type ClosureEnv = NameEnv (Name, ForeignHValue) emptyClosureEnv :: ClosureEnv emptyClosureEnv = emptyNameEnv -extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv +extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv extendClosureEnv cl_env pairs = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] @@ -62,173 +59,86 @@ extendClosureEnv cl_env pairs Linking interpretables into something we can run -} -{- -data BCO# = BCO# ByteArray# -- instrs :: Array Word16# - ByteArray# -- literals :: Array Word32# - PtrArray# -- ptrs :: Array HValue - ByteArray# -- itbls :: Array Addr# --} - -linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue -linkBCO dflags ie ce ul_bco - = do BCO bco# <- linkBCO' dflags ie ce ul_bco - -- SDM: Why do we need mkApUpd0 here? I *think* it's because - -- otherwise top-level interpreted CAFs don't get updated - -- after evaluation. A top-level BCO will evaluate itself and - -- return its value when entered, but it won't update itself. - -- Wrapping the BCO in an AP_UPD thunk will take care of the - -- update for us. - -- - -- Update: the above is true, but now we also have extra invariants: - -- (a) An AP thunk *must* point directly to a BCO - -- (b) A zero-arity BCO *must* be wrapped in an AP thunk - -- (c) An AP is always fully saturated, so we *can't* wrap - -- non-zero arity BCOs in an AP thunk. - -- - if (unlinkedBCOArity ul_bco > 0) - then return (HValue (unsafeCoerce# bco#)) - else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) } - - -linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO -linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) - -- Raises an IO exception on failure - = do let literals = ssElts literalsSS - ptrs = ssElts ptrsSS - - linked_literals <- mapM (lookupLiteral dflags ie) literals - - let n_literals = sizeSS literalsSS - n_ptrs = sizeSS ptrsSS - - ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs - - let - !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr - - litRange - | n_literals > 0 = (0, fromIntegral n_literals - 1) - | otherwise = (1, 0) - literals_arr :: UArray Word Word - literals_arr = listArray litRange linked_literals - !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr - - !(I# arity#) = arity - - newBCO insns_barr literals_barr ptrs_parr arity# bitmap - - --- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) -mkPtrsArray dflags ie ce n_ptrs ptrs = do - let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) - marr <- newArray_ ptrRange - let - fill (BCOPtrName n) i = do - ptr <- lookupName ce n - unsafeWrite marr i ptr - fill (BCOPtrPrimOp op) i = do - ptr <- lookupPrimOp op - unsafeWrite marr i ptr - fill (BCOPtrBCO ul_bco) i = do - BCO bco# <- linkBCO' dflags ie ce ul_bco - writeArrayBCO marr i bco# - fill (BCOPtrBreakInfo brkInfo) i = - unsafeWrite marr i (HValue (unsafeCoerce# brkInfo)) - fill (BCOPtrArray brkArray) i = - unsafeWrite marr i (HValue (unsafeCoerce# brkArray)) - zipWithM_ fill ptrs [0..] - unsafeFreeze marr - -newtype IOArray i e = IOArray (STArray RealWorld i e) - -instance MArray IOArray e IO where - getBounds (IOArray marr) = stToIO $ getBounds marr - getNumElements (IOArray marr) = stToIO $ getNumElements marr - newArray lu init = stToIO $ do - marr <- newArray lu init; return (IOArray marr) - newArray_ lu = stToIO $ do - marr <- newArray_ lu; return (IOArray marr) - unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i) - unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e) - --- XXX HACK: we should really have a new writeArray# primop that takes a BCO#. -writeArrayBCO :: IOArray Word a -> Int -> BCO# -> IO () -writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# -> - case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> - (# s#, () #) } - -{- -writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO () -writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# -> - case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# -> - (# s#, () #) } --} - -data BCO = BCO BCO# - -newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO -newBCO instrs lits ptrs arity bitmap - = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of - (# s1, bco #) -> (# s1, BCO bco #) - - -lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word -lookupLiteral _ _ (BCONPtrWord lit) = return lit -lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm - return (W# (int2Word# (addr2Int# a#))) - -lookupStaticPtr :: FastString -> IO (Ptr ()) -lookupStaticPtr addr_of_label_string - = do let label_to_find = unpackFS addr_of_label_string - m <- lookupSymbol label_to_find - case m of - Just ptr -> return ptr - Nothing -> linkFail "ByteCodeLink: can't find label" - label_to_find - -lookupPrimOp :: PrimOp -> IO HValue -lookupPrimOp primop - = do let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol sym_to_find - case m of - Just (Ptr addr) -> case addrToAny# addr of - (# a #) -> return (HValue a) - Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find - -lookupName :: ClosureEnv -> Name -> IO HValue -lookupName ce nm - = case lookupNameEnv ce nm of - Just (_,aa) -> return aa - Nothing - -> ASSERT2(isExternalName nm, ppr nm) - do let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol sym_to_find - case m of - Just (Ptr addr) -> case addrToAny# addr of - (# a #) -> return (HValue a) - Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find - -lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a) -lookupIE dflags ie con_nm - = case lookupNameEnv ie con_nm of - Just (_, a) -> return (castPtr (itblCode dflags a)) - Nothing - -> do -- try looking up in the object files. - let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupSymbol sym_to_find1 - case m of - Just addr -> return addr - Nothing - -> do -- perhaps a nullary constructor? - let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupSymbol sym_to_find2 - case n of - Just addr -> return addr - Nothing -> linkFail "ByteCodeLink.lookupIE" - (sym_to_find1 ++ " or " ++ sym_to_find2) +linkBCO + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> UnlinkedBCO + -> IO ResolvedBCO +linkBCO hsc_env ie ce bco_ix + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + lits <- mapM (lookupLiteral hsc_env ie) (ssElts lits0) + ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix) (ssElts ptrs0) + return (ResolvedBCO arity insns bitmap + (listArray (0, fromIntegral (sizeSS lits0)-1) lits) + (addListToSS emptySS ptrs)) + +lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral hsc_env _ (BCONPtrLbl sym) = do + Ptr a# <- lookupStaticPtr hsc_env sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral hsc_env ie (BCONPtrItbl nm) = do + Ptr a# <- lookupIE hsc_env ie nm + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral hsc_env _ (BCONPtrStr bs) = do + fromIntegral . ptrToWordPtr <$> mallocData hsc_env bs + +lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) +lookupStaticPtr hsc_env addr_of_label_string = do + m <- lookupSymbol hsc_env addr_of_label_string + case m of + Just ptr -> return ptr + Nothing -> linkFail "ByteCodeLink: can't find label" + (unpackFS addr_of_label_string) + +lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr a) +lookupIE hsc_env ie con_nm = + case lookupNameEnv ie con_nm of + Just (_, ItblPtr a) -> return (castPtr (conInfoPtr 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 + case m of + Just addr -> return (castPtr addr) + Nothing + -> do -- perhaps a nullary constructor? + let sym_to_find2 = nameToCLabel con_nm "static_info" + n <- lookupSymbol hsc_env sym_to_find2 + case n of + Just addr -> return (castPtr addr) + Nothing -> linkFail "ByteCodeLink.lookupIE" + (unpackFS sym_to_find1 ++ " or " ++ + unpackFS sym_to_find2) + +lookupPrimOp :: HscEnv -> PrimOp -> IO RemotePtr +lookupPrimOp hsc_env primop = do + let sym_to_find = primopToCLabel primop "closure" + m <- lookupSymbol hsc_env (mkFastString sym_to_find) + case m of + Just p -> return (toRemotePtr p) + Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find + +resolvePtr + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> BCOPtr + -> IO ResolvedBCOPtr +resolvePtr hsc_env _ie ce bco_ix (BCOPtrName nm) + | Just ix <- lookupNameEnv bco_ix nm = + return (ResolvedBCORef ix) -- ref to another BCO in this group + | Just (_, rhv) <- lookupNameEnv ce nm = + return (ResolvedBCOPtr (unsafeForeignHValueToHValueRef rhv)) + | otherwise = + ASSERT2(isExternalName nm, ppr nm) + do let sym_to_find = nameToCLabel nm "closure" + m <- lookupSymbol hsc_env sym_to_find + case m of + Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) + Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find) +resolvePtr hsc_env _ _ _ (BCOPtrPrimOp op) = + ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op +resolvePtr hsc_env ie ce bco_ix (BCOPtrBCO bco) = + ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix bco +resolvePtr _ _ _ _ (BCOPtrBreakInfo break_info) = + return (ResolvedBCOPtrLocal (unsafeCoerce# break_info)) +resolvePtr _ _ _ _ (BCOPtrArray break_array) = + return (ResolvedBCOPtrLocal (unsafeCoerce# break_array)) linkFail :: String -> String -> IO a linkFail who what @@ -246,8 +156,9 @@ linkFail who what ]) -nameToCLabel :: Name -> String -> String -nameToCLabel n suffix = label where +nameToCLabel :: Name -> String -> FastString +nameToCLabel n suffix = mkFastString label + where encodeZ = zString . zEncodeFS (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n packagePart = encodeZ (unitIdFS pkgKey) @@ -268,4 +179,3 @@ primopToCLabel primop suffix = concat , zString (zEncodeFS (occNameFS (primOpOcc primop))) , '_':suffix ] - diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs new file mode 100644 index 0000000000..0a8dd304b6 --- /dev/null +++ b/compiler/ghci/ByteCodeTypes.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE MagicHash #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler types +module ByteCodeTypes + ( CompiledByteCode(..), FFIInfo(..) + , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) + , ItblEnv, ItblPtr(..) + , BreakInfo(..) + ) where + +import FastString +import Id +import Module +import Name +import NameEnv +import Outputable +import PrimOp +import SizedSeq +import Type + +import Foreign +import Data.Array.Base ( UArray(..) ) +import Data.ByteString (ByteString) +import GHC.Exts + + +data CompiledByteCode + = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings + ItblEnv -- A mapping from DataCons to their itbls + [FFIInfo] -- ffi blocks we allocated + -- ToDo: we're not tracking strings that we malloc'd + +newtype FFIInfo = FFIInfo (Ptr ()) + deriving Show + +instance Outputable CompiledByteCode where + ppr (ByteCode bcos _ _) = ppr bcos + +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +newtype ItblPtr = ItblPtr (Ptr ()) deriving Show + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: Name, + unlinkedBCOArity :: Int, + unlinkedBCOInstrs :: UArray Int Word16, -- insns + unlinkedBCOBitmap :: UArray Int Word, -- bitmap + unlinkedBCOLits :: (SizedSeq BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: (SizedSeq BCOPtr) -- ptrs + } + +data BCOPtr + = BCOPtrName Name + | BCOPtrPrimOp PrimOp + | BCOPtrBCO UnlinkedBCO + | BCOPtrBreakInfo BreakInfo + | BCOPtrArray (MutableByteArray# RealWorld) + +data BCONPtr + = BCONPtrWord Word + | BCONPtrLbl FastString + | BCONPtrItbl Name + | BCONPtrStr ByteString + +data BreakInfo + = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: {-# UNPACK #-} !Int + , breakInfo_vars :: [(Id,Word16)] + , breakInfo_resty :: Type + } + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeSS lits), text "lits", + ppr (sizeSS ptrs), text "ptrs" ] + +instance Outputable BreakInfo where + ppr info = text "BreakInfo" <+> + parens (ppr (breakInfo_module info) <+> + ppr (breakInfo_number info) <+> + ppr (breakInfo_vars info) <+> + ppr (breakInfo_resty info)) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 2b9e732c4b..5c6a02d3ff 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -17,6 +17,8 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where import Linker import RtClosureInspect +import GHCi +import GHCi.RemoteTypes import GhcMonad import HscTypes import Id @@ -117,7 +119,8 @@ bindSuspensions t = do let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids - liftIO $ extendLinkEnv (zip names hvals) + fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) hvals + liftIO $ extendLinkEnv (zip names fhvs) modifySession $ \_ -> hsc_env {hsc_IC = new_ic } return t' where @@ -170,7 +173,8 @@ showTerm term = do let noop_log _ _ _ _ _ = return () expr = "show " ++ showPpr dflags bname _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} - txt_ <- withExtendedLinkEnv [(bname, val)] + fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkHValueRef val + txt_ <- withExtendedLinkEnv [(bname, fhv)] (GHC.compileExpr expr) let myprec = 10 -- application precedence. TODO Infix constructors let txt = unsafeCoerce# txt_ :: [a] diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index d1ff9134ec..096b809c26 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -4,8 +4,8 @@ module DebuggerUtils ( dataConInfoPtrToName, ) where +import GHCi.InfoTable import CmmInfo ( stdInfoTableSizeB ) -import ByteCodeItbls import DynFlags import FastString import TcRnTypes diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs new file mode 100644 index 0000000000..d9c26c1d47 --- /dev/null +++ b/compiler/ghci/GHCi.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} + +-- +-- | Interacting with the interpreter, whether it is running on an +-- external process or in the current process. +-- +module GHCi + ( -- * High-level interface to the interpreter + evalStmt, EvalStatus(..), EvalResult(..), EvalExpr(..) + , resumeStmt + , abandonStmt + , evalIO + , evalString + , evalStringToIOString + , mallocData + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + -- * Lower-level API using messages + , iservCmd, Message(..), withIServ, stopIServ + , iservCall, readIServ, writeIServ + , purgeLookupSymbolCache + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , mkEvalOpts + , fromEvalResult + ) where + +import GHCi.Message +import GHCi.Run +import GHCi.RemoteTypes +import HscTypes +import UniqFM +import Panic +import DynFlags +#ifndef mingw32_HOST_OS +import ErrUtils +import Outputable +#endif +import Exception +import BasicTypes +import FastString + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Binary +import Data.ByteString (ByteString) +import Data.IORef +import Foreign +import System.Exit +#ifndef mingw32_HOST_OS +import Data.Maybe +import System.Posix as Posix +#endif +import System.Process + +{- Note [Remote GHCi] + +When the flag -fexternal-interpreter is given to GHC, interpreted code +is run in a separate process called iserv, and we communicate with the +external process over a pipe using Binary-encoded messages. + +Motivation +~~~~~~~~~~ + +When the interpreted code is running in a separate process, it can +use a different "way", e.g. profiled or dynamic. This means + +- compiling Template Haskell code with -prof does not require + building the code without -prof first + +- when GHC itself is profiled, it can interpret unprofiled code, + and the same applies to dynamic linking. + +- An unprofiled GHCi can load and run profiled code, which means it + can use the stack-trace functionality provided by profiling without + taking the performance hit on the compiler that profiling would + entail. + +For other reasons see RemoteGHCi on the wiki. + +Implementation Overview +~~~~~~~~~~~~~~~~~~~~~~~ + +The main pieces are: + +- libraries/ghci, containing: + - types for talking about remote values (GHCi.RemoteTypes) + - the message protocol (GHCi.Message), + - implementation of the messages (GHCi.Run) + - implementation of Template Haskell (GHCi.TH) + - a few other things needed to run interpreted code + +- top-level iserv directory, containing the codefor the external + server. This is a fairly simple wrapper, most of the functionality + is provided by modules in libraries/ghci. + +- This module (GHCi) which provides the interface to the server used + by the rest of GHC. + +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, +interpreted code is run in the same process as GHC. + +Things that do not work with -fexternal-interpreter +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +dynCompileExpr cannot work, because we have no way to run code of an +unknown type in the remote process. This API fails with an error +message if it is used with -fexternal-interpreter. +-} + +-- | Run a command in the interpreter's context. With +-- @-fexternal-interpreter@, the command is serialized and sent to an +-- external iserv process, and the response is deserialized (hence the +-- @Binary@ constraint). With @-fno-external-interpreter@ we execute +-- the command directly here. +iservCmd :: Binary a => HscEnv -> Message a -> IO a +iservCmd hsc_env@HscEnv{..} msg + | gopt Opt_ExternalInterpreter hsc_dflags = + withIServ hsc_env $ \iserv -> + uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] + iservCall iserv msg + | otherwise = -- Just run it directly + run msg + + +-- Note [uninterruptibleMask_ and iservCmd] +-- +-- If we receive an async exception, such as ^C, while communicating +-- with the iserv process then we will be out-of-sync and not be able +-- to recoever. Thus we use uninterruptibleMask_ during +-- communication. A ^C will be delivered to the iserv process (because +-- signals get sent to the whole process group) which will interrupt +-- the running computation and return an EvalException result. + +-- | Grab a lock on the 'IServ' and do something with it. +-- Overloaded because this is used from TcM as well as IO. +withIServ + :: (MonadIO m, ExceptionMonad m) + => HscEnv -> (IServ -> m a) -> m a +withIServ HscEnv{..} action = + gmask $ \restore -> do + m <- liftIO $ takeMVar hsc_iserv + -- start the iserv process if we haven't done so yet + iserv <- maybe (liftIO $ startIServ hsc_dflags) return m + `gonException` (liftIO $ putMVar hsc_iserv Nothing) + -- free any ForeignHValues that have been garbage collected. + let iserv' = iserv{ iservPendingFrees = [] } + a <- (do + liftIO $ when (not (null (iservPendingFrees iserv))) $ + iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) + -- run the inner action + restore $ action iserv) + `gonException` (liftIO $ putMVar hsc_iserv (Just iserv')) + liftIO $ putMVar hsc_iserv (Just iserv') + return a + + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus [ForeignHValue]) +evalStmt hsc_env step foreign_expr = do + let dflags = hsc_dflags hsc_env + status <- withExpr foreign_expr $ \expr -> + iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) + handleEvalStatus hsc_env status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignHValue fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt :: HscEnv -> Bool -> ForeignHValue -> IO (EvalStatus [ForeignHValue]) +resumeStmt hsc_env step resume_ctxt = do + let dflags = hsc_dflags hsc_env + status <- withForeignHValue resume_ctxt $ \rhv -> + iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) + handleEvalStatus hsc_env status + +abandonStmt :: HscEnv -> ForeignHValue -> IO () +abandonStmt hsc_env resume_ctxt = do + withForeignHValue resume_ctxt $ \rhv -> + iservCmd hsc_env (AbandonStmt rhv) + +handleEvalStatus + :: HscEnv -> EvalStatus [HValueRef] -> IO (EvalStatus [ForeignHValue]) +handleEvalStatus hsc_env status = + case status of + EvalBreak a b c d -> return (EvalBreak a b c d) + EvalComplete alloc res -> + EvalComplete alloc <$> addFinalizer res + where + addFinalizer (EvalException e) = return (EvalException e) + addFinalizer (EvalSuccess rs) = do + EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs + +-- | Execute an action of type @IO ()@ +evalIO :: HscEnv -> ForeignHValue -> IO () +evalIO hsc_env fhv = do + liftIO $ withForeignHValue fhv $ \fhv -> + iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult + +-- | Execute an action of type @IO String@ +evalString :: HscEnv -> ForeignHValue -> IO String +evalString hsc_env fhv = do + liftIO $ withForeignHValue fhv $ \fhv -> + iservCmd hsc_env (EvalString fhv) >>= fromEvalResult + +-- | Execute an action of type @String -> IO String@ +evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String +evalStringToIOString hsc_env fhv str = do + liftIO $ withForeignHValue fhv $ \fhv -> + iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult + + +-- | Allocate and store the given bytes in memory, returning a pointer +-- to the memory in the remote process. +mallocData :: HscEnv -> ByteString -> IO (Ptr ()) +mallocData hsc_env bs = fromRemotePtr <$> iservCmd hsc_env (MallocData bs) + + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +initObjLinker :: HscEnv -> IO () +initObjLinker hsc_env = iservCmd hsc_env InitLinker + +lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) +lookupSymbol hsc_env@HscEnv{..} str + | gopt Opt_ExternalInterpreter hsc_dflags = + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + withIServ hsc_env $ \iserv@IServ{..} -> do + cache <- readIORef iservLookupSymbolCache + case lookupUFM cache str of + Just p -> return (Just p) + Nothing -> do + m <- uninterruptibleMask_ $ + iservCall iserv (LookupSymbol (unpackFS str)) + case m of + Nothing -> return Nothing + Just r -> do + let p = fromRemotePtr r + writeIORef iservLookupSymbolCache $! addToUFM cache str p + return (Just p) + | otherwise = + fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) + +lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) +lookupClosure hsc_env str = + iservCmd hsc_env (LookupClosure str) + +purgeLookupSymbolCache :: HscEnv -> IO () +purgeLookupSymbolCache hsc_env@HscEnv{..} = + when (gopt Opt_ExternalInterpreter hsc_dflags) $ + withIServ hsc_env $ \IServ{..} -> + writeIORef iservLookupSymbolCache emptyUFM + + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +-- Returns: +-- +-- Nothing => success +-- Just err_msg => failure +loadDLL :: HscEnv -> String -> IO (Maybe String) +loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) + +loadArchive :: HscEnv -> String -> IO () +loadArchive hsc_env str = iservCmd hsc_env (LoadArchive str) + +loadObj :: HscEnv -> String -> IO () +loadObj hsc_env str = iservCmd hsc_env (LoadObj str) + +unloadObj :: HscEnv -> String -> IO () +unloadObj hsc_env str = iservCmd hsc_env (UnloadObj str) + +addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) +addLibrarySearchPath hsc_env str = + fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) + +removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool +removeLibrarySearchPath hsc_env p = + iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) + +resolveObjs :: HscEnv -> IO SuccessFlag +resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs + +findSystemLibrary :: HscEnv -> String -> IO (Maybe String) +findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) + + +-- ----------------------------------------------------------------------------- +-- Raw calls and messages + +-- | Send a 'Message' and receive the response from the iserv process +iservCall :: Binary a => IServ -> Message a -> IO a +iservCall iserv@IServ{..} msg = + remoteCall iservPipe msg + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Read a value from the iserv process +readIServ :: IServ -> Get a -> IO a +readIServ iserv@IServ{..} get = + readPipe iservPipe get + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Send a value to the iserv process +writeIServ :: IServ -> Put -> IO () +writeIServ iserv@IServ{..} put = + writePipe iservPipe put + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +handleIServFailure :: IServ -> SomeException -> IO a +handleIServFailure IServ{..} e = do + ex <- getProcessExitCode iservProcess + case ex of + Just (ExitFailure n) -> + throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess iservProcess + _ <- waitForProcess iservProcess + throw e + +-- ----------------------------------------------------------------------------- +-- Starting and stopping the iserv process + +startIServ :: DynFlags -> IO IServ +#ifdef mingw32_HOST_OS +startIServ _ = panic "startIServ" + -- should not be called, because we disable -fexternal-interpreter on Windows. + -- (see DynFlags.makeDynFlagsConsistent) +#else +startIServ dflags = do + let flavour + | WayProf `elem` ways dflags = "-prof" + | WayDyn `elem` ways dflags = "-dyn" + | otherwise = "" + prog = pgm_i dflags ++ flavour + opts = getOpts dflags opt_i + debugTraceMsg dflags 3 $ text "Starting " <> text prog + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = show wfd1 : show rfd2 : opts + (_, _, _, ph) <- createProcess (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + lo_ref <- newIORef Nothing + cache_ref <- newIORef emptyUFM + return $ IServ + { iservPipe = Pipe { pipeRead = rh + , pipeWrite = wh + , pipeLeftovers = lo_ref } + , iservProcess = ph + , iservLookupSymbolCache = cache_ref + , iservPendingFrees = [] + } +#endif + +stopIServ :: HscEnv -> IO () +#ifdef mingw32_HOST_OS +stopIServ _ = return () +#else +stopIServ HscEnv{..} = + gmask $ \_restore -> do + m <- takeMVar hsc_iserv + maybe (return ()) stop m + putMVar hsc_iserv Nothing + where + stop iserv = do + ex <- getProcessExitCode (iservProcess iserv) + if isJust ex + then return () + else iservCall iserv Shutdown +#endif + +-- ----------------------------------------------------------------------------- +{- Note [External GHCi pointers] + +We have the following ways to reference things in GHCi: + +HValue +------ + +HValue is a direct reference to an value in the local heap. Obviously +we cannot use this to refer to things in the external process. + + +HValueRef +--------- + +HValueRef is a StablePtr to a heap-resident value. When +-fexternal-interpreter is used, this value resides in the external +process's heap. HValueRefs are mostly used to send pointers in +messages between GHC and iserv. + +An HValueRef must be explicitly freed when no longer required, using +freeHValueRefs, or by attaching a finalizer with mkForeignHValue. + +To get from an HValueRef to an HValue you can use 'wormholeRef', which +fails with an error message if -fexternal-interpreter is in use. + +ForeignHValue +------------- + +A ForeignHValue is an HValueRef with a finalizer that will free the +'HValueRef' when it is gargabe collected. We mostly use ForeignHValue +on the GHC side. + +The finalizer adds the HValueRef to the iservPendingFrees list in the +IServ record. The next call to iservCmd will free any HValueRefs in +the list. It was done this way rather than calling iservCmd directly, +because I didn't want to have arbitrary threads calling iservCmd. In +principle it would probably be ok, but it seems less hairy this way. +-} + +-- | Creates a 'ForeignHValue' that will automatically release the +-- 'HValueRef' when it is no longer referenced. +mkFinalizedHValue :: HscEnv -> HValueRef -> IO ForeignHValue +mkFinalizedHValue HscEnv{..} hvref = mkForeignHValue hvref free + where + !external = gopt Opt_ExternalInterpreter hsc_dflags + + free :: IO () + free + | not external = freeHValueRef hvref + | otherwise = + modifyMVar_ hsc_iserv $ \mb_iserv -> + case mb_iserv of + Nothing -> return Nothing -- already shut down + Just iserv@IServ{..} -> + return (Just iserv{iservPendingFrees = hvref : iservPendingFrees}) + +freeHValueRefs :: HscEnv -> [HValueRef] -> IO () +freeHValueRefs _ [] = return () +freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) + +-- | Convert a 'ForeignHValue' to an 'HValue' directly. This only works +-- when the interpreter is running in the same process as the compiler, +-- so it fails when @-fexternal-interpreter@ is on. +wormhole :: DynFlags -> ForeignHValue -> IO HValue +wormhole dflags r = wormholeRef dflags (unsafeForeignHValueToHValueRef r) + +-- | Convert an 'HValueRef' to an 'HValue' directly. This only works +-- when the interpreter is running in the same process as the compiler, +-- so it fails when @-fexternal-interpreter@ is on. +wormholeRef :: DynFlags -> HValueRef -> IO HValue +wormholeRef dflags r + | gopt Opt_ExternalInterpreter dflags + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") + | otherwise + = localHValueRef r + +-- ----------------------------------------------------------------------------- +-- Misc utils + +mkEvalOpts :: DynFlags -> Bool -> EvalOpts +mkEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = step + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags } + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs index 7c10fae331..11936c7c75 100644 --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-} {-# OPTIONS_GHC -fno-cse #-} -- -- (c) The University of Glasgow 2002-2006 @@ -24,11 +24,12 @@ module Linker ( getHValue, showLinkerState, #include "HsVersions.h" +import GHCi +import GHCi.RemoteTypes import LoadIface -import ObjLink import ByteCodeLink -import ByteCodeItbls import ByteCodeAsm +import ByteCodeTypes import TcRnMonad import Packages import DriverPhases @@ -63,7 +64,6 @@ import Data.Maybe import Control.Concurrent.MVar import System.FilePath -import System.IO import System.Directory import Exception @@ -147,35 +147,46 @@ extendLoadedPkgs pkgs = modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } -extendLinkEnv :: [(Name,HValue)] -> IO () --- Automatically discards shadowed bindings +extendLinkEnv :: [(Name,ForeignHValue)] -> IO () extendLinkEnv new_bindings = - modifyPLS_ $ \pls -> - let new_closure_env = extendClosureEnv (closure_env pls) new_bindings - in return pls{ closure_env = new_closure_env } + modifyPLS_ $ \pls -> do + let ce = closure_env pls + let new_ce = extendClosureEnv ce new_bindings + return pls{ closure_env = new_ce } deleteFromLinkEnv :: [Name] -> IO () deleteFromLinkEnv to_remove = - modifyPLS_ $ \pls -> - let new_closure_env = delListFromNameEnv (closure_env pls) to_remove - in return pls{ closure_env = new_closure_env } + modifyPLS_ $ \pls -> do + let ce = closure_env pls + let new_ce = delListFromNameEnv ce to_remove + return pls{ closure_env = new_ce } -- | Get the 'HValue' associated with the given name. -- -- May cause loading the module that contains the name. -- -- Throws a 'ProgramError' if loading fails or the name cannot be found. -getHValue :: HscEnv -> Name -> IO HValue +getHValue :: HscEnv -> Name -> IO ForeignHValue getHValue hsc_env name = do - initDynLinker (hsc_dflags hsc_env) + initDynLinker hsc_env pls <- modifyPLS $ \pls -> do if (isExternalName name) then do - (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan + [nameModule name] if (failed ok) then throwGhcExceptionIO (ProgramError "") else return (pls', pls') else return (pls, pls) - lookupName (closure_env pls) name + case lookupNameEnv (closure_env pls) name of + Just (_,aa) -> return aa + Nothing + -> ASSERT2(isExternalName name, ppr name) + do let sym_to_find = nameToCLabel name "closure" + m <- lookupClosure hsc_env (unpackFS sym_to_find) + case m of + Just hvref -> mkFinalizedHValue hsc_env hvref + Nothing -> linkFail "ByteCodeLink.lookupCE" + (unpackFS sym_to_find) linkDependencies :: HscEnv -> PersistentLinkerState -> SrcSpan -> [Module] @@ -195,14 +206,14 @@ linkDependencies hsc_env pls span needed_mods = do maybe_normal_osuf span needed_mods -- Link the packages and modules required - pls1 <- linkPackages' dflags pkgs pls - linkModules dflags pls1 lnks + pls1 <- linkPackages' hsc_env pkgs pls + linkModules hsc_env pls1 lnks -- | Temporarily extend the linker state. withExtendedLinkEnv :: (ExceptionMonad m) => - [(Name,HValue)] -> m a -> m a + [(Name,ForeignHValue)] -> m a -> m a withExtendedLinkEnv new_env action = gbracket (liftIO $ extendLinkEnv new_env) (\_ -> reset_old_env) @@ -219,19 +230,6 @@ withExtendedLinkEnv new_env action new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } --- filterNameMap removes from the environment all entries except --- those for a given set of modules; --- Note that this removes all *local* (i.e. non-isExternal) names too --- (these are the temporary bindings from the command line). --- Used to filter both the ClosureEnv and ItblEnv - -filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) -filterNameMap mods env - = filterNameEnv keep_elt env - where - keep_elt (n,_) = isExternalName n - && (nameModule n `elem` mods) - -- | Display the persistent linker state. showLinkerState :: DynFlags -> IO () @@ -268,41 +266,45 @@ showLinkerState dflags -- nothing. This is useful in Template Haskell, where we call it before -- trying to link. -- -initDynLinker :: DynFlags -> IO () -initDynLinker 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 dflags + reallyInitDynLinker hsc_env -reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState -reallyInitDynLinker dflags = - do { -- Initialise the linker state - let pls0 = emptyPLS dflags +reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState +reallyInitDynLinker hsc_env = do + -- Initialise the linker state + let dflags = hsc_dflags hsc_env + pls0 = emptyPLS dflags - -- (a) initialise the C dynamic linker - ; initObjLinker + -- (a) initialise the C dynamic linker + initObjLinker hsc_env - -- (b) Load packages from the command-line (Note [preload packages]) - ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0 - -- steps (c), (d) and (e) - ; linkCmdLineLibs' dflags pls - } + -- steps (c), (d) and (e) + linkCmdLineLibs' hsc_env pls -linkCmdLineLibs :: DynFlags -> IO () -linkCmdLineLibs dflags = do - initDynLinker dflags + +linkCmdLineLibs :: HscEnv -> IO () +linkCmdLineLibs hsc_env = do + initDynLinker hsc_env modifyPLS_ $ \pls -> do - linkCmdLineLibs' dflags pls + linkCmdLineLibs' hsc_env pls + +linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState +linkCmdLineLibs' hsc_env pls = + do + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths}) = hsc_dflags hsc_env -linkCmdLineLibs' :: DynFlags -> PersistentLinkerState -> IO PersistentLinkerState -linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs - , libraryPaths = lib_paths}) pls = - do -- (c) Link libraries from the command-line + -- (c) Link libraries from the command-line let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] - libspecs <- mapM (locateLib dflags False lib_paths) minus_ls + libspecs <- mapM (locateLib hsc_env False lib_paths) minus_ls -- (d) Link .o files from the command-line classified_ld_inputs <- mapM (classifyLdInput dflags) @@ -327,15 +329,15 @@ linkCmdLineLibs' dflags@(DynFlags { ldInputs = cmdline_ld_inputs ++ lib_paths ++ [ takeDirectory dll | DLLPath dll <- libspecs ] in nub $ map normalise paths - pathCache <- mapM addLibrarySearchPath all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths - pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls + pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls cmdline_lib_specs maybePutStr dflags "final link ... " - ok <- resolveObjs + ok <- resolveObjs hsc_env -- DLLs are loaded, reset the search paths - mapM_ removeLibrarySearchPath $ reverse pathCache + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache if succeeded ok then maybePutStrLn dflags "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") @@ -377,56 +379,58 @@ classifyLdInput dflags f return Nothing where platform = targetPlatform dflags -preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState - -> LibrarySpec -> IO PersistentLinkerState -preloadLib dflags lib_paths framework_paths pls lib_spec - = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Object static_ish - -> do (b, pls1) <- preload_static lib_paths static_ish - maybePutStrLn dflags (if b then "done" - else "not found") - return pls1 - - Archive static_ish - -> do b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" - else "not found") - return pls - - DLL dll_unadorned - -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned) - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm | platformOS platform /= OSDarwin -> - preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do - -- As a backup, on Darwin, try to also load a .so file - -- since (apparently) some things install that way - see - -- ticket #8770. - err2 <- loadDLL $ ("lib" ++ dll_unadorned) <.> "so" - case err2 of - Nothing -> maybePutStrLn dflags "done" - Just _ -> preloadFailed mm lib_paths lib_spec - return pls - - DLLPath dll_path - -> do maybe_errstr <- loadDLL dll_path - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm lib_paths lib_spec - return pls - - Framework framework -> - if platformUsesFrameworks (targetPlatform dflags) - then do maybe_errstr <- loadFramework framework_paths framework - case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" - Just mm -> preloadFailed mm framework_paths lib_spec - return pls - else panic "preloadLib Framework" +preloadLib + :: HscEnv -> [String] -> [String] -> PersistentLinkerState + -> LibrarySpec -> IO PersistentLinkerState +preloadLib hsc_env lib_paths framework_paths pls lib_spec = do + maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Object static_ish -> do + (b, pls1) <- preload_static lib_paths static_ish + maybePutStrLn dflags (if b then "done" else "not found") + return pls1 + + Archive static_ish -> do + b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" else "not found") + return pls + + DLL dll_unadorned -> do + maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Just mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + let libfile = ("lib" ++ dll_unadorned) <.> "so" + err2 <- loadDLL hsc_env libfile + case err2 of + Nothing -> maybePutStrLn dflags "done" + Just _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path -> do + do maybe_errstr <- loadDLL hsc_env dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework hsc_env framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else panic "preloadLib Framework" where + dflags = hsc_dflags hsc_env + platform = targetPlatform dflags preloadFailed :: String -> [String] -> LibrarySpec -> IO () @@ -445,9 +449,9 @@ preloadLib dflags lib_paths framework_paths pls lib_spec = do b <- doesFileExist name if not b then return (False, pls) else if dynamicGhc - then do pls1 <- dynLoadObjs dflags pls [name] + then do pls1 <- dynLoadObjs hsc_env pls [name] return (True, pls1) - else do loadObj name + else do loadObj hsc_env name return (True, pls) preload_static_archive _paths name @@ -455,7 +459,7 @@ preloadLib dflags lib_paths framework_paths pls lib_spec if not b then return False else do if dynamicGhc then panic "Loading archives not supported" - else loadArchive name + else loadArchive hsc_env name return True @@ -471,12 +475,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec -- Raises an IO exception ('ProgramError') if it can't find a compiled -- version of the dependents to link. -- -linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue linkExpr hsc_env span root_ul_bco = do { -- Initialise the linker (if it's not been done already) - let dflags = hsc_dflags hsc_env - ; initDynLinker dflags + ; initDynLinker hsc_env -- Take lock for the actual work. ; modifyPLS $ \pls0 -> do { @@ -492,8 +495,10 @@ linkExpr hsc_env span root_ul_bco ce = closure_env pls -- Link the necessary packages and linkables - ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco] - ; return (pls, root_hval) + + ; [(_,root_hvref)] <- linkSomeBCOs hsc_env ie ce [root_ul_bco] + ; fhv <- mkFinalizedHValue hsc_env root_hvref + ; return (pls, fhv) }}} where free_names = nameSetElems (bcoFreeNames root_ul_bco) @@ -514,6 +519,11 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) checkNonStdWay dflags srcspan + | gopt Opt_ExternalInterpreter dflags = return Nothing + -- with -fexternal-interpreter we load the .o files, whatever way + -- they were built. If they were built for a non-std way, then + -- we will use the appropriate variant of the iserv binary to load them. + | interpWays == haskellWays = return Nothing -- Only if we are compiling with the same ways as GHC is built -- with, can we dynamically load those object files. (see #3604) @@ -533,11 +543,19 @@ normalObjectSuffix = phaseInputExt StopLn failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) failNonStd dflags srcspan = dieWith dflags srcspan $ - ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$ - ptext (sLit "You need to build the program twice: once") <+> - ghciWay <> ptext (sLit ", and then") $$ - ptext (sLit "in the desired way using -osuf to set the object file suffix.") - where ghciWay + ptext (sLit "Cannot load") <+> compWay <+> + ptext (sLit "objects when GHC is built") <+> ghciWay $$ + ptext (sLit "To fix this, either:") $$ + ptext (sLit " (1) Use -fexternal-interprter, or") $$ + ptext (sLit " (2) Build the program twice: once") <+> + ghciWay <> ptext (sLit ", and then") $$ + ptext (sLit " with") <+> compWay <+> + ptext (sLit "using -osuf to set a different object file suffix.") + where compWay + | WayDyn `elem` ways dflags = ptext (sLit "-dynamic") + | WayProf `elem` ways dflags = ptext (sLit "-prof") + | otherwise = ptext (sLit "normal") + ghciWay | dynamicGhc = ptext (sLit "with -dynamic") | rtsIsProfiled = ptext (sLit "with -prof") | otherwise = ptext (sLit "the normal way") @@ -684,11 +702,10 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods ********************************************************************* -} -linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue] -linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do +linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () +linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv _) = do -- Initialise the linker (if it's not been done already) - let dflags = hsc_dflags hsc_env - initDynLinker dflags + initDynLinker hsc_env -- Take lock for the actual work. modifyPLS $ \pls0 -> do @@ -704,10 +721,11 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do ce = closure_env pls -- Link the necessary packages and linkables - (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs - let pls2 = pls { closure_env = final_gce, - itbl_env = ie } - return (pls2, ()) --hvals) + new_bindings <- linkSomeBCOs hsc_env ie ce unlinkedBCOs + nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings + let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs + , itbl_env = ie } + return (pls2, ()) where free_names = concatMap (nameSetElems . bcoFreeNames) unlinkedBCOs @@ -721,8 +739,6 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. - - {- ********************************************************************** Loading a single module @@ -731,7 +747,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do - initDynLinker (hsc_dflags hsc_env) + initDynLinker hsc_env modifyPLS_ $ \pls -> do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") @@ -745,21 +761,21 @@ linkModule hsc_env mod = do ********************************************************************* -} -linkModules :: DynFlags -> PersistentLinkerState -> [Linkable] +linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) -linkModules dflags pls linkables +linkModules hsc_env pls linkables = mask_ $ do -- don't want to be interrupted by ^C in here let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables) -- Load objects first; they can't depend on BCOs - (pls1, ok_flag) <- dynLinkObjs dflags pls objs + (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs dflags pls1 bcos + pls2 <- dynLinkBCOs hsc_env pls1 bcos return (pls2, Succeeded) @@ -795,36 +811,37 @@ linkableInSet l objs_loaded = ********************************************************************* -} -dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable] +dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] -> IO (PersistentLinkerState, SuccessFlag) -dynLinkObjs dflags pls objs = do +dynLinkObjs hsc_env pls objs = do -- Load the object files and link them let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs pls1 = pls { objs_loaded = objs_loaded' } unlinkeds = concatMap linkableUnlinked new_objs wanted_objs = map nameOfObject unlinkeds - if dynamicGhc - then do pls2 <- dynLoadObjs dflags pls1 wanted_objs + if loadingDynamicHSLibs (hsc_dflags hsc_env) + then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs return (pls2, Succeeded) - else do mapM_ loadObj wanted_objs + else do mapM_ (loadObj hsc_env) wanted_objs -- Link them all together - ok <- resolveObjs + ok <- resolveObjs hsc_env -- If resolving failed, unload all our -- object modules and carry on if succeeded ok then do return (pls1, Succeeded) else do - pls2 <- unload_wkr dflags [] pls1 + pls2 <- unload_wkr hsc_env [] pls1 return (pls2, Failed) -dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath] +dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs dflags pls objs = do +dynLoadObjs _ pls [] = return pls +dynLoadObjs hsc_env pls objs = do + let dflags = hsc_dflags hsc_env let platform = targetPlatform dflags (soFile, libPath , libName) <- newTempLibName dflags (soExt platform) let @@ -860,7 +877,7 @@ dynLoadObjs dflags pls objs = do -- symbols in this link we must link all loaded packages again. linkDynLib dflags2 objs (pkgs_loaded pls) consIORef (filesToNotIntermediateClean dflags) soFile - m <- loadDLL soFile + m <- loadDLL hsc_env soFile case m of Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls } Just err -> panic ("Loading temp shared object failed: " ++ err) @@ -884,9 +901,9 @@ rmDupLinkables already ls ********************************************************************* -} -dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable] +dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState -dynLinkBCOs dflags pls bcos = do +dynLinkBCOs hsc_env pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -897,46 +914,49 @@ dynLinkBCOs dflags pls bcos = do cbcs = map byteCodeOfObject unlinkeds - ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] - ies = [ie | ByteCode _ ie <- cbcs] + ul_bcos = [b | ByteCode bs _ _ <- cbcs, b <- bs] + ies = [ie | ByteCode _ ie _ <- cbcs] gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos - -- XXX What happens to these linked_bcos? + names_and_refs <- linkSomeBCOs hsc_env final_ie gce ul_bcos - let pls2 = pls1 { closure_env = final_gce, + -- We only want to add the external ones to the ClosureEnv + let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs + + -- Immediately release any HValueRefs we're not going to add + freeHValueRefs hsc_env (map snd to_drop) + -- Wrap finalizers on the ones we want to keep + new_binds <- makeForeignNamedHValueRefs hsc_env to_add + + let pls2 = pls1 { closure_env = extendClosureEnv gce new_binds, itbl_env = final_ie } return pls2 --- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: DynFlags - -> Bool -- False <=> add _all_ BCOs to returned closure env - -- True <=> add only toplevel BCOs to closure env +-- Link a bunch of BCOs and return references to their values +linkSomeBCOs :: HscEnv -> ItblEnv -> ClosureEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, [HValue]) - -- The returned HValues are associated 1-1 with + -> IO [(Name,HValueRef)] + -- The returned HValueRefs are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos - = do let nms = map unlinkedBCOName ul_bcos - hvals <- fixIO - ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) - in mapM (linkBCO dflags ie ce_out) ul_bcos ) - let ce_all_additions = zip nms hvals - ce_top_additions = filter (isExternalName.fst) ce_all_additions - ce_additions = if toplevs_only then ce_top_additions - else ce_all_additions - ce_out = -- make sure we're not inserting duplicate names into the - -- closure environment, which leads to trouble. - ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) - extendClosureEnv ce_in ce_additions - return (ce_out, hvals) +linkSomeBCOs _ _ _ [] = return [] +linkSomeBCOs hsc_env ie ce ul_bcos = do + let names = map unlinkedBCOName ul_bcos + bco_ix = mkNameEnv (zip names [0..]) + resolved <- mapM (linkBCO hsc_env ie ce bco_ix) ul_bcos + hvrefs <- iservCmd hsc_env (CreateBCOs resolved) + return (zip names hvrefs) +-- | Useful to apply to the result of 'linkSomeBCOs' +makeForeignNamedHValueRefs + :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] +makeForeignNamedHValueRefs hsc_env bindings = + mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings {- ********************************************************************** @@ -958,62 +978,85 @@ linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos -- -- * we also implicitly unload all temporary bindings at this point. -- -unload :: DynFlags +unload :: HscEnv -> [Linkable] -- ^ The linkables to *keep*. -> IO () -unload dflags linkables +unload hsc_env linkables = mask_ $ do -- mask, so we're safe from Ctrl-C in here -- Initialise the linker (if it's not been done already) - initDynLinker dflags + initDynLinker hsc_env new_pls <- modifyPLS $ \pls -> do - pls1 <- unload_wkr dflags linkables pls + pls1 <- unload_wkr hsc_env linkables pls return (pls1, pls1) - debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls)) - debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)) + let dflags = hsc_dflags hsc_env + debugTraceMsg dflags 3 $ + text "unload: retaining objs" <+> ppr (objs_loaded new_pls) + debugTraceMsg dflags 3 $ + text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) return () -unload_wkr :: DynFlags +unload_wkr :: HscEnv -> [Linkable] -- stable linkables -> PersistentLinkerState -> IO PersistentLinkerState -- Does the core unload business -- (the wrapper blocks exceptions and deals with the PLS get and put) -unload_wkr _ linkables pls - = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables +unload_wkr hsc_env keep_linkables pls = do + 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) + (bcos_to_unload, remaining_bcos_loaded) = + partition (discard bcos_to_keep) (bcos_loaded pls) + + mapM_ unloadObjs objs_to_unload + mapM_ unloadObjs bcos_to_unload + + -- If we unloaded any object files at all, we need to purge the cache + -- of lookupSymbol results. + when (not (null (objs_to_unload ++ + filter (not . null . linkableObjs) bcos_to_unload))) $ + purgeLookupSymbolCache hsc_env + + let bcos_retained = map linkableModule remaining_bcos_loaded + + -- Note that we want to remove all *local* + -- (i.e. non-isExternal) names too (these are the + -- temporary bindings from the command line). + keep_name (n,_) = isExternalName n && + nameModule n `elem` bcos_retained - objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) - bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) + itbl_env' = filterNameEnv keep_name (itbl_env pls) + closure_env' = filterNameEnv keep_name (closure_env pls) - let bcos_retained = map linkableModule bcos_loaded' - itbl_env' = filterNameMap bcos_retained (itbl_env pls) - closure_env' = filterNameMap bcos_retained (closure_env pls) - new_pls = pls { itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = bcos_loaded', - objs_loaded = 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 + return new_pls where - maybeUnload :: [Linkable] -> Linkable -> IO Bool - maybeUnload keep_linkables lnk - | linkableInSet lnk keep_linkables = return True - -- We don't do any cleanup when linking objects with the dynamic linker. - -- Doing so introduces extra complexity for not much benefit. - | dynamicGhc = return False + unloadObjs :: Linkable -> IO () + unloadObjs lnk + | dynamicGhc = return () + -- We don't do any cleanup when linking objects with the + -- dynamic linker. Doing so introduces extra complexity for + -- not much benefit. | otherwise - = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] + = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain -- dot-o files. Which is very confusing. -- -- But the BCO parts can be unlinked just by -- letting go of them (plus of course depopulating -- the symbol table which is done in the main body) - return False {- ********************************************************************** @@ -1067,7 +1110,7 @@ showLS (Framework nm) = "(framework) " ++ nm -- automatically, and it doesn't matter what order you specify the input -- packages. -- -linkPackages :: DynFlags -> [UnitId] -> IO () +linkPackages :: HscEnv -> [UnitId] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, -- we don't really need to use the package-config dependencies. -- @@ -1076,19 +1119,21 @@ linkPackages :: DynFlags -> [UnitId] -> IO () -- perhaps makes the error message a bit more localised if we get a link -- failure. So the dependency walking code is still here. -linkPackages dflags new_pkgs = do +linkPackages hsc_env new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. - initDynLinker dflags + initDynLinker hsc_env modifyPLS_ $ \pls -> do - linkPackages' dflags new_pkgs pls + linkPackages' hsc_env new_pkgs pls -linkPackages' :: DynFlags -> [UnitId] -> PersistentLinkerState +linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState -> IO PersistentLinkerState -linkPackages' dflags new_pks pls = do +linkPackages' hsc_env new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where + dflags = hsc_dflags hsc_env + link :: [UnitId] -> [UnitId] -> IO [UnitId] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1101,18 +1146,19 @@ linkPackages' dflags new_pks pls = do = do { -- Link dependents first pkgs' <- link pkgs (depends pkg_cfg) -- Now link the package itself - ; linkPackage dflags pkg_cfg + ; linkPackage hsc_env pkg_cfg ; return (new_pkg : pkgs') } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg)) -linkPackage :: DynFlags -> PackageConfig -> IO () -linkPackage dflags pkg +linkPackage :: HscEnv -> PackageConfig -> IO () +linkPackage hsc_env pkg = do - let platform = targetPlatform dflags - dirs = Packages.libraryDirs pkg + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + dirs = Packages.libraryDirs pkg let hs_libs = Packages.hsLibraries pkg -- The FFI GHCi import lib isn't needed as @@ -1135,8 +1181,8 @@ linkPackage dflags pkg else Packages.extraGHCiLibraries pkg) ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] - hs_classifieds <- mapM (locateLib dflags True dirs) hs_libs' - extra_classifieds <- mapM (locateLib dflags False dirs) extra_libs + hs_classifieds <- mapM (locateLib hsc_env True dirs) hs_libs' + extra_classifieds <- mapM (locateLib hsc_env False dirs) extra_libs let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. @@ -1148,27 +1194,28 @@ linkPackage dflags 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 all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths maybePutStr dflags ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do - loadFrameworks platform pkg - mapM_ load_dyn (known_dlls ++ map (mkSOName platform) dlls) + loadFrameworks hsc_env platform pkg + mapM_ (load_dyn hsc_env) + (known_dlls ++ map (mkSOName platform) dlls) -- DLLs are loaded, reset the search paths - mapM_ removeLibrarySearchPath $ reverse pathCache + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything. - mapM_ loadObj objs - mapM_ loadArchive archs + mapM_ (loadObj hsc_env) objs + mapM_ (loadArchive hsc_env) archs maybePutStr dflags "linking ... " - ok <- resolveObjs + ok <- resolveObjs hsc_env if succeeded ok then maybePutStrLn dflags "done." else let errmsg = "unable to load package `" @@ -1180,33 +1227,44 @@ linkPackage dflags pkg -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, -- loadDLL is going to search the system paths to find the library. -- -load_dyn :: FilePath -> IO () -load_dyn dll = do r <- loadDLL dll - case r of - Nothing -> return () - Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) - -loadFrameworks :: Platform -> PackageConfig -> IO () -loadFrameworks platform pkg +load_dyn :: HscEnv -> FilePath -> IO () +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 ++ ")" )) + +loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO () +loadFrameworks hsc_env platform pkg = when (platformUsesFrameworks platform) $ mapM_ load frameworks where fw_dirs = Packages.frameworkDirs pkg frameworks = Packages.frameworks pkg - load fw = do r <- loadFramework fw_dirs fw + 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 ++ ")" )) +loadingDynamicHSLibs :: DynFlags -> Bool +loadingDynamicHSLibs dflags + | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags + | otherwise = dynamicGhc + +loadingProfiledHSLibs :: DynFlags -> Bool +loadingProfiledHSLibs dflags + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + -- 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, -- which generally means that it should be a dynamic library in the -- standard system search path. -locateLib :: DynFlags -> Bool -> [FilePath] -> String -> IO LibrarySpec -locateLib dflags is_hs dirs lib +locateLib :: HscEnv -> Bool -> [FilePath] -> String -> IO LibrarySpec +locateLib hsc_env is_hs dirs lib | not is_hs -- For non-Haskell libraries (e.g. gmp, iconv): -- first look in library-dirs for a dynamic library (libfoo.so) @@ -1224,15 +1282,12 @@ locateLib dflags is_hs dirs lib findArchive `orElse` assumeDll - | dynamicGhc - -- When the GHC package was compiled as dynamic library (=DYNAMIC set), - -- we search for .so libraries first. + | loading_dynamic_hs_libs -- search for .so libraries first. = findHSDll `orElse` findDynObject `orElse` assumeDll - | rtsIsProfiled - -- When the GHC package is profiled, only a libHSfoo_p.a archive will do. + | loading_profiled_hs_libs -- only a libHSfoo_p.a archive will do. = findArchive `orElse` assumeDll @@ -1244,10 +1299,15 @@ locateLib dflags is_hs dirs lib assumeDll where + dflags = hsc_dflags hsc_env + obj_file = lib <.> "o" dyn_obj_file = lib <.> "dyn_o" arch_file = "lib" ++ lib ++ lib_tag <.> "a" - lib_tag = if is_hs && rtsIsProfiled then "_p" else "" + lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" + + loading_profiled_hs_libs = loadingProfiledHSLibs dflags + loading_dynamic_hs_libs = loadingDynamicHSLibs dflags hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name @@ -1265,7 +1325,7 @@ locateLib dflags is_hs dirs lib in liftM2 (<|>) local linked findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file - findSysDll = fmap (fmap $ DLL . takeFileName) $ findSystemLibrary so_name + findSysDll = fmap (fmap $ DLL . 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 @@ -1297,8 +1357,8 @@ searchForLibUsingGcc dflags so dirs = do -- Darwin / MacOS X only: load a framework -- a framework is a dynamic library packaged inside a directory of the same -- name. They are searched for in different paths than normal libraries. -loadFramework :: [FilePath] -> FilePath -> IO (Maybe String) -loadFramework extraPaths rootname +loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String) +loadFramework hsc_env extraPaths rootname = do { either_dir <- tryIO getHomeDirectory ; let homeFrameworkPath = case either_dir of Left _ -> [] @@ -1306,7 +1366,7 @@ loadFramework extraPaths rootname ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths ; mb_fwk <- findFile ps fwk_file ; case mb_fwk of - Just fwk_path -> loadDLL fwk_path + Just fwk_path -> loadDLL hsc_env fwk_path Nothing -> return (Just "not found") } -- Tried all our known library paths, but dlopen() -- has no built-in paths for frameworks: give up diff --git a/compiler/ghci/ObjLink.hs b/compiler/ghci/ObjLink.hs deleted file mode 100644 index b1cfe61da9..0000000000 --- a/compiler/ghci/ObjLink.hs +++ /dev/null @@ -1,142 +0,0 @@ --- --- (c) The University of Glasgow 2002-2006 --- - --- --------------------------------------------------------------------------- --- The dynamic linker for object code (.o .so .dll files) --- --------------------------------------------------------------------------- - --- | Primarily, this module consists of an interface to the C-land --- dynamic linker. -module ObjLink ( - initObjLinker, -- :: IO () - loadDLL, -- :: String -> IO (Maybe String) - loadArchive, -- :: String -> IO () - loadObj, -- :: String -> IO () - unloadObj, -- :: String -> IO () - insertSymbol, -- :: String -> String -> Ptr a -> IO () - lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs, -- :: IO SuccessFlag - addLibrarySearchPath, -- :: FilePath -> IO (Ptr ()) - removeLibrarySearchPath, -- :: Ptr () -> IO Bool - findSystemLibrary -- :: FilePath -> IO (Maybe FilePath) - ) where - -import Panic -import BasicTypes ( SuccessFlag, successIf ) -import Config ( cLeadingUnderscore ) -import Util - -import Control.Monad ( when ) -import Foreign.C -import Foreign.Marshal.Alloc ( free ) -import Foreign ( nullPtr ) -import GHC.Exts ( Ptr(..) ) -import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath ) -import System.FilePath ( dropExtension, normalise ) - - --- --------------------------------------------------------------------------- --- RTS Linker Interface --- --------------------------------------------------------------------------- - -insertSymbol :: String -> String -> Ptr a -> IO () -insertSymbol obj_name key symbol - = let str = prefixUnderscore key - in withFilePath obj_name $ \c_obj_name -> - withCAString str $ \c_str -> - c_insertSymbol c_obj_name c_str symbol - -lookupSymbol :: String -> IO (Maybe (Ptr a)) -lookupSymbol str_in = do - let str = prefixUnderscore str_in - withCAString str $ \c_str -> do - addr <- c_lookupSymbol c_str - if addr == nullPtr - then return Nothing - else return (Just addr) - -prefixUnderscore :: String -> String -prefixUnderscore - | cLeadingUnderscore == "YES" = ('_':) - | otherwise = id - --- | loadDLL loads a dynamic library using the OS's native linker --- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either --- an absolute pathname to the file, or a relative filename --- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL --- searches the standard locations for the appropriate library. --- -loadDLL :: String -> IO (Maybe String) --- Nothing => success --- Just err_msg => failure -loadDLL str0 = do - let - -- On Windows, addDLL takes a filename without an extension, because - -- it tries adding both .dll and .drv. To keep things uniform in the - -- layers above, loadDLL always takes a filename with an extension, and - -- we drop it here on Windows only. - str | isWindowsHost = dropExtension str0 - | otherwise = str0 - -- - maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll - if maybe_errmsg == nullPtr - then return Nothing - else do str <- peekCString maybe_errmsg - free maybe_errmsg - return (Just str) - -loadArchive :: String -> IO () -loadArchive str = do - withFilePath str $ \c_str -> do - r <- c_loadArchive c_str - when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) - -loadObj :: String -> IO () -loadObj str = do - withFilePath str $ \c_str -> do - r <- c_loadObj c_str - when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) - -unloadObj :: String -> IO () -unloadObj str = - withFilePath str $ \c_str -> do - r <- c_unloadObj c_str - when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) - -addLibrarySearchPath :: String -> IO (Ptr ()) -addLibrarySearchPath str = - withFilePath str c_addLibrarySearchPath - -removeLibrarySearchPath :: Ptr () -> IO Bool -removeLibrarySearchPath = c_removeLibrarySearchPath - -findSystemLibrary :: String -> IO (Maybe String) -findSystemLibrary str = do - result <- withFilePath str c_findSystemLibrary - case result == nullPtr of - True -> return Nothing - False -> do path <- peekFilePath result - free result - return $ Just path - -resolveObjs :: IO SuccessFlag -resolveObjs = do - r <- c_resolveObjs - return (successIf (r /= 0)) - --- --------------------------------------------------------------------------- --- Foreign declarations to RTS entry points which does the real work; --- --------------------------------------------------------------------------- - -foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString -foreign import ccall unsafe "initLinker" initObjLinker :: IO () -foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () -foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) -foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int -foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int -foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int -foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int -foreign import ccall unsafe "addLibrarySearchPath" c_addLibrarySearchPath :: CFilePath -> IO (Ptr ()) -foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr () -> IO Bool -foreign import ccall unsafe "findSystemLibrary" c_findSystemLibrary :: CFilePath -> IO CFilePath diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 015126fae9..f71c904454 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -27,9 +27,9 @@ module RtClosureInspect( #include "HsVersions.h" import DebuggerUtils -import ByteCodeItbls ( StgInfoTable, peekItbl ) -import qualified ByteCodeItbls as BCI( StgInfoTable(..) ) -import BasicTypes ( HValue ) +import GHCi.RemoteTypes ( HValue ) +import qualified GHCi.InfoTable as InfoTable +import GHCi.InfoTable (StgInfoTable, peekItbl) import HscTypes import DataCon @@ -185,12 +185,12 @@ getClosureData dflags a = -- into account the extra entry pointer when -- !ghciTablesNextToCode, so we must adjust here: iptr0 `plusPtr` negate (wORD_SIZE dflags) - itbl <- peekItbl dflags iptr1 - let tipe = readCType (BCI.tipe itbl) - elems = fromIntegral (BCI.ptrs itbl) + 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 (BCI.nptrs itbl)-1] ] + | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ] ASSERT(elems >= 0) return () ptrsList `seq` return (Closure tipe iptr0 itbl ptrsList nptrs_data) diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index a81ae80614..052b0615e7 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -12,7 +12,8 @@ module Annotations ( -- * AnnEnv for collecting and querying Annotations AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, deserializeAnns ) where @@ -20,7 +21,7 @@ import Binary import Module ( Module ) import Name import Outputable -import Serialized +import GHC.Serialized import UniqFM import Unique @@ -115,10 +116,17 @@ findAnns deserialize (MkAnnEnv ann_env) = (mapMaybe (fromSerialized deserialize)) . (lookupWithDefaultUFM ann_env []) +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep + = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target + , tyrep' == tyrep ] + -- | Deserialize all annotations of a given type. This happens lazily, that is -- no deserialization will take place until the [a] is actually demanded and -- the [a] can also be empty (the UniqFM is not filtered). deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] deserializeAnns deserialize (MkAnnEnv ann_env) = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env - diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 4692b21520..c37cc6536e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -237,7 +237,7 @@ compileOne' m_tc_result mHscMessage needsLinker = needsTH || needsQQ isDynWay = any (== WayDyn) (ways dflags0) isProfWay = any (== WayProf) (ways dflags0) - + internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) src_flavour = ms_hsc_src summary mod_name = ms_mod_name summary @@ -245,9 +245,10 @@ compileOne' m_tc_result mHscMessage object_filename = ml_obj_file location -- #8180 - when using TemplateHaskell, switch on -dynamic-too so - -- the linker can correctly load the object files. - - dflags1 = if needsLinker && dynamicGhc && not isDynWay && not isProfWay + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + dflags1 = if needsLinker && dynamicGhc && internalInterpreter && + not isDynWay && not isProfWay then gopt_set dflags0 Opt_BuildDynamicToo else dflags0 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index e443926d0f..03eb39846c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -72,8 +72,8 @@ module DynFlags ( versionedAppDir, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, - pgm_windres, pgm_libtool, pgm_lo, pgm_lc, - opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, + pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i, + opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i, opt_windres, opt_lo, opt_lc, @@ -428,6 +428,7 @@ data GeneralFlag | Opt_RelativeDynlibPaths | Opt_Hpc | Opt_FlatCache + | Opt_ExternalInterpreter -- PreInlining is on by default. The option is there just to see how -- bad things get if you turn it off! @@ -884,6 +885,7 @@ data Settings = Settings { sPgm_libtool :: String, sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + sPgm_i :: String, -- options for particular phases sOpt_L :: [String], sOpt_P :: [String], @@ -894,6 +896,7 @@ data Settings = Settings { sOpt_windres :: [String], sOpt_lo :: [String], -- LLVM: llvm optimiser sOpt_lc :: [String], -- LLVM: llc static compiler + sOpt_i :: [String], -- iserv options sPlatformConstants :: PlatformConstants } @@ -944,6 +947,8 @@ pgm_lo :: DynFlags -> (String,[Option]) pgm_lo dflags = sPgm_lo (settings dflags) pgm_lc :: DynFlags -> (String,[Option]) pgm_lc dflags = sPgm_lc (settings dflags) +pgm_i :: DynFlags -> String +pgm_i dflags = sPgm_i (settings dflags) opt_L :: DynFlags -> [String] opt_L dflags = sOpt_L (settings dflags) opt_P :: DynFlags -> [String] @@ -965,6 +970,8 @@ opt_lo :: DynFlags -> [String] opt_lo dflags = sOpt_lo (settings dflags) opt_lc :: DynFlags -> [String] opt_lc dflags = sOpt_lc (settings dflags) +opt_i :: DynFlags -> [String] +opt_i dflags = sOpt_i (settings dflags) -- | The directory for this version of ghc in the user's app directory -- (typically something like @~/.ghc/x86_64-linux-7.6.3@) @@ -2188,6 +2195,8 @@ dynamic_flags = [ (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) , defFlag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , defFlag "pgmi" + (hasArg (\f -> alterSettings (\s -> s { sPgm_i = f}))) , defFlag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) , defFlag "pgmP" @@ -2214,6 +2223,8 @@ dynamic_flags = [ (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) , defFlag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , defFlag "opti" + (hasArg (\f -> alterSettings (\s -> s { sOpt_i = f : sOpt_i s}))) , defFlag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) , defFlag "optP" @@ -2904,6 +2915,7 @@ fFlags = [ flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "external-interpreter" Opt_ExternalInterpreter, flagSpec "flat-cache" Opt_FlatCache, flagSpec "float-in" Opt_FloatIn, flagSpec "force-recomp" Opt_ForceRecomp, @@ -4158,6 +4170,33 @@ tARGET_MAX_WORD dflags 8 -> toInteger (maxBound :: Word64) w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). +-} + -- | Resolve any internal inconsistencies in a set of 'DynFlags'. -- Returns the consistent 'DynFlags' as well as a list of warnings -- to report to the user. @@ -4171,6 +4210,13 @@ makeDynFlagsConsistent dflags = let dflags' = gopt_unset dflags Opt_BuildDynamicToo warn = "-dynamic-too is not supported on Windows" in loop dflags' warn + -- Disalbe -fexternal-interpreter on Windows. This is a temporary measure; + -- all that is missing is the implementation of the interprocess communication + -- which uses pipes on POSIX systems. (#11100) + | os == OSMinGW32 && gopt Opt_ExternalInterpreter dflags + = let dflags' = gopt_unset dflags Opt_ExternalInterpreter + warn = "-fexternal-interpreter is currently not supported on Windows" + in loop dflags' warn | hscTarget dflags == HscC && not (platformUnregisterised (targetPlatform dflags)) = if cGhcWithNativeCodeGen == "YES" @@ -4211,6 +4257,7 @@ makeDynFlagsConsistent dflags = loop (updOptLevel 0 dflags) err | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) , rtsIsProfiled , isObjectTarget (hscTarget dflags) , WayProf `notElem` ways dflags @@ -4226,32 +4273,6 @@ makeDynFlagsConsistent dflags arch = platformArch platform os = platformOS platform -{- -Note [DynFlags consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a number of number of DynFlags configurations which either -do not make sense or lead to unimplemented or buggy codepaths in the -compiler. makeDynFlagsConsistent is responsible for verifying the validity -of a set of DynFlags, fixing any issues, and reporting them back to the -caller. - -GHCi and -O ---------------- - -When using optimization, the compiler can introduce several things -(such as unboxed tuples) into the intermediate code, which GHCi later -chokes on since the bytecode interpreter can't handle this (and while -this is arguably a bug these aren't handled, there are no plans to fix -it.) - -While the driver pipeline always checks for this particular erroneous -combination when parsing flags, we also need to check when we update -the flags; this is because API clients may parse flags but update the -DynFlags afterwords, before finally running code inside a session (see -T10052 and #10052). - --} -------------------------------------------------------------------------- -- Do not use unsafeGlobalDynFlags! diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 0d4b84252f..bbaf12978b 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -24,6 +24,7 @@ module DynamicLoading ( #ifdef GHCI import Linker ( linkModule, getHValue ) +import GHCi ( wormhole ) import SrcLoc ( noSrcSpan ) import Finder ( findImportedModule, cannotFindModule ) import TcRnMonad ( initTcInteractive, initIfaceTcRn ) @@ -38,7 +39,7 @@ import Plugins ( Plugin, FrontendPlugin, CommandLineOption ) import PrelNames ( pluginTyConName, frontendPluginTyConName ) import HscTypes -import BasicTypes ( HValue ) +import GHCi.RemoteTypes ( HValue ) import Type ( Type, eqType, mkTyConTy, pprTyThingCategory ) import TyCon ( TyCon ) import Name ( Name, nameModule_maybe ) @@ -170,7 +171,7 @@ getHValueSafely hsc_env val_name expected_type = do return () Nothing -> return () -- Find the value that we just linked in and cast it given that we have proved it's type - hval <- getHValue hsc_env val_name + hval <- getHValue hsc_env val_name >>= wormhole dflags return (Just hval) else return Nothing Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 74860a1c03..4bf9a5845f 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -127,6 +127,8 @@ module GHC ( -- ** Compiling expressions HValue, parseExpr, compileParsedExpr, InteractiveEval.compileExpr, dynCompileExpr, + ForeignHValue, + compileExprRemote, compileParsedExprRemote, -- ** Other runTcInteractive, -- Desired by some clients (Trac #8878) @@ -134,7 +136,7 @@ module GHC ( -- ** The debugger SingleStep(..), - Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, + Resume(resumeStmt, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, @@ -287,10 +289,12 @@ module GHC ( #include "HsVersions.h" #ifdef GHCI -import ByteCodeInstr +import ByteCodeTypes import BreakArray import InteractiveEval import TcRnDriver ( runTcInteractive ) +import GHCi +import GHCi.RemoteTypes #endif import PprTyThing ( pprFamInst ) @@ -405,22 +409,12 @@ defaultErrorHandler fm (FlushOut flushOut) inner = ) $ inner --- | Install a default cleanup handler to remove temporary files deposited by --- a GHC run. This is separate from 'defaultErrorHandler', because you might --- want to override the error handling, but still get the ordinary cleanup --- behaviour. -defaultCleanupHandler :: (ExceptionMonad m) => - DynFlags -> m a -> m a -defaultCleanupHandler dflags inner = - -- make sure we clean up after ourselves - inner `gfinally` - (liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags - ) - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. +-- | This function is no longer necessary, cleanup is now done by +-- runGhc/runGhcT. +{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-} +defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a +defaultCleanupHandler _ m = m + where _warning_suppression = m `gonException` undefined -- %************************************************************************ @@ -446,7 +440,8 @@ runGhc mb_top_dir ghc = do let session = Session ref flip unGhc session $ do initGhcMonad mb_top_dir - ghc + withCleanupSession ghc + -- XXX: unregister interrupt handlers here? -- | Run function for 'GhcT' monad transformer. @@ -469,7 +464,23 @@ runGhcT mb_top_dir ghct = do let session = Session ref flip unGhcT session $ do initGhcMonad mb_top_dir - ghct + withCleanupSession ghct + +withCleanupSession :: GhcMonad m => m a -> m a +withCleanupSession ghc = ghc `gfinally` cleanup + where + cleanup = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + cleanTempFiles dflags + cleanTempDirs dflags +#ifdef GHCI + stopIServ hsc_env -- shut down the IServ +#endif + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. -- | Initialise a GHC session. -- diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index f0dc3005f1..41d4f1c592 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -532,7 +532,7 @@ unload :: HscEnv -> [Linkable] -> IO () unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload hsc_env stable_linkables #else LinkInMemory -> panic "unload: no interpreter" -- urgh. avoid warnings: diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index c60b41ec50..2aef9b3510 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -18,7 +18,7 @@ module GhcPlugins( module TysWiredIn, module HscTypes, module BasicTypes, module VarSet, module VarEnv, module NameSet, module NameEnv, module UniqSet, module UniqFM, module FiniteMap, - module Util, module Serialized, module SrcLoc, module Outputable, + module Util, module GHC.Serialized, module SrcLoc, module Outputable, module UniqSupply, module Unique, module FastString ) where @@ -75,7 +75,7 @@ import FiniteMap -- Common utilities import Util -import Serialized +import GHC.Serialized import SrcLoc import Outputable import UniqSupply diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index f75214b4f4..0b75bc599d 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -5,6 +5,7 @@ -- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES -- stuff in compiler/ghc.mk makes DynFlags link to too much stuff +{-# LANGUAGE CPP #-} module Hooks ( Hooks , emptyHooks , lookupHook @@ -14,13 +15,17 @@ module Hooks ( Hooks , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook +#ifdef GHCI , hscCompileCoreExprHook +#endif , ghcPrimIfaceHook , runPhaseHook , runMetaHook , linkHook , runRnSpliceHook +#ifdef GHCI , getValueSafelyHook +#endif ) where import DynFlags @@ -36,6 +41,9 @@ import TcRnTypes import Bag import RdrName import CoreSyn +#ifdef GHCI +import GHCi.RemoteTypes +#endif import BasicTypes import Type import SrcLoc @@ -55,21 +63,40 @@ import Data.Maybe -- uses the default built-in behaviour emptyHooks :: Hooks -emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing +#ifdef GHCI + , hscCompileCoreExprHook = Nothing +#endif + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing +#ifdef GHCI + , getValueSafelyHook = Nothing +#endif + } data Hooks = Hooks { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) - , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue) +#ifdef GHCI + , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) +#endif , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) , runMetaHook :: Maybe (MetaHook TcM) , linkHook :: Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag) , runRnSpliceHook :: Maybe (HsSplice Name -> RnM (HsSplice Name)) +#ifdef GHCI , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue)) +#endif } getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 0b60596123..558341aebc 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -90,7 +90,7 @@ module HscMain #ifdef GHCI import Id -import BasicTypes ( HValue ) +import GHCi.RemoteTypes ( ForeignHValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker import CoreTidy ( tidyExpr ) @@ -101,8 +101,6 @@ import VarEnv ( emptyTidyEnv ) import THNames ( templateHaskellNames ) import Panic import ConLike - -import GHC.Exts #endif import Module @@ -162,6 +160,7 @@ import Stream (Stream) import Util import Data.List +import Control.Concurrent import Control.Monad import Data.IORef import System.FilePath as FilePath @@ -183,15 +182,20 @@ newHscEnv dflags = do us <- mkSplitUniqSupply 'r' nc_var <- newIORef (initNameCache us allKnownKeyNames) fc_var <- newIORef emptyModuleEnv - return HscEnv { hsc_dflags = dflags, - hsc_targets = [], - hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext dflags, - hsc_HPT = emptyHomePackageTable, - hsc_EPS = eps_var, - hsc_NC = nc_var, - hsc_FC = fc_var, - hsc_type_env_var = Nothing } + iserv_mvar <- newMVar Nothing + return HscEnv { hsc_dflags = dflags + , hsc_targets = [] + , hsc_mod_graph = [] + , hsc_IC = emptyInteractiveContext dflags + , hsc_HPT = emptyHomePackageTable + , hsc_EPS = eps_var + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_var = Nothing +#ifdef GHCI + , hsc_iserv = iserv_mvar +#endif + } allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -1303,7 +1307,7 @@ hscInteractive hsc_env cgguts mod_summary = do prepd_binds <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env location core_binds data_tycons ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks + comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs @@ -1434,7 +1438,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes -- -- We return Nothing to indicate an empty statement (or comment only), not a -- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv)) +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it @@ -1445,7 +1449,9 @@ hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], IO [HValue], FixityEnv)) + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) hscStmtWithLocation hsc_env0 stmt source linenumber = runInteractiveHsc hsc_env0 $ do maybe_stmt <- hscParseStmtWithLocation source linenumber stmt @@ -1458,7 +1464,9 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = hscParsedStmt :: HscEnv -> GhciLStmt RdrName -- ^ The parsed statement - -> IO (Maybe ([Id], IO [HValue], FixityEnv)) + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- Rename and typecheck it (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt @@ -1474,9 +1482,8 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr - let hvals_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hvals_io, fix_env) + return $ Just (ids, hval, fix_env) -- | Compile a decls hscDecls :: HscEnv @@ -1518,8 +1525,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber = {- Tidy -} (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg - let dflags = hsc_dflags hsc_env - !CgGuts{ cg_module = this_mod, + let !CgGuts{ cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, cg_modBreaks = mod_breaks } = tidy_cg @@ -1536,7 +1542,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber = liftIO $ corePrepPgm hsc_env iNTERACTIVELoc core_binds data_tycons {- Generate byte code -} - cbc <- liftIO $ byteCodeGen dflags this_mod + cbc <- liftIO $ byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks let src_span = srcLocSpan interactiveSrcLoc @@ -1715,11 +1721,11 @@ mkModGuts mod safe binds = %********************************************************************* -} #ifdef GHCI -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr hsc_env = lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr = do { let dflags = hsc_dflags hsc_env @@ -1736,7 +1742,8 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr {- Convert to BCOs -} - ; bcos <- coreExprToBCOs dflags (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr {- link it -} ; hval <- linkExpr hsc_env srcspan bcos diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 40c99f6436..3766b57df1 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -14,6 +14,9 @@ module HscTypes ( Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), +#ifdef GHCI + IServ(..), +#endif -- * Hsc monad Hsc(..), runHsc, runInteractiveHsc, @@ -130,8 +133,10 @@ module HscTypes ( #include "HsVersions.h" #ifdef GHCI -import ByteCodeAsm ( CompiledByteCode ) +import ByteCodeTypes ( CompiledByteCode ) import InteractiveEvalTypes ( Resume ) +import GHCi.Message ( Pipe ) +import GHCi.RemoteTypes ( HValueRef ) #endif import HsSyn @@ -184,16 +189,19 @@ import Binary import ErrUtils import Platform import Util -import Serialized ( Serialized ) +import GHC.Serialized ( Serialized ) import Control.Monad ( guard, liftM, when, ap ) +import Control.Concurrent import Data.Array ( Array, array ) import Data.IORef import Data.Time import Data.Word import Data.Typeable ( Typeable ) import Exception +import Foreign import System.FilePath +import System.Process ( ProcessHandle ) -- ----------------------------------------------------------------------------- -- Compilation state @@ -333,7 +341,7 @@ handleFlagWarnings dflags warns ************************************************************************ -} --- | Hscenv is like 'Session', except that some of the fields are immutable. +-- | HscEnv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. Things like -- the module graph don't change during a single compilation. @@ -394,12 +402,27 @@ data HscEnv -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' + +#ifdef GHCI + , hsc_iserv :: MVar (Maybe IServ) + -- ^ interactive server process. Created the first + -- time it is needed. +#endif } instance ContainsDynFlags HscEnv where extractDynFlags env = hsc_dflags env replaceDynFlags env dflags = env {hsc_dflags = dflags} +#ifdef GHCI +data IServ = IServ + { iservPipe :: Pipe + , iservProcess :: ProcessHandle + , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) + , iservPendingFrees :: [HValueRef] + } +#endif + -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index ac53382a78..2f819e4a60 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -11,7 +11,7 @@ module InteractiveEval ( #ifdef GHCI - Status(..), Resume(..), History(..), + Resume(..), History(..), execStmt, ExecOptions(..), execOptions, ExecResult(..), resumeExec, runDecls, runDeclsWithLocation, isStmt, isImport, isDecl, @@ -36,6 +36,7 @@ module InteractiveEval ( isModuleInterpreted, parseExpr, compileParsedExpr, compileExpr, dynCompileExpr, + compileExprRemote, compileParsedExprRemote, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, -- * Depcreated API (remove in GHC 7.14) RunResult(..), runStmt, runStmtWithLocation, @@ -48,11 +49,13 @@ module InteractiveEval ( import InteractiveEvalTypes +import GHCi +import GHCi.Run +import GHCi.RemoteTypes import GhcMonad import HscMain import HsSyn import HscTypes -import BasicTypes ( HValue ) import InstEnv import IfaceEnv ( newInteractiveBinder ) import FamInstEnv ( FamInst, orphNamesOfFamInst ) @@ -67,7 +70,7 @@ import Avail import RdrName import VarSet import VarEnv -import ByteCodeInstr +import ByteCodeTypes import Linker import DynFlags import Unique @@ -88,25 +91,16 @@ import Bag import qualified Lexer (P (..), ParseResult(..), unP, mkPState) import qualified Parser (parseStmt, parseModule, parseDeclaration) -import System.Mem.Weak import System.Directory import Data.Dynamic import Data.Either import Data.List (find) import StringBuffer (stringToStringBuffer) import Control.Monad -#if __GLASGOW_HASKELL__ >= 709 -import Foreign -#else -import Foreign.Safe -#endif -import Foreign.C import GHC.Exts import Data.Array import Exception import Control.Concurrent -import System.IO.Unsafe -import GHC.Conc ( setAllocationCounter, getAllocationCounter ) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -114,7 +108,7 @@ import GHC.Conc ( setAllocationCounter, getAllocationCounter ) getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> HValue -> BreakInfo -> History +mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History mkHistory hsc_env hval bi = let decls = findEnclosingDecls hsc_env bi in History hval bi decls @@ -166,6 +160,7 @@ execOptions = ExecOptions { execSingleStep = RunToCompletion , execSourceFile = "<interactive>" , execLineNumber = 1 + , execWrap = EvalThis -- just run the statement, don't wrap it in anything } -- | Run a statement in the current interactive context. @@ -177,12 +172,7 @@ execStmt execStmt stmt ExecOptions{..} = do hsc_env <- getSession - -- wait on this when we hit a breakpoint - breakMVar <- liftIO $ newEmptyMVar - -- wait on this when a computation is running - statusMVar <- liftIO $ newEmptyMVar - - -- Turn off -Wunused-local-binds when running a statement, to hide + -- Turn off -fwarn-unused-local-binds when running a statement, to hide -- warnings about the implicit bindings we introduce. let ic = hsc_IC hsc_env -- use the interactive dflags idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds @@ -201,9 +191,8 @@ execStmt stmt ExecOptions{..} = do status <- withVirtualCWD $ - withBreakAction (isStep execSingleStep) idflags' - breakMVar statusMVar $ do - liftIO $ sandboxIO idflags' statusMVar hval + liftIO $ + evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -211,7 +200,7 @@ execStmt stmt ExecOptions{..} = do size = ghciHistSize idflags' handleRunStatus execSingleStep stmt bindings ids - breakMVar statusMVar status (emptyHistory size) + status (emptyHistory size) -- | The type returned by the deprecated 'runStmt' and -- 'runStmtWithLocation' API @@ -226,7 +215,7 @@ execResultToRunResult r = case r of ExecComplete{ execResult = Left ex } -> RunException ex ExecComplete{ execResult = Right names } -> RunOk names - ExecBreak{..} -> RunBreak breakThreadId breakNames breakInfo + ExecBreak{..} -> RunBreak (error "no breakThreadId") breakNames breakInfo -- Remove in GHC 7.14 {-# DEPRECATED runStmt "use execStmt" #-} @@ -249,7 +238,8 @@ runStmtWithLocation source linenumber expr step = do runDecls :: GhcMonad m => String -> m [Name] runDecls = runDeclsWithLocation "<interactive>" 1 -runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation + :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession @@ -265,8 +255,12 @@ runDeclsWithLocation source linenumber expr = withVirtualCWD :: GhcMonad m => m a -> m a withVirtualCWD m = do hsc_env <- getSession - let ic = hsc_IC hsc_env + -- a virtual CWD is only necessary when we're running interpreted code in + -- the same process as the compiler. + if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do + + let ic = hsc_IC hsc_env let set_cwd = do dir <- liftIO $ getCurrentDirectory case ic_cwd ic of @@ -291,68 +285,67 @@ emptyHistory size = nilBL size handleRunStatus :: GhcMonad m => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] - -> MVar () -> MVar Status -> Status -> BoundedList History + -> EvalStatus [ForeignHValue] -> BoundedList History -> m ExecResult -handleRunStatus step expr bindings final_ids - breakMVar statusMVar status history +handleRunStatus step expr bindings final_ids status history | RunAndLogSteps <- step = tracing | otherwise = not_tracing where tracing - | Break is_exception apStack info tid <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status , not is_exception = do hsc_env <- getSession + let dflags = hsc_dflags hsc_env + info_hv <- liftIO $ wormholeRef dflags info_ref + let info = unsafeCoerce# info_hv :: BreakInfo b <- liftIO $ isBreakEnabled hsc_env info if b then not_tracing -- This breakpoint is explicitly enabled; we want to stop -- instead of just logging it. else do - let history' = mkHistory hsc_env apStack info `consBL` history + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref + let history' = mkHistory hsc_env apStack_fhv info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. _ <- liftIO $ evaluate history' - status <- withBreakAction True (hsc_dflags hsc_env) - breakMVar statusMVar $ do - liftIO $ mask_ $ do - putMVar breakMVar () -- awaken the stopped thread - redirectInterrupts tid $ - takeMVar statusMVar -- and wait for the result + fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + status <- liftIO $ GHCi.resumeStmt hsc_env True fhv handleRunStatus RunAndLogSteps expr bindings final_ids - breakMVar statusMVar status history' + status history' | otherwise = not_tracing not_tracing -- Hit a breakpoint - | Break is_exception apStack info tid <- status + | EvalBreak is_exception apStack_ref info_ref resume_ctxt <- status = do hsc_env <- getSession + let dflags = hsc_dflags hsc_env + info_hv <- liftIO $ wormholeRef dflags info_ref + let info = unsafeCoerce# info_hv :: BreakInfo + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref let mb_info | is_exception = Nothing | otherwise = Just info (hsc_env1, names, span) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack mb_info + bindLocalsAtBreakpoint hsc_env apStack_fhv mb_info let resume = Resume - { resumeStmt = expr, resumeThreadId = tid - , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + { resumeStmt = expr, resumeContext = resume_ctxt_fhv , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeApStack = apStack_fhv, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume modifySession (\_ -> hsc_env2) - return (ExecBreak tid names mb_info) - - -- Completed with an exception - | Complete (Left e) alloc <- status - = return (ExecComplete (Left e) alloc) + return (ExecBreak names mb_info) -- Completed successfully - | Complete (Right hvals) allocs <- status + | EvalComplete allocs (EvalSuccess hvals) <- status = do hsc_env <- getSession let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids final_names = map getName final_ids @@ -361,8 +354,12 @@ handleRunStatus step expr bindings final_ids modifySession (\_ -> hsc_env') return (ExecComplete (Right final_names) allocs) + -- Completed with an exception + | EvalComplete alloc (EvalException e) <- status + = return (ExecComplete (Left (fromSerializableException e)) alloc) + | otherwise - = panic "handleRunStatus" -- The above cases are in fact exhaustive + = panic "not_tracing" -- actually exhaustive, but GHC can't tell isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = @@ -376,148 +373,6 @@ isBreakEnabled hsc_env inf = return False -foreign import ccall "&rts_stop_next_breakpoint" stepFlag :: Ptr CInt -foreign import ccall "&rts_stop_on_exception" exceptionFlag :: Ptr CInt - -setStepFlag :: IO () -setStepFlag = poke stepFlag 1 -resetStepFlag :: IO () -resetStepFlag = poke stepFlag 0 - --- this points to the IO action that is executed when a breakpoint is hit -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) - --- When running a computation, we redirect ^C exceptions to the running --- thread. ToDo: we might want a way to continue even if the target --- thread doesn't die when it receives the exception... "this thread --- is not responding". --- --- Careful here: there may be ^C exceptions flying around, so we start the new --- thread blocked (forkIO inherits mask from the parent, #1048), and unblock --- only while we execute the user's code. We can't afford to lose the final --- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) -sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status -sandboxIO dflags statusMVar thing = - mask $ \restore -> -- fork starts blocked - let runIt = - liftM (uncurry Complete) $ - measureAlloc $ - try $ restore $ rethrow dflags $ thing - in if gopt Opt_GhciSandbox dflags - then do tid <- forkIO $ do res <- runIt - putMVar statusMVar res -- empty: can't block - redirectInterrupts tid $ - takeMVar statusMVar - - else -- GLUT on OS X needs to run on the main thread. If you - -- try to use it from another thread then you just get a - -- white rectangle rendered. For this, or anything else - -- with such restrictions, you can turn the GHCi sandbox off - -- and things will be run in the main thread. - -- - -- BUT, note that the debugging features (breakpoints, - -- tracing, etc.) need the expression to be running in a - -- separate thread, so debugging is only enabled when - -- using the sandbox. - runIt - --- --- While we're waiting for the sandbox thread to return a result, if --- the current thread receives an asynchronous exception we re-throw --- it at the sandbox thread and continue to wait. --- --- This is for two reasons: --- --- * So that ^C interrupts runStmt (e.g. in GHCi), allowing the --- computation to run its exception handlers before returning the --- exception result to the caller of runStmt. --- --- * clients of the GHC API can terminate a runStmt in progress --- without knowing the ThreadId of the sandbox thread (#1381) --- --- NB. use a weak pointer to the thread, so that the thread can still --- be considered deadlocked by the RTS and sent a BlockedIndefinitely --- exception. A symptom of getting this wrong is that conc033(ghci) --- will hang. --- -redirectInterrupts :: ThreadId -> IO a -> IO a -redirectInterrupts target wait - = do wtid <- mkWeakThreadId target - wait `catch` \e -> do - m <- deRefWeak wtid - case m of - Nothing -> wait - Just target -> do throwTo target (e :: SomeException); wait - -measureAlloc :: IO a -> IO (a,Word64) -measureAlloc io = do - setAllocationCounter maxBound - a <- io - allocs <- getAllocationCounter - return (a, fromIntegral (maxBound::Int64) - fromIntegral allocs) - --- We want to turn ^C into a break when -fbreak-on-exception is on, --- but it's an async exception and we only break for sync exceptions. --- Idea: if we catch and re-throw it, then the re-throw will trigger --- a break. Great - but we don't want to re-throw all exceptions, because --- then we'll get a double break for ordinary sync exceptions (you'd have --- to :continue twice, which looks strange). So if the exception is --- not "Interrupted", we unset the exception flag before throwing. --- -rethrow :: DynFlags -> IO a -> IO a -rethrow dflags io = Exception.catch io $ \se -> do - -- If -fbreak-on-error, we break unconditionally, - -- but with care of not breaking twice - if gopt Opt_BreakOnError dflags && - not (gopt Opt_BreakOnException dflags) - then poke exceptionFlag 1 - else case fromException se of - -- If it is a "UserInterrupt" exception, we allow - -- a possible break by way of -fbreak-on-exception - Just UserInterrupt -> return () - -- In any other case, we don't want to break - _ -> poke exceptionFlag 0 - - Exception.throwIO se - --- This function sets up the interpreter for catching breakpoints, and --- resets everything when the computation has stopped running. This --- is a not-very-good way to ensure that only the interactive --- evaluation should generate breakpoints. -withBreakAction :: (ExceptionMonad m) => - Bool -> DynFlags -> MVar () -> MVar Status -> m a -> m a -withBreakAction step dflags breakMVar statusMVar act - = gbracket (liftIO setBreakAction) (liftIO . resetBreakAction) (\_ -> act) - where - setBreakAction = do - stablePtr <- newStablePtr onBreak - poke breakPointIOAction stablePtr - when (gopt Opt_BreakOnException dflags) $ poke exceptionFlag 1 - when step $ setStepFlag - return stablePtr - -- Breaking on exceptions is not enabled by default, since it - -- might be a bit surprising. The exception flag is turned off - -- as soon as it is hit, or in resetBreakAction below. - - onBreak is_exception info apStack = do - tid <- myThreadId - putMVar statusMVar (Break is_exception apStack info tid) - takeMVar breakMVar - - resetBreakAction stablePtr = do - poke breakPointIOAction noBreakStablePtr - poke exceptionFlag 0 - resetStepFlag - freeStablePtr stablePtr - -noBreakStablePtr :: StablePtr (Bool -> BreakInfo -> HValue -> IO ()) -noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction - -noBreakAction :: Bool -> BreakInfo -> HValue -> IO () -noBreakAction False _ _ = putStrLn "*** Ignoring breakpoint" -noBreakAction True _ _ = return () -- exception: just continue - resume :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m RunResult resume canLogSpan step = execResultToRunResult <$> resumeExec canLogSpan step @@ -547,22 +402,14 @@ resumeExec canLogSpan step (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names - when (isStep step) $ liftIO setStepFlag case r of - Resume { resumeStmt = expr, resumeThreadId = tid - , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + Resume { resumeStmt = expr, resumeContext = fhv , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span + , resumeApStack = apStack, resumeBreakInfo = info + , resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do - withBreakAction (isStep step) (hsc_dflags hsc_env) - breakMVar statusMVar $ do - status <- liftIO $ mask_ $ do - putMVar breakMVar () - -- this awakens the stopped thread... - redirectInterrupts tid $ - takeMVar statusMVar - -- and wait for the result + status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv let prevHistoryLst = fromListBL 50 hist hist' = case info of Nothing -> prevHistoryLst @@ -570,8 +417,7 @@ resumeExec canLogSpan step | not $canLogSpan span -> prevHistoryLst | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist - handleRunStatus step expr bindings final_ids - breakMVar statusMVar status hist' + handleRunStatus step expr bindings final_ids status hist' back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) @@ -626,7 +472,7 @@ result_fs = fsLit "_result" bindLocalsAtBreakpoint :: HscEnv - -> HValue + -> ForeignHValue -> Maybe BreakInfo -> IO (HscEnv, [Name], SrcSpan) @@ -648,13 +494,12 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] -- - Linker.extendLinkEnv [(exn_name, unsafeCoerce# apStack)] + Linker.extendLinkEnv [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span) -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack (Just info) = do - +bindLocalsAtBreakpoint hsc_env apStack_fhv (Just info) = do let mod_name = moduleName (breakInfo_module info) hmi = expectJust "bindLocalsAtBreakpoint" $ @@ -682,12 +527,12 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- has been accidentally evaluated, or something else has gone wrong. -- So that we don't fall over in a heap when this happens, just don't -- bind any free variables instead, and we emit a warning. + apStack <- wormhole (hsc_dflags hsc_env) apStack_fhv mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" - us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time let tv_subst = newTyVars us free_tvs filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] @@ -706,8 +551,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids names = map idName new_ids - Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + fhvs <- mapM (mkFinalizedHValue hsc_env <=< mkHValueRef) + (catMaybes mb_hValues) + Linker.extendLinkEnv (zip names fhvs) + when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names, span) where @@ -791,7 +638,7 @@ abandon = do [] -> return False r:rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } - liftIO $ abandon_ r + liftIO $ abandonStmt hsc_env (resumeContext r) return True abandonAll :: GhcMonad m => m Bool @@ -803,28 +650,9 @@ abandonAll = do [] -> return False rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } - liftIO $ mapM_ abandon_ rs + liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs return True --- when abandoning a computation we have to --- (a) kill the thread with an async exception, so that the --- computation itself is stopped, and --- (b) fill in the MVar. This step is necessary because any --- thunks that were under evaluation will now be updated --- with the partial computation, which still ends in takeMVar, --- so any attempt to evaluate one of these thunks will block --- unless we fill in the MVar. --- (c) wait for the thread to terminate by taking its status MVar. This --- step is necessary to prevent race conditions with --- -fbreak-on-exception (see #5975). --- See test break010. -abandon_ :: Resume -> IO () -abandon_ r = do - killThread (resumeThreadId r) - putMVar (resumeBreakMVar r) () - _ <- takeMVar (resumeStatMVar r) - return () - -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -1058,10 +886,16 @@ compileExpr expr = do parsed_expr <- parseExpr expr compileParsedExpr parsed_expr +-- | Compile an expression, run it and deliver the resulting HValue. +compileExprRemote :: GhcMonad m => String -> m ForeignHValue +compileExprRemote expr = do + parsed_expr <- parseExpr expr + compileParsedExprRemote parsed_expr + -- | Compile an parsed expression (before renaming), run it and deliver -- the resulting HValue. -compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue -compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do +compileParsedExprRemote :: GhcMonad m => LHsExpr RdrName -> m ForeignHValue +compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- > let _compileParsedExpr = expr -- Create let stmt from expr to make hscParsedStmt happy. -- We will ignore the returned [Id], namely [expr_id], and not really @@ -1071,13 +905,21 @@ compileParsedExpr expr@(L loc _) = withSession $ \hsc_env -> do let_stmt = L loc . LetStmt . L loc . HsValBinds $ ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] - Just (ids, hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt + Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt updateFixityEnv fix_env - hvals <- liftIO hvals_io - case (ids, hvals) of - ([_expr_id], [hval]) -> return hval + status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) + case status of + EvalComplete _ (EvalSuccess [hval]) -> return hval + EvalComplete _ (EvalException e) -> + liftIO $ throwIO (fromSerializableException e) _ -> panic "compileParsedExpr" +compileParsedExpr :: GhcMonad m => LHsExpr RdrName -> m HValue +compileParsedExpr expr = do + fhv <- compileParsedExprRemote expr + dflags <- getDynFlags + liftIO $ wormhole dflags fhv + -- | Compile an expression, run it and return the result as a Dynamic. dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do @@ -1116,14 +958,16 @@ obtainTermFromVal hsc_env bound force ty x = obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do - hv <- Linker.getHValue hsc_env (varName id) - cvObtainTerm hsc_env bound force (idType id) hv + let dflags = hsc_dflags hsc_env + hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags + cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) - cvReconstructType hsc_env bound (idType id) hv + let dflags = hsc_dflags hsc_env + hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags + cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index 7e6e837bea..98090bbaed 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -10,22 +10,22 @@ module InteractiveEvalTypes ( #ifdef GHCI - Status(..), Resume(..), History(..), ExecResult(..), + Resume(..), History(..), ExecResult(..), SingleStep(..), isStep, ExecOptions(..) #endif ) where #ifdef GHCI +import GHCi.RemoteTypes (ForeignHValue) +import GHCi.Message (EvalExpr) import Id -import BasicTypes import Name import RdrName import Type -import ByteCodeInstr +import ByteCodeTypes import SrcLoc import Exception -import Control.Concurrent import Data.Word @@ -34,6 +34,7 @@ data ExecOptions { execSingleStep :: SingleStep -- ^ stepping mode , execSourceFile :: String -- ^ filename (for errors) , execLineNumber :: Int -- ^ line number (for errors) + , execWrap :: ForeignHValue -> EvalExpr ForeignHValue } data SingleStep @@ -51,26 +52,17 @@ data ExecResult , execAllocation :: Word64 } | ExecBreak - { breakThreadId :: ThreadId - , breakNames :: [Name] + { breakNames :: [Name] , breakInfo :: Maybe BreakInfo } -data Status - = Break Bool HValue BreakInfo ThreadId - -- ^ the computation hit a breakpoint (Bool <=> was an exception) - | Complete (Either SomeException [HValue]) Word64 - -- ^ the computation completed with either an exception or a value - data Resume = Resume { resumeStmt :: String, -- the original statement - resumeThreadId :: ThreadId, -- thread running the computation - resumeBreakMVar :: MVar (), - resumeStatMVar :: MVar Status, + resumeContext :: ForeignHValue, -- thread running the computation resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion - resumeApStack :: HValue, -- The object from which we can get + resumeApStack :: ForeignHValue, -- The object from which we can get -- value of the free variables. resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at @@ -84,7 +76,7 @@ data Resume data History = History { - historyApStack :: HValue, + historyApStack :: ForeignHValue, historyBreakInfo :: BreakInfo, historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index ad717a8a88..c7ca4a6481 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -187,6 +187,8 @@ initSysTools mbMinusB platformConstantsFile = top_dir </> "platformConstants" installed :: FilePath -> FilePath installed file = top_dir </> file + libexec :: FilePath -> FilePath + libexec file = top_dir </> "bin" </> file settingsStr <- readFile settingsFile platformConstantsStr <- readFile platformConstantsFile @@ -265,10 +267,10 @@ initSysTools mbMinusB -- For all systems, unlit, split, mangle are GHC utilities -- architecture-specific stuff is done when building Config.hs - unlit_path = installed cGHC_UNLIT_PGM + unlit_path = libexec cGHC_UNLIT_PGM -- split is a Perl script - split_script = installed cGHC_SPLIT_PGM + split_script = libexec cGHC_SPLIT_PGM windres_path <- getSetting "windres command" libtool_path <- getSetting "libtool command" @@ -305,6 +307,8 @@ initSysTools mbMinusB lc_prog <- getSetting "LLVM llc command" lo_prog <- getSetting "LLVM opt command" + let iserv_prog = libexec "ghc-iserv" + let platform = Platform { platformArch = targetArch, platformOS = targetOS, @@ -344,6 +348,7 @@ initSysTools mbMinusB sPgm_libtool = libtool_path, sPgm_lo = (lo_prog,[]), sPgm_lc = (lc_prog,[]), + sPgm_i = iserv_prog, sOpt_L = [], sOpt_P = [], sOpt_F = [], @@ -353,6 +358,7 @@ initSysTools mbMinusB sOpt_windres = [], sOpt_lo = [], sOpt_lc = [], + sOpt_i = [], sPlatformConstants = platformConstants } diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index ff4613448e..db56d6995b 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -47,7 +47,7 @@ import DynFlags ( DynFlags(..) ) import StaticFlags ( opt_PprStyle_Debug ) import Maybes ( orElse, catMaybes, isJust, isNothing ) import Demand -import Serialized ( deserializeWithData ) +import GHC.Serialized ( deserializeWithData ) import Util import Pair import UniqSupply diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 6fc26f85eb..d30cf44765 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -28,7 +28,7 @@ module TcRnDriver ( ) where #ifdef GHCI -import {-# SOURCE #-} TcSplice ( runQuasi ) +import {-# SOURCE #-} TcSplice ( finishTH ) import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import IfaceEnv( externaliseName ) import TcHsType @@ -485,11 +485,7 @@ tcRnSrcDecls explicit_mod_hdr decls ; setEnvs (tcg_env, tcl_env) $ do { #ifdef GHCI - -- Run all module finalizers - let th_modfinalizers_var = tcg_th_modfinalizers tcg_env - ; modfinalizers <- readTcRef th_modfinalizers_var - ; writeTcRef th_modfinalizers_var [] - ; mapM_ runQuasi modfinalizers + ; finishTH #endif /* GHCI */ -- wanted constraints from static forms diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 5797b8e8ac..f5d5ed553b 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -101,6 +101,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_topnames_var <- newIORef emptyNameSet ; th_modfinalizers_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; + th_remote_state_var <- newIORef Nothing ; #endif /* GHCI */ let { dflags = hsc_dflags hsc_env ; @@ -116,6 +117,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_th_topnames = th_topnames_var, tcg_th_modfinalizers = th_modfinalizers_var, tcg_th_state = th_state_var, + tcg_th_remote_state = th_remote_state_var, #endif /* GHCI */ tcg_mod = mod, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 47d554d50a..c885bbdb04 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -174,6 +174,7 @@ import qualified Control.Monad.Fail as MonadFail import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) import Data.Typeable ( TypeRep ) +import GHCi.RemoteTypes import qualified Language.Haskell.TH as TH #endif @@ -492,6 +493,7 @@ data TcGblEnv -- ^ Template Haskell module finalizers tcg_th_state :: TcRef (Map TypeRep Dynamic), + tcg_th_remote_state :: TcRef (Maybe ForeignHValue), -- ^ Template Haskell state #endif /* GHCI */ diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 2074100f84..64f7d1d311 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -11,6 +11,8 @@ TcSplice: Template Haskell splices {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module TcSplice( @@ -26,7 +28,8 @@ module TcSplice( -- called only in stage2 (ie GHCI is on) runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta' + defaultRunMeta, runMeta', + finishTH #endif ) where @@ -47,6 +50,9 @@ import TcUnify import TcEnv #ifdef GHCI +import GHCi.Message +import GHCi.RemoteTypes +import GHCi import HscMain -- These imports are the reason that TcSplice -- is very high up the module hierarchy @@ -89,7 +95,7 @@ import Id import IdInfo import DsExpr import DsMonad -import Serialized +import GHC.Serialized import ErrUtils import Util import Unique @@ -109,9 +115,14 @@ import qualified Language.Haskell.TH.Syntax as TH import GHC.Desugar ( AnnotationWrapper(..) ) import qualified Data.IntSet as IntSet -import qualified Data.Map as Map +import Control.Exception +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn ) -import Data.Typeable ( typeOf, Typeable, typeRep ) +import qualified Data.Map as Map +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) import GHC.Exts ( unsafeCoerce# ) @@ -558,18 +569,28 @@ runAnnotation target expr = do ann_value = serialized } -convertAnnotationWrapper :: AnnotationWrapper -> Either MsgDoc Serialized -convertAnnotationWrapper annotation_wrapper = Right $ - case annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- annotation are exposed at this point. This is also why we are - -- doing all this stuff inside the context of runMeta: it has the - -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - +convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper fhv = do + dflags <- getDynFlags + if gopt Opt_ExternalInterpreter dflags + then do + Right <$> runTH THAnnWrapper fhv + else do + annotation_wrapper <- liftIO $ wormhole dflags fhv + return $ Right $ + case unsafeCoerce# annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- annotation are exposed at this point. This is also why we are + -- doing all this stuff inside the context of runMeta: it has the + -- facilities to deal with user error in a meta-level expression + seqSerialized serialized `seq` serialized + +-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms +seqSerialized :: Serialized -> () +seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () {- @@ -583,12 +604,19 @@ convertAnnotationWrapper annotation_wrapper = Right $ runQuasi :: TH.Q a -> TcM a runQuasi act = TH.runQ act -runQResult :: (a -> String) -> (SrcSpan -> a -> b) -> SrcSpan -> TH.Q a -> TcM b -runQResult show_th f expr_span hval - = do { th_result <- TH.runQ hval +runQResult + :: (a -> String) + -> (SrcSpan -> a -> b) + -> (ForeignHValue -> TcM a) + -> SrcSpan + -> ForeignHValue {- TH.Q a -} + -> TcM b +runQResult show_th f runQ expr_span hval + = do { th_result <- runQ hval ; traceTc "Got TH result:" (text (show_th th_result)) ; return (f expr_span th_result) } + ----------------- runMeta :: (MetaHook TcM -> LHsExpr Id -> TcM hs_syn) -> LHsExpr Id @@ -599,15 +627,15 @@ runMeta unwrap e defaultRunMeta :: MetaHook TcM defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const (return . convertAnnotationWrapper)) + = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) -- We turn off showing the code in meta-level exceptions because doing so exposes -- the toAnnotationWrapper function that we slap around the users code @@ -635,7 +663,7 @@ runMetaD = runMeta metaRequestD --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t runMeta' show_code ppr_hs run_and_convert expr @@ -680,7 +708,7 @@ runMeta' show_code ppr_hs run_and_convert expr ; either_tval <- tryAllM $ setSrcSpan expr_span $ -- Set the span so that qLocation can -- see where this splice is - do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval) + do { mb_result <- run_and_convert expr_span hval ; case mb_result of Left err -> failWithTc err Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) @@ -694,6 +722,7 @@ runMeta' show_code ppr_hs run_and_convert expr }}} where -- see Note [Concealed TH exceptions] + fail_with_exn :: Exception e => String -> e -> TcM a fail_with_exn phase exn = do exn_msg <- liftIO $ Panic.safeShowException exn let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", @@ -857,6 +886,125 @@ instance TH.Quasi TcM where dflags <- hsc_dflags <$> getTopEnv return $ map toEnum $ IntSet.elems $ extensionFlags dflags + +-- | Run all module finalizers +finishTH :: TcM () +finishTH = do + hsc_env <- env_top <$> getEnv + dflags <- getDynFlags + if not (gopt Opt_ExternalInterpreter dflags) + then do + tcg <- getGblEnv + let th_modfinalizers_var = tcg_th_modfinalizers tcg + modfinalizers <- readTcRef th_modfinalizers_var + writeTcRef th_modfinalizers_var [] + mapM_ runQuasi modfinalizers + else withIServ hsc_env $ \i -> do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Nothing -> return () -- TH was not started, nothing to do + Just fhv -> do + liftIO $ withForeignHValue fhv $ \rhv -> + writeIServ i (putMessage (FinishTH rhv)) + () <- runRemoteTH i + writeTcRef (tcg_th_remote_state tcg) Nothing + +runTHExp :: ForeignHValue -> TcM TH.Exp +runTHExp = runTH THExp + +runTHPat :: ForeignHValue -> TcM TH.Pat +runTHPat = runTH THPat + +runTHType :: ForeignHValue -> TcM TH.Type +runTHType = runTH THType + +runTHDec :: ForeignHValue -> TcM [TH.Dec] +runTHDec = runTH THDec + +runTH :: Binary a => THResultType -> ForeignHValue -> TcM a +runTH ty fhv = do + hsc_env <- env_top <$> getEnv + dflags <- getDynFlags + if not (gopt Opt_ExternalInterpreter dflags) + then do + -- just run it in the local TcM + hv <- liftIO $ wormhole dflags fhv + r <- runQuasi (unsafeCoerce# hv :: TH.Q a) + return r + else + -- run it on the server + withIServ hsc_env $ \i -> do + rstate <- getTHState i + loc <- TH.qLocation + liftIO $ + withForeignHValue rstate $ \state_hv -> + withForeignHValue fhv $ \q_hv -> + writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) + bs <- runRemoteTH i + return $! runGet get (LB.fromStrict bs) + +-- | communicate with a remotely-running TH computation until it +-- finishes and returns a result. +runRemoteTH :: Binary a => IServ -> TcM a +runRemoteTH iserv = do + Msg msg <- liftIO $ readIServ iserv getMessage + case msg of + QDone -> liftIO $ readIServ iserv get + QException str -> liftIO $ throwIO (ErrorCall str) + QFail str -> fail str + _other -> do + r <- handleTHMessage msg + liftIO $ writeIServ iserv (put r) + runRemoteTH iserv + +getTHState :: IServ -> TcM ForeignHValue +getTHState i = do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Just rhv -> return rhv + Nothing -> do + hsc_env <- env_top <$> getEnv + fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH + writeTcRef (tcg_th_remote_state tcg) (Just fhv) + return fhv + +wrapTHResult :: TcM a -> TcM (THResult a) +wrapTHResult tcm = do + e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic + case e of + Left e -> return (THException (show e)) + Right a -> return (THComplete a) + +handleTHMessage :: Message a -> TcM a +handleTHMessage msg = case msg of + NewName a -> wrapTHResult $ TH.qNewName a + Report b str -> wrapTHResult $ TH.qReport b str + LookupName b str -> wrapTHResult $ TH.qLookupName b str + Reify n -> wrapTHResult $ TH.qReify n + ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + ReifyAnnotations lookup tyrep -> + wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + ReifyModule m -> wrapTHResult $ TH.qReifyModule m + AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + _ -> panic ("handleTHMessage: unexpected message " ++ show msg) + +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep th_name tyrep + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep + ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + {- ************************************************************************ * * diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index 50b7aac98f..743362024b 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -39,4 +39,5 @@ runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a +finishTH :: TcM () #endif diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index ab5b772eec..b70304d785 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -81,6 +81,7 @@ import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) +import GHC.Serialized type BinArray = ForeignPtr Word8 @@ -930,3 +931,12 @@ instance Binary SrcSpan where (mkSrcLoc f el ec)) _ -> do s <- get bh return (UnhelpfulSpan s) + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index cda74755ca..c3bdf5eb79 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -94,6 +94,7 @@ import Util import Platform import Pretty ( Doc, Mode(..) ) import Panic +import GHC.Serialized import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -811,6 +812,9 @@ instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type) + {- ************************************************************************ * * diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs index 782333633a..f1ccb7b5a5 100644 --- a/compiler/utils/Panic.hs +++ b/compiler/utils/Panic.hs @@ -20,10 +20,10 @@ module Panic ( panic, sorry, assertPanic, trace, panicDoc, sorryDoc, pgmErrorDoc, - Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, + Exception.Exception(..), showException, safeShowException, + try, tryMost, throwTo, installSignalHandlers, - pushInterruptTargetThread, popInterruptTargetThread ) where #include "HsVersions.h" @@ -47,7 +47,7 @@ import GHC.ConsoleHandler #endif import GHC.Stack -import System.Mem.Weak ( Weak, deRefWeak ) +import System.Mem.Weak ( deRefWeak ) -- | GHC's own exception type -- error messages all take the form: @@ -220,18 +220,15 @@ tryMost action = do r <- try action installSignalHandlers :: IO () installSignalHandlers = do main_thread <- myThreadId - pushInterruptTargetThread main_thread + wtid <- mkWeakThreadId main_thread let - interrupt_exn = (toException UserInterrupt) - interrupt = do - mt <- peekInterruptTargetThread - case mt of + r <- deRefWeak wtid + case r of Nothing -> return () - Just t -> throwTo t interrupt_exn + Just t -> throwTo t UserInterrupt - -- #if !defined(mingw32_HOST_OS) _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing @@ -254,29 +251,3 @@ installSignalHandlers = do _ <- installHandler (Catch sig_handler) return () #endif - -{-# NOINLINE interruptTargetThread #-} -interruptTargetThread :: MVar [Weak ThreadId] -interruptTargetThread = unsafePerformIO (newMVar []) - -pushInterruptTargetThread :: ThreadId -> IO () -pushInterruptTargetThread tid = do - wtid <- mkWeakThreadId tid - modifyMVar_ interruptTargetThread $ return . (wtid :) - -peekInterruptTargetThread :: IO (Maybe ThreadId) -peekInterruptTargetThread = - withMVar interruptTargetThread $ loop - where - loop [] = return Nothing - loop (t:ts) = do - r <- deRefWeak t - case r of - Nothing -> loop ts - Just t -> return (Just t) - -popInterruptTargetThread :: IO () -popInterruptTargetThread = - modifyMVar_ interruptTargetThread $ - \tids -> return $! case tids of [] -> [] - (_:ts) -> ts diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs deleted file mode 100644 index 41c1cea03f..0000000000 --- a/compiler/utils/Serialized.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} - --- --- (c) The University of Glasgow 2002-2006 --- --- Serialized values - -module Serialized ( - -- * Main Serialized data type - Serialized, - seqSerialized, - - -- * Going into and out of 'Serialized' - toSerialized, fromSerialized, - - -- * Handy serialization functions - serializeWithData, deserializeWithData, - ) where - -import Binary -import Outputable -import FastString -import Util - -import Data.Bits -import Data.Word ( Word8 ) - -import Data.Data - - --- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types -data Serialized = Serialized TypeRep [Word8] - -instance Outputable Serialized where - ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type) - -instance Binary Serialized where - put_ bh (Serialized the_type bytes) = do - put_ bh the_type - put_ bh bytes - get bh = do - the_type <- get bh - bytes <- get bh - return (Serialized the_type bytes) - --- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later -toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized -toSerialized serialize what = Serialized (typeOf what) (serialize what) - --- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. --- Otherwise return @Nothing@. -fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a -fromSerialized deserialize (Serialized the_type bytes) - | the_type == typeOf (undefined :: a) = Just (deserialize bytes) - | otherwise = Nothing - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () - - --- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' -serializeWithData :: Data a => a -> [Word8] -serializeWithData what = serializeWithData' what [] - -serializeWithData' :: Data a => a -> [Word8] -> [Word8] -serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a)) - (\x -> (serializeConstr (constrRep (toConstr what)), x)) - what - --- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData' -deserializeWithData :: Data a => [Word8] -> a -deserializeWithData = snd . deserializeWithData' - -deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a) -deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes -> - gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b)) - (\x -> (bytes, x)) - (repConstr (dataTypeOf (undefined :: a)) constr_rep) - - -serializeConstr :: ConstrRep -> [Word8] -> [Word8] -serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix -serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i -serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r -serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c - - -deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a -deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes -> - case constr_ix of - 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix) - 2 -> deserializeInteger bytes $ \i -> k (IntConstr i) - 3 -> deserializeRational bytes $ \r -> k (FloatConstr r) - 4 -> deserializeChar bytes $ \c -> k (CharConstr c) - x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes - - -serializeFixedWidthNum :: forall a. (Integral a, FiniteBits a) => a -> [Word8] -> [Word8] -serializeFixedWidthNum what = go (finiteBitSize what) what - where - go :: Int -> a -> [Word8] -> [Word8] - go size current rest - | size <= 0 = rest - | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest - -deserializeFixedWidthNum :: forall a b. (Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b -deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k - where - go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b - go size bytes k - | size <= 0 = k 0 bytes - | otherwise = case bytes of - (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte)) - [] -> error "deserializeFixedWidthNum: unexpected end of stream" - - -serializeEnum :: (Enum a) => a -> [Word8] -> [Word8] -serializeEnum = serializeInt . fromEnum - -deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b -deserializeEnum bytes k = deserializeInt bytes (k . toEnum) - - -serializeWord8 :: Word8 -> [Word8] -> [Word8] -serializeWord8 x = (x:) - -deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a -deserializeWord8 (byte:bytes) k = k byte bytes -deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream" - - -serializeInt :: Int -> [Word8] -> [Word8] -serializeInt = serializeFixedWidthNum - -deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a -deserializeInt = deserializeFixedWidthNum - - -serializeRational :: (Real a) => a -> [Word8] -> [Word8] -serializeRational = serializeString . show . toRational - -deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b -deserializeRational bytes k = deserializeString bytes (k . fromRational . read) - - -serializeInteger :: Integer -> [Word8] -> [Word8] -serializeInteger = serializeString . show - -deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a -deserializeInteger bytes k = deserializeString bytes (k . read) - - -serializeChar :: Char -> [Word8] -> [Word8] -serializeChar = serializeString . show - -deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a -deserializeChar bytes k = deserializeString bytes (k . read) - - -serializeString :: String -> [Word8] -> [Word8] -serializeString = serializeList serializeEnum - -deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a -deserializeString = deserializeList deserializeEnum - - -serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8] -serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs) - -deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c) - -> [Word8] -> ([a] -> [Word8] -> b) -> b -deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k - where - go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b - go len bytes k - | len <= 0 = k [] bytes - | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:))) - |