ghci (empty) → 8.0.1
raw patch · 17 files changed
+2486/−0 lines, 17 filesdep +arraydep +basedep +binarysetup-changed
Dependencies added: array, base, binary, bytestring, containers, deepseq, filepath, ghc-boot, template-haskell, transformers, unix
Files
- GHCi/BreakArray.hs +114/−0
- GHCi/CreateBCO.hs +152/−0
- GHCi/FFI.hsc +150/−0
- GHCi/InfoTable.hsc +436/−0
- GHCi/Message.hs +474/−0
- GHCi/ObjLink.hs +158/−0
- GHCi/RemoteTypes.hs +106/−0
- GHCi/ResolvedBCO.hs +90/−0
- GHCi/Run.hs +361/−0
- GHCi/Signals.hs +46/−0
- GHCi/TH.hs +169/−0
- GHCi/TH/Binary.hs +77/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- SizedSeq.hs +43/−0
- changelog.md +5/−0
- ghci.cabal +72/−0
+ GHCi/BreakArray.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++-------------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2007+--+-- | Break Arrays+--+-- An array of bytes, indexed by a breakpoint number (breakpointId in Tickish)+-- There is one of these arrays per module.+--+-- Each byte is+-- 1 if the corresponding breakpoint is enabled+-- 0 otherwise+--+-------------------------------------------------------------------------------++module GHCi.BreakArray+ (+ BreakArray+ (BA) -- constructor is exported only for ByteCodeGen+ , newBreakArray+ , getBreak+ , setBreakOn+ , setBreakOff+ , showBreakArray+ ) where++import Control.Monad+import Data.Word+import GHC.Word++import GHC.Exts+import GHC.IO ( IO(..) )+import System.IO.Unsafe ( unsafeDupablePerformIO )++data BreakArray = BA (MutableByteArray# RealWorld)++breakOff, breakOn :: Word8+breakOn = 1+breakOff = 0++showBreakArray :: BreakArray -> IO ()+showBreakArray array = do+ forM_ [0 .. (size array - 1)] $ \i -> do+ val <- readBreakArray array i+ putStr $ ' ' : show val+ putStr "\n"++setBreakOn :: BreakArray -> Int -> IO Bool+setBreakOn array index+ | safeIndex array index = do+ writeBreakArray array index breakOn+ return True+ | otherwise = return False++setBreakOff :: BreakArray -> Int -> IO Bool+setBreakOff array index+ | safeIndex array index = do+ writeBreakArray array index breakOff+ return True+ | otherwise = return False++getBreak :: BreakArray -> Int -> IO (Maybe Word8)+getBreak array index+ | safeIndex array index = do+ val <- readBreakArray array index+ return $ Just val+ | otherwise = return Nothing++safeIndex :: BreakArray -> Int -> Bool+safeIndex array index = index < size array && index >= 0++size :: BreakArray -> Int+size (BA array) = size+ where+ -- We want to keep this operation pure. The mutable byte array+ -- is never resized so this is safe.+ size = unsafeDupablePerformIO $ sizeofMutableByteArray array++ sizeofMutableByteArray :: MutableByteArray# RealWorld -> IO Int+ sizeofMutableByteArray arr =+ IO $ \s -> case getSizeofMutableByteArray# arr s of+ (# s', n# #) -> (# s', I# n# #)++allocBA :: Int -> IO BreakArray+allocBA (I# sz) = IO $ \s1 ->+ case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) }++-- create a new break array and initialise elements to zero+newBreakArray :: Int -> IO BreakArray+newBreakArray entries@(I# sz) = do+ BA array <- allocBA entries+ case breakOff of+ W8# off -> do+ let loop n | isTrue# (n ==# sz) = return ()+ | otherwise = do writeBA# array n off; loop (n +# 1#)+ loop 0#+ return $ BA array++writeBA# :: MutableByteArray# RealWorld -> Int# -> Word# -> IO ()+writeBA# array i word = IO $ \s ->+ case writeWord8Array# array i word s of { s -> (# s, () #) }++writeBreakArray :: BreakArray -> Int -> Word8 -> IO ()+writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word++readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8+readBA# array i = IO $ \s ->+ case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) }++readBreakArray :: BreakArray -> Int -> IO Word8+readBreakArray (BA array) (I# i) = readBA# array i
+ GHCi/CreateBCO.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RecordWildCards #-}++--+-- (c) The University of Glasgow 2002-2006+--++module GHCi.CreateBCO (createBCOs) where++import GHCi.ResolvedBCO+import GHCi.RemoteTypes+import GHCi.BreakArray+import SizedSeq++import System.IO (fixIO)+import Control.Monad+import Data.Array.Base+import Foreign hiding (newArray)+import GHC.Arr ( Array(..) )+import GHC.Exts+import GHC.IO+-- import Debug.Trace++createBCOs :: [ResolvedBCO] -> IO [HValueRef]+createBCOs bcos = do+ let n_bcos = length bcos+ hvals <- fixIO $ \hvs -> do+ let arr = listArray (0, n_bcos-1) hvs+ mapM (createBCO arr) bcos+ mapM mkRemoteRef hvals++createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue+createBCO arr bco+ = do BCO bco# <- linkBCO' arr bco+ -- Why do we need mkApUpd0 here? 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.+ --+ -- Furthermore:+ -- (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 (resolvedBCOArity bco > 0)+ then return (HValue (unsafeCoerce# bco#))+ else case mkApUpd0# bco# of { (# final_bco #) ->+ return (HValue final_bco) }+++linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO+linkBCO' arr ResolvedBCO{..} = do+ let+ ptrs = ssElts resolvedBCOPtrs+ n_ptrs = sizeSS resolvedBCOPtrs++ !(I# arity#) = resolvedBCOArity++ !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]++ barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b+ insns_barr = barr resolvedBCOInstrs+ bitmap_barr = barr resolvedBCOBitmap+ literals_barr = barr resolvedBCOLits++ PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs+ IO $ \s ->+ case unsafeFreezeArray# marr s of { (# s, arr #) ->+ case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->+ io s+ }}+++-- we recursively link any sub-BCOs while making the ptrs array+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr+mkPtrsArray arr n_ptrs ptrs = do+ marr <- newPtrsArray (fromIntegral n_ptrs)+ let+ fill (ResolvedBCORef n) i =+ writePtrsArrayHValue i (arr ! n) marr -- must be lazy!+ fill (ResolvedBCOPtr r) i = do+ hv <- localRef r+ writePtrsArrayHValue i hv marr+ fill (ResolvedBCOStaticPtr r) i = do+ writePtrsArrayPtr i (fromRemotePtr r) marr+ fill (ResolvedBCOPtrBCO bco) i = do+ BCO bco# <- linkBCO' arr bco+ writePtrsArrayBCO i bco# marr+ fill (ResolvedBCOPtrBreakArray r) i = do+ BA mba <- localRef r+ writePtrsArrayMBA i mba marr+ zipWithM_ fill ptrs [0..]+ return marr++data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)++newPtrsArray :: Int -> IO PtrsArr+newPtrsArray (I# i) = IO $ \s ->+ case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)++writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->+ case writeArray# arr i hv s of s' -> (# s', () #)++writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->+ case writeArrayAddr# arr i a# s of s' -> (# s', () #)++-- This is rather delicate: convincing GHC to pass an Addr# as an Any but+-- without making a thunk turns out to be surprisingly tricky.+{-# NOINLINE writeArrayAddr# #-}+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s++writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()+writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->+ case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)++data BCO = BCO BCO#++writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()+writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->+ case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)++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 #)++{- Note [BCO empty array]++Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:+they are 2-word heap objects. So let's make a single empty array and+share it between all BCOs.+-}++data EmptyArr = EmptyArr ByteArray#++{-# NOINLINE emptyArr #-}+emptyArr :: EmptyArr+emptyArr = unsafeDupablePerformIO $ IO $ \s ->+ case newByteArray# 0# s of { (# s, arr #) ->+ case unsafeFreezeByteArray# arr s of { (# s, farr #) ->+ (# s, EmptyArr farr #)+ }}
+ GHCi/FFI.hsc view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+--+-- libffi bindings+--+-- (c) The University of Glasgow 2008+--+-----------------------------------------------------------------------------++#include <ffi.h>++{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}+module GHCi.FFI+ ( FFIType(..)+ , FFIConv(..)+ , C_ffi_cif+ , prepForeignCall+ , freeForeignCallInfo+ ) where++import Control.Exception+import Data.Binary+import GHC.Generics+import Foreign+import Foreign.C++data FFIType+ = FFIVoid+ | FFIPointer+ | FFIFloat+ | FFIDouble+ | FFISInt8+ | FFISInt16+ | FFISInt32+ | FFISInt64+ | FFIUInt8+ | FFIUInt16+ | FFIUInt32+ | FFIUInt64+ deriving (Show, Generic, Binary)++data FFIConv+ = FFICCall+ | FFIStdCall+ deriving (Show, Generic, Binary)+++prepForeignCall+ :: FFIConv+ -> [FFIType] -- arg types+ -> FFIType -- result type+ -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller)++prepForeignCall cconv arg_types result_type = do+ let n_args = length arg_types+ arg_arr <- mallocArray n_args+ pokeArray arg_arr (map ffiType arg_types)+ cif <- mallocBytes (#const sizeof(ffi_cif))+ let abi = convToABI cconv+ r <- ffi_prep_cif cif abi (fromIntegral n_args) (ffiType result_type) arg_arr+ if (r /= fFI_OK)+ then throwIO (ErrorCall ("prepForeignCallFailed: " ++ show r))+ else return (castPtr cif)++freeForeignCallInfo :: Ptr C_ffi_cif -> IO ()+freeForeignCallInfo p = do+ free ((#ptr ffi_cif, arg_types) p)+ free p++convToABI :: FFIConv -> C_ffi_abi+convToABI FFICCall = fFI_DEFAULT_ABI+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)+convToABI FFIStdCall = fFI_STDCALL+#endif+-- unknown conventions are mapped to the default, (#3336)+convToABI _ = fFI_DEFAULT_ABI++ffiType :: FFIType -> Ptr C_ffi_type+ffiType FFIVoid = ffi_type_void+ffiType FFIPointer = ffi_type_pointer+ffiType FFIFloat = ffi_type_float+ffiType FFIDouble = ffi_type_double+ffiType FFISInt8 = ffi_type_sint8+ffiType FFISInt16 = ffi_type_sint16+ffiType FFISInt32 = ffi_type_sint32+ffiType FFISInt64 = ffi_type_sint64+ffiType FFIUInt8 = ffi_type_uint8+ffiType FFIUInt16 = ffi_type_uint16+ffiType FFIUInt32 = ffi_type_uint32+ffiType FFIUInt64 = ffi_type_uint64++data C_ffi_type+data C_ffi_cif++type C_ffi_status = (#type ffi_status)+type C_ffi_abi = (#type ffi_abi)++foreign import ccall "&ffi_type_void" ffi_type_void :: Ptr C_ffi_type+foreign import ccall "&ffi_type_uint8" ffi_type_uint8 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_sint8" ffi_type_sint8 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_uint16" ffi_type_uint16 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_sint16" ffi_type_sint16 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_uint32" ffi_type_uint32 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_sint32" ffi_type_sint32 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_uint64" ffi_type_uint64 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_sint64" ffi_type_sint64 :: Ptr C_ffi_type+foreign import ccall "&ffi_type_float" ffi_type_float :: Ptr C_ffi_type+foreign import ccall "&ffi_type_double" ffi_type_double :: Ptr C_ffi_type+foreign import ccall "&ffi_type_pointer"ffi_type_pointer :: Ptr C_ffi_type++fFI_OK :: C_ffi_status+fFI_OK = (#const FFI_OK)+--fFI_BAD_ABI :: C_ffi_status+--fFI_BAD_ABI = (#const FFI_BAD_ABI)+--fFI_BAD_TYPEDEF :: C_ffi_status+--fFI_BAD_TYPEDEF = (#const FFI_BAD_TYPEDEF)++fFI_DEFAULT_ABI :: C_ffi_abi+fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)+fFI_STDCALL :: C_ffi_abi+fFI_STDCALL = (#const FFI_STDCALL)+#endif++-- ffi_status ffi_prep_cif(ffi_cif *cif,+-- ffi_abi abi,+-- unsigned int nargs,+-- ffi_type *rtype,+-- ffi_type **atypes);++foreign import ccall "ffi_prep_cif"+ ffi_prep_cif :: Ptr C_ffi_cif -- cif+ -> C_ffi_abi -- abi+ -> CUInt -- nargs+ -> Ptr C_ffi_type -- result type+ -> Ptr (Ptr C_ffi_type) -- arg types+ -> IO C_ffi_status++-- Currently unused:++-- void ffi_call(ffi_cif *cif,+-- void (*fn)(),+-- void *rvalue,+-- void **avalue);++-- foreign import ccall "ffi_call"+-- ffi_call :: Ptr C_ffi_cif -- cif+-- -> FunPtr (IO ()) -- function to call+-- -> Ptr () -- put result here+-- -> Ptr (Ptr ()) -- arg values+-- -> IO ()
+ GHCi/InfoTable.hsc view
@@ -0,0 +1,436 @@+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}++-- |+-- Run-time info table support. This module provides support for+-- creating and reading info tables /in the running program/.+-- We use the RTS data structures directly via hsc2hs.+--+module GHCi.InfoTable+ ( mkConInfoTable+ , peekItbl, StgInfoTable(..)+ , conInfoPtr+ ) where++#if !defined(TABLES_NEXT_TO_CODE)+import Data.Maybe (fromJust)+#endif+import Foreign+import Foreign.C+import GHC.Ptr+import GHC.Exts+import System.IO.Unsafe++mkConInfoTable+ :: Int -- ptr words+ -> Int -- non-ptr words+ -> Int -- constr tag+ -> [Word8] -- con desc+ -> IO (Ptr StgInfoTable)+ -- resulting info table is allocated with allocateExec(), and+ -- should be freed with freeExec().++mkConInfoTable ptr_words nonptr_words tag con_desc =+ castFunPtrToPtr <$> newExecConItbl itbl con_desc+ where+ entry_addr = stg_interp_constr_entry+ code' = mkJumpToAddr entry_addr+ itbl = StgInfoTable {+ entry = if ghciTablesNextToCode+ then Nothing+ else Just entry_addr,+ ptrs = fromIntegral ptr_words,+ nptrs = fromIntegral nonptr_words,+ tipe = fromIntegral cONSTR,+ srtlen = fromIntegral tag,+ code = if ghciTablesNextToCode+ then Just code'+ else Nothing+ }+++-- -----------------------------------------------------------------------------+-- Building machine code fragments for a constructor's entry code++type ItblCodes = Either [Word8] [Word32]++funPtrToInt :: FunPtr a -> Int+funPtrToInt (FunPtr a) = I## (addr2Int## a)++data Arch = ArchSPARC+ | ArchPPC+ | ArchX86+ | ArchX86_64+ | ArchAlpha+ | ArchARM+ | ArchARM64+ | ArchPPC64+ | ArchPPC64LE+ | ArchUnknown+ deriving Show++platform :: Arch+platform =+#if defined(sparc_HOST_ARCH)+ ArchSPARC+#elif defined(powerpc_HOST_ARCH)+ ArchPPC+#elif defined(i386_HOST_ARCH)+ ArchX86+#elif defined(x86_64_HOST_ARCH)+ ArchX86_64+#elif defined(alpha_HOST_ARCH)+ ArchAlpha+#elif defined(arm_HOST_ARCH)+ ArchARM+#elif defined(aarch64_HOST_ARCH)+ ArchARM64+#elif defined(powerpc64_HOST_ARCH)+ ArchPPC64+#elif defined(powerpc64le_HOST_ARCH)+ ArchPPC64LE+#else+# if defined(TABLES_NEXT_TO_CODE)+# error Unimplemented architecture+# else+ ArchUnknown+# endif+#endif++mkJumpToAddr :: EntryFunPtr -> ItblCodes+mkJumpToAddr a = case platform 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]++ ArchARM64 { } ->+ -- Generates:+ --+ -- ldr x1, label+ -- br x1+ -- label:+ -- .quad <addr>+ --+ -- which looks like:+ -- 0: 58000041 ldr x1, <label>+ -- 4: d61f0020 br x1+ let w64 = fromIntegral (funPtrToInt a) :: Word64+ in Right [ 0x58000041+ , 0xd61f0020+ , fromIntegral w64+ , fromIntegral (w64 `shiftR` 32) ]+ ArchPPC64 ->+ -- We use the compiler's register r12 to read the function+ -- descriptor and the linker's register r11 as a temporary+ -- register to hold the function entry point.+ -- In the medium code model the function descriptor+ -- is located in the first two gigabytes, i.e. the address+ -- of the function pointer is a non-negative 32 bit number.+ -- 0x0EADBEEF stands for the address of the function pointer:+ -- 0: 3d 80 0e ad lis r12,0x0EAD+ -- 4: 61 8c be ef ori r12,r12,0xBEEF+ -- 8: e9 6c 00 00 ld r11,0(r12)+ -- c: e8 4c 00 08 ld r2,8(r12)+ -- 10: 7d 69 03 a6 mtctr r11+ -- 14: e9 6c 00 10 ld r11,16(r12)+ -- 18: 4e 80 04 20 bctr+ let w32 = fromIntegral (funPtrToInt a)+ hi16 x = (x `shiftR` 16) .&. 0xFFFF+ lo16 x = x .&. 0xFFFF+ in Right [ 0x3D800000 .|. hi16 w32,+ 0x618C0000 .|. lo16 w32,+ 0xE96C0000,+ 0xE84C0008,+ 0x7D6903A6,+ 0xE96C0010,+ 0x4E800420]++ ArchPPC64LE ->+ -- The ABI requires r12 to point to the function's entry point.+ -- We use the medium code model where code resides in the first+ -- two gigabytes, so loading a non-negative32 bit address+ -- with lis followed by ori is fine.+ -- 0x0EADBEEF stands for the address:+ -- 3D800EAD lis r12,0x0EAD+ -- 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 ]++ -- This code must not be called. You either need to+ -- add your architecture as a distinct case or+ -- use non-TABLES_NEXT_TO_CODE mode+ ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"++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)+++-- -----------------------------------------------------------------------------+-- read & write intfo tables++-- Get definitions for the structs, constants & config etc.+#include "Rts.h"++-- 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+#elif SIZEOF_VOID_P == 4+type HalfWord = Word16+#else+#error Uknown SIZEOF_VOID_P+#endif++data StgConInfoTable = StgConInfoTable {+ conDesc :: Ptr Word8,+ infoTable :: StgInfoTable+}++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+ }++pokeConItbl+ :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable+ -> IO ()+pokeConItbl wr_ptr ex_ptr itbl = do+ let _con_desc = conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)+#if defined(TABLES_NEXT_TO_CODE)+ (#poke StgConInfoTable, con_desc) wr_ptr _con_desc+#else+ (#poke StgConInfoTable, con_desc) wr_ptr (conDesc itbl)+#endif+ pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)++sizeOfEntryCode :: Int+sizeOfEntryCode+ | not ghciTablesNextToCode = 0+ | otherwise =+ case mkJumpToAddr undefined of+ Left xs -> sizeOf (head xs) * length xs+ Right xs -> sizeOf (head xs) * length xs++pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()+pokeItbl a0 itbl = do+#if !defined(TABLES_NEXT_TO_CODE)+ (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))+#endif+ (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)+ (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)+ (#poke StgInfoTable, type) a0 (tipe itbl)+ (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)+#if defined(TABLES_NEXT_TO_CODE)+ let code_offset = (a0 `plusPtr` (#offset StgInfoTable, code))+ case code itbl of+ Nothing -> return ()+ Just (Left xs) -> pokeArray code_offset xs+ Just (Right xs) -> pokeArray code_offset xs+#endif++peekItbl :: Ptr StgInfoTable -> IO StgInfoTable+peekItbl a0 = do+#if defined(TABLES_NEXT_TO_CODE)+ let entry' = Nothing+#else+ entry' <- Just <$> (#peek StgInfoTable, entry) a0+#endif+ ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0+ nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0+ tipe' <- (#peek StgInfoTable, type) a0+ srtlen' <- (#peek StgInfoTable, srt_bitmap) a0+ return StgInfoTable+ { entry = entry'+ , ptrs = ptrs'+ , nptrs = nptrs'+ , tipe = tipe'+ , srtlen = srtlen'+ , code = Nothing+ }++newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())+newExecConItbl obj con_desc+ = alloca $ \pcode -> do+ let lcon_desc = length con_desc + 1{- null terminator -}+ sz = fromIntegral ((#size StgConInfoTable) + sizeOfEntryCode)+ -- 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 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 ()++-- | Convert a pointer to an StgConInfo into an info pointer that can be+-- used in the header of a closure.+conInfoPtr :: Ptr () -> Ptr ()+conInfoPtr ptr+ | ghciTablesNextToCode = ptr `plusPtr` (#size StgConInfoTable)+ | otherwise = ptr++-- -----------------------------------------------------------------------------+-- Constants and config++wORD_SIZE :: Int+wORD_SIZE = (#const SIZEOF_HSINT)++fixedInfoTableSizeB :: Int+fixedInfoTableSizeB = 2 * wORD_SIZE++profInfoTableSizeB :: Int+profInfoTableSizeB = (#size StgProfInfo)++stdInfoTableSizeB :: Int+stdInfoTableSizeB+ = (if ghciTablesNextToCode then 0 else wORD_SIZE)+ + (if rtsIsProfiled then profInfoTableSizeB else 0)+ + fixedInfoTableSizeB++conInfoTableSizeB :: Int+conInfoTableSizeB = stdInfoTableSizeB + wORD_SIZE++foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt++rtsIsProfiled :: Bool+rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0++cONSTR :: Int -- Defined in ClosureTypes.h+cONSTR = (#const CONSTR)++ghciTablesNextToCode :: Bool+#ifdef TABLES_NEXT_TO_CODE+ghciTablesNextToCode = True+#else+ghciTablesNextToCode = False+#endif
+ GHCi/Message.hs view
@@ -0,0 +1,474 @@+{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving,+ GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}++module GHCi.Message+ ( Message(..), Msg(..)+ , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)+ , SerializableException(..)+ , THResult(..), THResultType(..)+ , ResumeContext(..)+ , QState(..)+ , getMessage, putMessage+ , Pipe(..), remoteCall, readPipe, writePipe+ ) where++import GHCi.RemoteTypes+import GHCi.InfoTable (StgInfoTable)+import GHCi.FFI+import GHCi.TH.Binary ()+import GHCi.BreakArray++import GHC.LanguageExtensions+import Control.Concurrent+import Control.Exception+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Dynamic+import Data.IORef+import Data.Map (Map)+import GHC.Generics+import GHC.Stack.CCS+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import System.Exit+import System.IO+import System.IO.Error++-- -----------------------------------------------------------------------------+-- The RPC protocol between GHC and the interactive server++-- | A @Message a@ is a message that returns a value of type @a@+data Message a where+ -- | Exit the iserv process+ Shutdown :: Message ()++ -- RTS Linker -------------------------------------------++ -- These all invoke the corresponding functions in the RTS Linker API.+ InitLinker :: Message ()+ LookupSymbol :: String -> Message (Maybe (RemotePtr ()))+ LookupClosure :: String -> Message (Maybe HValueRef)+ LoadDLL :: String -> Message (Maybe String)+ LoadArchive :: String -> Message () -- error?+ LoadObj :: String -> Message () -- error?+ UnloadObj :: String -> Message () -- error?+ AddLibrarySearchPath :: String -> Message (RemotePtr ())+ RemoveLibrarySearchPath :: RemotePtr () -> Message Bool+ ResolveObjs :: Message Bool+ FindSystemLibrary :: String -> Message (Maybe String)++ -- Interpreter -------------------------------------------++ -- | Create a set of BCO objects, and return HValueRefs to them+ CreateBCOs :: [LB.ByteString] -> Message [HValueRef]++ -- | Release 'HValueRef's+ FreeHValueRefs :: [HValueRef] -> Message ()++ -- | Malloc some data and return a 'RemotePtr' to it+ MallocData :: ByteString -> Message (RemotePtr ())+ MallocStrings :: [ByteString] -> Message [RemotePtr ()]++ -- | Calls 'GHCi.FFI.prepareForeignCall'+ PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)++ -- | Free data previously created by 'PrepFFI'+ FreeFFI :: RemotePtr C_ffi_cif -> Message ()++ -- | Create an info table for a constructor+ MkConInfoTable+ :: Int -- ptr words+ -> Int -- non-ptr words+ -> Int -- constr tag+ -> [Word8] -- constructor desccription+ -> Message (RemotePtr StgInfoTable)++ -- | Evaluate a statement+ EvalStmt+ :: EvalOpts+ -> EvalExpr HValueRef {- IO [a] -}+ -> Message (EvalStatus [HValueRef]) {- [a] -}++ -- | Resume evaluation of a statement after a breakpoint+ ResumeStmt+ :: EvalOpts+ -> RemoteRef (ResumeContext [HValueRef])+ -> Message (EvalStatus [HValueRef])++ -- | Abandon evaluation of a statement after a breakpoint+ AbandonStmt+ :: RemoteRef (ResumeContext [HValueRef])+ -> Message ()++ -- | Evaluate something of type @IO String@+ EvalString+ :: HValueRef {- IO String -}+ -> Message (EvalResult String)++ -- | Evaluate something of type @String -> IO String@+ EvalStringToString+ :: HValueRef {- String -> IO String -}+ -> String+ -> Message (EvalResult String)++ -- | Evaluate something of type @IO ()@+ EvalIO+ :: HValueRef {- IO a -}+ -> Message (EvalResult ())++ -- | Create a set of CostCentres with the same module name+ MkCostCentres+ :: String -- module, RemotePtr so it can be shared+ -> [(String,String)] -- (name, SrcSpan)+ -> Message [RemotePtr CostCentre]++ -- | Show a 'CostCentreStack' as a @[String]@+ CostCentreStackInfo+ :: RemotePtr CostCentreStack+ -> Message [String]++ -- | Create a new array of breakpoint flags+ NewBreakArray+ :: Int -- size+ -> Message (RemoteRef BreakArray)++ -- | Enable a breakpoint+ EnableBreakpoint+ :: RemoteRef BreakArray+ -> Int -- index+ -> Bool -- on or off+ -> Message ()++ -- | Query the status of a breakpoint (True <=> enabled)+ BreakpointStatus+ :: RemoteRef BreakArray+ -> Int -- index+ -> Message Bool -- True <=> enabled++ -- | Get a reference to a free variable at a breakpoint+ GetBreakpointVar+ :: HValueRef -- the AP_STACK from EvalBreak+ -> Int+ -> Message (Maybe HValueRef)++ -- Template Haskell -------------------------------------------++ -- | Start a new TH module, return a state token that should be+ StartTH :: Message (RemoteRef (IORef QState))++ -- | Run TH module finalizers, and free the HValueRef+ FinishTH :: RemoteRef (IORef QState) -> Message ()++ -- | Evaluate a TH computation.+ --+ -- Returns a ByteString, because we have to force the result+ -- before returning it to ensure there are no errors lurking+ -- in it. The TH types don't have NFData instances, and even if+ -- they did, we have to serialize the value anyway, so we might+ -- as well serialize it to force it.+ RunTH+ :: RemoteRef (IORef QState)+ -> HValueRef {- e.g. TH.Q TH.Exp -}+ -> THResultType+ -> Maybe TH.Loc+ -> Message ByteString {- e.g. TH.Exp -}++ -- Template Haskell Quasi monad operations+ NewName :: String -> Message (THResult TH.Name)+ Report :: Bool -> String -> Message (THResult ())+ LookupName :: Bool -> String -> Message (THResult (Maybe TH.Name))+ Reify :: TH.Name -> Message (THResult TH.Info)+ ReifyFixity :: TH.Name -> Message (THResult (Maybe TH.Fixity))+ ReifyInstances :: TH.Name -> [TH.Type] -> Message (THResult [TH.Dec])+ ReifyRoles :: TH.Name -> Message (THResult [TH.Role])+ ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString])+ ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo)+ ReifyConStrictness :: TH.Name -> Message (THResult [TH.DecidedStrictness])++ AddDependentFile :: FilePath -> Message (THResult ())+ AddTopDecls :: [TH.Dec] -> Message (THResult ())+ IsExtEnabled :: Extension -> Message (THResult Bool)+ ExtsEnabled :: Message (THResult [Extension])++ StartRecover :: Message ()+ EndRecover :: Bool -> Message ()++ -- Template Haskell return values++ -- | RunTH finished successfully; return value follows+ QDone :: Message ()+ -- | RunTH threw an exception+ QException :: String -> Message ()+ -- | RunTH called 'fail'+ QFail :: String -> Message ()++deriving instance Show (Message a)++data EvalOpts = EvalOpts+ { useSandboxThread :: Bool+ , singleStep :: Bool+ , breakOnException :: Bool+ , breakOnError :: Bool+ }+ deriving (Generic, Show)++instance Binary EvalOpts++data ResumeContext a = ResumeContext+ { resumeBreakMVar :: MVar ()+ , resumeStatusMVar :: MVar (EvalStatus a)+ , resumeThreadId :: ThreadId+ }++-- | We can pass simple expressions to EvalStmt, consisting of values+-- and application. This allows us to wrap the statement to be+-- executed in another function, which is used by GHCi to implement+-- :set args and :set prog. It might be worthwhile to extend this+-- little language in the future.+data EvalExpr a+ = EvalThis a+ | EvalApp (EvalExpr a) (EvalExpr a)+ deriving (Generic, Show)++instance Binary a => Binary (EvalExpr a)++type EvalStatus a = EvalStatus_ a a++data EvalStatus_ a b+ = EvalComplete Word64 (EvalResult a)+ | EvalBreak Bool+ HValueRef{- AP_STACK -}+ Int {- break index -}+ Int {- uniq of ModuleName -}+ (RemoteRef (ResumeContext b))+ (RemotePtr CostCentreStack) -- Cost centre stack+ deriving (Generic, Show)++instance Binary a => Binary (EvalStatus_ a b)++data EvalResult a+ = EvalException SerializableException+ | EvalSuccess a+ deriving (Generic, Show)++instance Binary a => Binary (EvalResult a)++-- SomeException can't be serialized because it contains dynamic+-- types. However, we do very limited things with the exceptions that+-- are thrown by interpreted computations:+--+-- * We print them, e.g. "*** Exception: <something>"+-- * UserInterrupt has a special meaning+-- * In ghc -e, exitWith should exit with the appropriate exit code+--+-- So all we need to do is distinguish UserInterrupt and ExitCode, and+-- all other exceptions can be represented by their 'show' string.+--+data SerializableException+ = EUserInterrupt+ | EExitCode ExitCode+ | EOtherException String+ deriving (Generic, Show)++instance Binary ExitCode+instance Binary SerializableException++data THResult a+ = THException String+ | THComplete a+ deriving (Generic, Show)++instance Binary a => Binary (THResult a)++data THResultType = THExp | THPat | THType | THDec | THAnnWrapper+ deriving (Enum, Show, Generic)++instance Binary THResultType++data QState = QState+ { qsMap :: Map TypeRep Dynamic+ -- ^ persistent data between splices in a module+ , qsFinalizers :: [TH.Q ()]+ -- ^ registered finalizers (in reverse order)+ , qsLocation :: Maybe TH.Loc+ -- ^ location for current splice, if any+ , qsPipe :: Pipe+ -- ^ pipe to communicate with GHC+ }+instance Show QState where show _ = "<QState>"++data Msg = forall a . (Binary a, Show a) => Msg (Message a)++getMessage :: Get Msg+getMessage = do+ b <- getWord8+ case b of+ 0 -> Msg <$> return Shutdown+ 1 -> Msg <$> return InitLinker+ 2 -> Msg <$> LookupSymbol <$> get+ 3 -> Msg <$> LookupClosure <$> get+ 4 -> Msg <$> LoadDLL <$> get+ 5 -> Msg <$> LoadArchive <$> get+ 6 -> Msg <$> LoadObj <$> get+ 7 -> Msg <$> UnloadObj <$> get+ 8 -> Msg <$> AddLibrarySearchPath <$> get+ 9 -> Msg <$> RemoveLibrarySearchPath <$> get+ 10 -> Msg <$> return ResolveObjs+ 11 -> Msg <$> FindSystemLibrary <$> get+ 12 -> Msg <$> CreateBCOs <$> get+ 13 -> Msg <$> FreeHValueRefs <$> get+ 14 -> Msg <$> MallocData <$> get+ 15 -> Msg <$> MallocStrings <$> get+ 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)+ 17 -> Msg <$> FreeFFI <$> get+ 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)+ 19 -> Msg <$> (EvalStmt <$> get <*> get)+ 20 -> Msg <$> (ResumeStmt <$> get <*> get)+ 21 -> Msg <$> (AbandonStmt <$> get)+ 22 -> Msg <$> (EvalString <$> get)+ 23 -> Msg <$> (EvalStringToString <$> get <*> get)+ 24 -> Msg <$> (EvalIO <$> get)+ 25 -> Msg <$> (MkCostCentres <$> get <*> get)+ 26 -> Msg <$> (CostCentreStackInfo <$> get)+ 27 -> Msg <$> (NewBreakArray <$> get)+ 28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)+ 29 -> Msg <$> (BreakpointStatus <$> get <*> get)+ 30 -> Msg <$> (GetBreakpointVar <$> get <*> get)+ 31 -> Msg <$> return StartTH+ 32 -> Msg <$> FinishTH <$> get+ 33 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)+ 34 -> Msg <$> NewName <$> get+ 35 -> Msg <$> (Report <$> get <*> get)+ 36 -> Msg <$> (LookupName <$> get <*> get)+ 37 -> Msg <$> Reify <$> get+ 38 -> Msg <$> ReifyFixity <$> get+ 39 -> Msg <$> (ReifyInstances <$> get <*> get)+ 40 -> Msg <$> ReifyRoles <$> get+ 41 -> Msg <$> (ReifyAnnotations <$> get <*> get)+ 42 -> Msg <$> ReifyModule <$> get+ 43 -> Msg <$> ReifyConStrictness <$> get+ 44 -> Msg <$> AddDependentFile <$> get+ 45 -> Msg <$> AddTopDecls <$> get+ 46 -> Msg <$> (IsExtEnabled <$> get)+ 47 -> Msg <$> return ExtsEnabled+ 48 -> Msg <$> return StartRecover+ 49 -> Msg <$> EndRecover <$> get+ 50 -> Msg <$> return QDone+ 51 -> Msg <$> QException <$> get+ _ -> Msg <$> QFail <$> get++putMessage :: Message a -> Put+putMessage m = case m of+ Shutdown -> putWord8 0+ InitLinker -> putWord8 1+ LookupSymbol str -> putWord8 2 >> put str+ LookupClosure str -> putWord8 3 >> put str+ LoadDLL str -> putWord8 4 >> put str+ LoadArchive str -> putWord8 5 >> put str+ LoadObj str -> putWord8 6 >> put str+ UnloadObj str -> putWord8 7 >> put str+ AddLibrarySearchPath str -> putWord8 8 >> put str+ RemoveLibrarySearchPath ptr -> putWord8 9 >> put ptr+ ResolveObjs -> putWord8 10+ FindSystemLibrary str -> putWord8 11 >> put str+ CreateBCOs bco -> putWord8 12 >> put bco+ FreeHValueRefs val -> putWord8 13 >> put val+ MallocData bs -> putWord8 14 >> put bs+ MallocStrings bss -> putWord8 15 >> put bss+ PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res+ FreeFFI p -> putWord8 17 >> put p+ MkConInfoTable p n t d -> putWord8 18 >> put p >> put n >> put t >> put d+ EvalStmt opts val -> putWord8 19 >> put opts >> put val+ ResumeStmt opts val -> putWord8 20 >> put opts >> put val+ AbandonStmt val -> putWord8 21 >> put val+ EvalString val -> putWord8 22 >> put val+ EvalStringToString str val -> putWord8 23 >> put str >> put val+ EvalIO val -> putWord8 24 >> put val+ MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs+ CostCentreStackInfo ptr -> putWord8 26 >> put ptr+ NewBreakArray sz -> putWord8 27 >> put sz+ EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b+ BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix+ GetBreakpointVar a b -> putWord8 30 >> put a >> put b+ StartTH -> putWord8 31+ FinishTH val -> putWord8 32 >> put val+ RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty+ NewName a -> putWord8 34 >> put a+ Report a b -> putWord8 35 >> put a >> put b+ LookupName a b -> putWord8 36 >> put a >> put b+ Reify a -> putWord8 37 >> put a+ ReifyFixity a -> putWord8 38 >> put a+ ReifyInstances a b -> putWord8 39 >> put a >> put b+ ReifyRoles a -> putWord8 40 >> put a+ ReifyAnnotations a b -> putWord8 41 >> put a >> put b+ ReifyModule a -> putWord8 42 >> put a+ ReifyConStrictness a -> putWord8 43 >> put a+ AddDependentFile a -> putWord8 44 >> put a+ AddTopDecls a -> putWord8 45 >> put a+ IsExtEnabled a -> putWord8 46 >> put a+ ExtsEnabled -> putWord8 47+ StartRecover -> putWord8 48+ EndRecover a -> putWord8 49 >> put a+ QDone -> putWord8 50+ QException a -> putWord8 51 >> put a+ QFail a -> putWord8 52 >> put a++-- -----------------------------------------------------------------------------+-- Reading/writing messages++data Pipe = Pipe+ { pipeRead :: Handle+ , pipeWrite :: Handle+ , pipeLeftovers :: IORef (Maybe ByteString)+ }++remoteCall :: Binary a => Pipe -> Message a -> IO a+remoteCall pipe msg = do+ writePipe pipe (putMessage msg)+ readPipe pipe get++writePipe :: Pipe -> Put -> IO ()+writePipe Pipe{..} put+ | LB.null bs = return ()+ | otherwise = do+ LB.hPut pipeWrite bs+ hFlush pipeWrite+ where+ bs = runPut put++readPipe :: Pipe -> Get a -> IO a+readPipe Pipe{..} get = do+ leftovers <- readIORef pipeLeftovers+ m <- getBin pipeRead get leftovers+ case m of+ Nothing -> throw $+ mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing+ Just (result, new_leftovers) -> do+ writeIORef pipeLeftovers new_leftovers+ return result++getBin+ :: Handle -> Get a -> Maybe ByteString+ -> IO (Maybe (a, Maybe ByteString))++getBin h get leftover = go leftover (runGetIncremental get)+ where+ go Nothing (Done leftover _ msg) =+ return (Just (msg, if B.null leftover then Nothing else Just leftover))+ go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers")+ go (Just leftover) (Partial fun) = do+ go Nothing (fun (Just leftover))+ go Nothing (Partial fun) = do+ -- putStrLn "before hGetSome"+ b <- B.hGetSome h (32*1024)+ -- printf "hGetSome: %d\n" (B.length b)+ if B.null b+ then return Nothing+ else go Nothing (fun (Just b))+ go _lft (Fail _rest _off str) =+ throwIO (ErrorCall ("getBin: " ++ str))
+ GHCi/ObjLink.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+--+-- (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 GHCi.ObjLink+ ( initObjLinker+ , loadDLL+ , loadArchive+ , loadObj+ , unloadObj+ , lookupSymbol+ , lookupClosure+ , resolveObjs+ , addLibrarySearchPath+ , removeLibrarySearchPath+ , findSystemLibrary+ ) where++import GHCi.RemoteTypes+import Control.Monad ( when )+import Foreign.C+import Foreign.Marshal.Alloc ( free )+import Foreign ( nullPtr )+import GHC.Exts+import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )+import System.FilePath ( dropExtension, normalise )++-- ---------------------------------------------------------------------------+-- RTS Linker Interface+-- ---------------------------------------------------------------------------++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)++lookupClosure :: String -> IO (Maybe HValueRef)+lookupClosure str = do+ m <- lookupSymbol str+ case m of+ Nothing -> return Nothing+ Just (Ptr addr) -> case addrToAny# addr of+ (# a #) -> Just <$> mkRemoteRef (HValue a)++prefixUnderscore :: String -> String+prefixUnderscore+ | cLeadingUnderscore = ('_':)+ | 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) (error ("loadArchive " ++ show str ++ ": failed"))++loadObj :: String -> IO ()+loadObj str = do+ withFilePath str $ \c_str -> do+ r <- c_loadObj c_str+ when (r == 0) (error ("loadObj " ++ show str ++ ": failed"))++unloadObj :: String -> IO ()+unloadObj str =+ withFilePath str $ \c_str -> do+ r <- c_unloadObj c_str+ when (r == 0) (error ("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 Bool+resolveObjs = do+ r <- c_resolveObjs+ return (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 "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 "findSystemLibrary" c_findSystemLibrary :: CFilePath -> IO CFilePath+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool++-- -----------------------------------------------------------------------------+-- Configuration++#include "ghcautoconf.h"++cLeadingUnderscore :: Bool+#ifdef LEADING_UNDERSCORE+cLeadingUnderscore = True+#else+cLeadingUnderscore = False+#endif++isWindowsHost :: Bool+#if mingw32_HOST_OS+isWindowsHost = True+#else+isWindowsHost = False+#endif
+ GHCi/RemoteTypes.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-}+module GHCi.RemoteTypes+ ( RemotePtr(..), toRemotePtr, fromRemotePtr, castRemotePtr+ , HValue(..)+ , RemoteRef, mkRemoteRef, localRef, freeRemoteRef+ , HValueRef, toHValueRef+ , ForeignRef, mkForeignRef, withForeignRef+ , ForeignHValue+ , unsafeForeignRefToRemoteRef, finalizeForeignRef+ ) where++import Data.Word+import Foreign hiding (newForeignPtr)+import Foreign.Concurrent+import Data.Binary+import Unsafe.Coerce+import GHC.Exts+import GHC.ForeignPtr++-- -----------------------------------------------------------------------------+-- RemotePtr++-- Static pointers only; don't use this for heap-resident pointers.+-- Instead use HValueRef.++#include "MachDeps.h"+#if SIZEOF_HSINT == 4+newtype RemotePtr a = RemotePtr Word32+#elif SIZEOF_HSINT == 8+newtype RemotePtr a = RemotePtr Word64+#endif++toRemotePtr :: Ptr a -> RemotePtr a+toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p))++fromRemotePtr :: RemotePtr a -> Ptr a+fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p)++castRemotePtr :: RemotePtr a -> RemotePtr b+castRemotePtr (RemotePtr a) = RemotePtr a++deriving instance Show (RemotePtr a)+deriving instance Binary (RemotePtr a)++-- -----------------------------------------------------------------------------+-- HValueRef++newtype HValue = HValue Any++instance Show HValue where+ show _ = "<HValue>"++-- | A reference to a remote value. These are allocated and freed explicitly.+newtype RemoteRef a = RemoteRef (RemotePtr ())+ deriving (Show, Binary)++-- We can discard type information if we want+toHValueRef :: RemoteRef a -> RemoteRef HValue+toHValueRef = unsafeCoerce++-- For convenience+type HValueRef = RemoteRef HValue++-- | Make a reference to a local value that we can send remotely.+-- This reference will keep the value that it refers to alive until+-- 'freeRemoteRef' is called.+mkRemoteRef :: a -> IO (RemoteRef a)+mkRemoteRef a = do+ sp <- newStablePtr a+ return $! RemoteRef (toRemotePtr (castStablePtrToPtr sp))++-- | Convert an HValueRef to an HValue. Should only be used if the HValue+-- originated in this process.+localRef :: RemoteRef a -> IO a+localRef (RemoteRef w) =+ deRefStablePtr (castPtrToStablePtr (fromRemotePtr w))++-- | Release an HValueRef that originated in this process+freeRemoteRef :: RemoteRef a -> IO ()+freeRemoteRef (RemoteRef w) =+ freeStablePtr (castPtrToStablePtr (fromRemotePtr w))++-- | An HValueRef with a finalizer+newtype ForeignRef a = ForeignRef (ForeignPtr ())++type ForeignHValue = ForeignRef HValue++-- | Create a 'ForeignRef' from a 'RemoteRef'. The finalizer+-- should arrange to call 'freeHValueRef' on the 'HValueRef'. (since+-- this function needs to be called in the process that created the+-- 'HValueRef', it cannot be called directly from the finalizer).+mkForeignRef :: RemoteRef a -> IO () -> IO (ForeignRef a)+mkForeignRef (RemoteRef hvref) finalizer =+ ForeignRef <$> newForeignPtr (fromRemotePtr hvref) finalizer++-- | Use a 'ForeignHValue'+withForeignRef :: ForeignRef a -> (RemoteRef a -> IO b) -> IO b+withForeignRef (ForeignRef fp) f =+ withForeignPtr fp (f . RemoteRef . toRemotePtr)++unsafeForeignRefToRemoteRef :: ForeignRef a -> RemoteRef a+unsafeForeignRefToRemoteRef (ForeignRef fp) =+ RemoteRef (toRemotePtr (unsafeForeignPtrToPtr fp))++finalizeForeignRef :: ForeignRef a -> IO ()+finalizeForeignRef (ForeignRef fp) = finalizeForeignPtr fp
+ GHCi/ResolvedBCO.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,+ BangPatterns #-}+module GHCi.ResolvedBCO+ ( ResolvedBCO(..)+ , ResolvedBCOPtr(..)+ ) where++import SizedSeq+import GHCi.RemoteTypes+import GHCi.BreakArray++import Control.Monad.ST+import Data.Array.Unboxed+import Data.Array.Base+import Data.Binary+import GHC.Generics++-- -----------------------------------------------------------------------------+-- ResolvedBCO++-- A A ResolvedBCO is one in which all the Name references have been+-- resolved to actual addresses or RemoteHValues.+--+-- Note, all arrays are zero-indexed (we assume this when+-- serializing/deserializing)+data ResolvedBCO+ = ResolvedBCO {+ resolvedBCOArity :: {-# UNPACK #-} !Int,+ resolvedBCOInstrs :: UArray Int Word, -- insns+ resolvedBCOBitmap :: UArray Int Word, -- bitmap+ resolvedBCOLits :: UArray Int Word, -- non-ptrs+ resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs+ }+ deriving (Generic, Show)++instance Binary ResolvedBCO where+ put ResolvedBCO{..} = do+ put resolvedBCOArity+ putArray resolvedBCOInstrs+ putArray resolvedBCOBitmap+ putArray resolvedBCOLits+ put resolvedBCOPtrs+ get = ResolvedBCO <$> get <*> getArray <*> getArray <*> getArray <*> get++-- Specialized versions of the binary get/put for UArray Int Word.+-- This saves a bit of time and allocation over using the default+-- get/put, because we get specialisd code and also avoid serializing+-- the bounds.+putArray :: UArray Int Word -> Put+putArray a@(UArray _ _ n _) = do+ put n+ mapM_ put (elems a)++getArray :: Get (UArray Int Word)+getArray = do+ n <- get+ xs <- gets n []+ return $! mkArray n xs+ where+ gets 0 xs = return xs+ gets n xs = do+ x <- get+ gets (n-1) (x:xs)++ mkArray :: Int -> [Word] -> UArray Int Word+ mkArray n0 xs0 = runST $ do+ !marr <- newArray (0,n0-1) 0+ let go 0 _ = return ()+ go _ [] = error "mkArray"+ go n (x:xs) = do+ let n' = n-1+ unsafeWrite marr n' x+ go n' xs+ go n0 xs0+ unsafeFreezeSTUArray marr++data ResolvedBCOPtr+ = ResolvedBCORef {-# UNPACK #-} !Int+ -- ^ reference to the Nth BCO in the current set+ | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)+ -- ^ reference to a previously created BCO+ | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())+ -- ^ reference to a static ptr+ | ResolvedBCOPtrBCO ResolvedBCO+ -- ^ a nested BCO+ | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)+ -- ^ Resolves to the MutableArray# inside the BreakArray+ deriving (Generic, Show)++instance Binary ResolvedBCOPtr
+ GHCi/Run.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,+ UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Execute GHCi messages+--+module GHCi.Run+ ( run, redirectInterrupts+ , toSerializableException, fromSerializableException+ ) where++import GHCi.CreateBCO+import GHCi.InfoTable+import GHCi.FFI+import GHCi.Message+import GHCi.ObjLink+import GHCi.RemoteTypes+import GHCi.TH+import GHCi.BreakArray++import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as B+import GHC.Exts+import GHC.Stack+import Foreign+import Foreign.C+import GHC.Conc.Sync+import GHC.IO hiding ( bracket )+import System.Exit+import System.Mem.Weak ( deRefWeak )+import Unsafe.Coerce++-- -----------------------------------------------------------------------------+-- Implement messages++run :: Message a -> IO a+run m = case m of+ InitLinker -> initObjLinker+ LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str+ LookupClosure str -> lookupClosure str+ LoadDLL str -> loadDLL str+ LoadArchive str -> loadArchive str+ LoadObj str -> loadObj str+ UnloadObj str -> unloadObj str+ AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str+ RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)+ ResolveObjs -> resolveObjs+ FindSystemLibrary str -> findSystemLibrary str+ CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)+ FreeHValueRefs rs -> mapM_ freeRemoteRef rs+ EvalStmt opts r -> evalStmt opts r+ ResumeStmt opts r -> resumeStmt opts r+ AbandonStmt r -> abandonStmt r+ EvalString r -> evalString r+ EvalStringToString r s -> evalStringToString r s+ EvalIO r -> evalIO r+ MkCostCentres mod ccs -> mkCostCentres mod ccs+ CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)+ NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz+ EnableBreakpoint ref ix b -> do+ arr <- localRef ref+ _ <- if b then setBreakOn arr ix else setBreakOff arr ix+ return ()+ BreakpointStatus ref ix -> do+ arr <- localRef ref; r <- getBreak arr ix+ case r of+ Nothing -> return False+ Just w -> return (w /= 0)+ GetBreakpointVar ref ix -> do+ aps <- localRef ref+ mapM mkRemoteRef =<< getIdValFromApStack aps ix+ MallocData bs -> mkString bs+ MallocStrings bss -> mapM mkString0 bss+ PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res+ FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)+ MkConInfoTable ptrs nptrs tag desc ->+ toRemotePtr <$> mkConInfoTable ptrs nptrs tag desc+ StartTH -> startTH+ _other -> error "GHCi.Run.run"++evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])+evalStmt opts expr = do+ io <- mkIO expr+ sandboxIO opts $ do+ rs <- unsafeCoerce io :: IO [HValue]+ mapM mkRemoteRef rs+ where+ mkIO (EvalThis href) = localRef href+ mkIO (EvalApp l r) = do+ l' <- mkIO l+ r' <- mkIO r+ return ((unsafeCoerce l' :: HValue -> HValue) r')++evalIO :: HValueRef -> IO (EvalResult ())+evalIO r = do+ io <- localRef r+ tryEval (unsafeCoerce io :: IO ())++evalString :: HValueRef -> IO (EvalResult String)+evalString r = do+ io <- localRef r+ tryEval $ do+ r <- unsafeCoerce io :: IO String+ evaluate (force r)++evalStringToString :: HValueRef -> String -> IO (EvalResult String)+evalStringToString r str = do+ io <- localRef r+ tryEval $ do+ r <- (unsafeCoerce io :: String -> IO String) str+ evaluate (force r)++-- 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 :: EvalOpts -> IO a -> IO (EvalStatus a)+sandboxIO opts io = do+ -- We are running in uninterruptibleMask+ breakMVar <- newEmptyMVar+ statusMVar <- newEmptyMVar+ withBreakAction opts breakMVar statusMVar $ do+ let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io+ if useSandboxThread opts+ then do+ tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar+ -- empty: can't block+ redirectInterrupts tid $ unsafeUnmask $ 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++-- 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 :: EvalOpts -> IO a -> IO a+rethrow EvalOpts{..} io =+ catch io $ \se -> do+ -- If -fbreak-on-error, we break unconditionally,+ -- but with care of not breaking twice+ if breakOnError && not breakOnException+ 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+ throwIO se++--+-- 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 (EvalResult a) -> IO (EvalStatus a)+measureAlloc io = do+ setAllocationCounter maxBound+ a <- io+ ctr <- getAllocationCounter+ let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr+ return (EvalComplete allocs a)++-- Exceptions can't be marshaled because they're dynamically typed, so+-- everything becomes a String.+tryEval :: IO a -> IO (EvalResult a)+tryEval io = do+ e <- try io+ case e of+ Left ex -> return (EvalException (toSerializableException ex))+ Right a -> return (EvalSuccess a)++toSerializableException :: SomeException -> SerializableException+toSerializableException ex+ | Just UserInterrupt <- fromException ex = EUserInterrupt+ | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)+ | otherwise = EOtherException (show (ex :: SomeException))++fromSerializableException :: SerializableException -> SomeException+fromSerializableException EUserInterrupt = toException UserInterrupt+fromSerializableException (EExitCode c) = toException c+fromSerializableException (EOtherException str) = toException (ErrorCall str)++-- 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 :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a+withBreakAction opts breakMVar statusMVar act+ = bracket setBreakAction resetBreakAction (\_ -> act)+ where+ setBreakAction = do+ stablePtr <- newStablePtr onBreak+ poke breakPointIOAction stablePtr+ when (breakOnException opts) $ poke exceptionFlag 1+ when (singleStep opts) $ 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 :: BreakpointCallback+ onBreak ix# uniq# is_exception apStack = do+ tid <- myThreadId+ let resume = ResumeContext+ { resumeBreakMVar = breakMVar+ , resumeStatusMVar = statusMVar+ , resumeThreadId = tid }+ resume_r <- mkRemoteRef resume+ apStack_r <- mkRemoteRef apStack+ ccs <- toRemotePtr <$> getCCSOf apStack+ putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs+ takeMVar breakMVar++ resetBreakAction stablePtr = do+ poke breakPointIOAction noBreakStablePtr+ poke exceptionFlag 0+ resetStepFlag+ freeStablePtr stablePtr++resumeStmt+ :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])+ -> IO (EvalStatus [HValueRef])+resumeStmt opts hvref = do+ ResumeContext{..} <- localRef hvref+ withBreakAction opts resumeBreakMVar resumeStatusMVar $+ mask_ $ do+ putMVar resumeBreakMVar () -- this awakens the stopped thread...+ redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar++-- 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.+abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt hvref = do+ ResumeContext{..} <- localRef hvref+ killThread resumeThreadId+ putMVar resumeBreakMVar ()+ _ <- takeMVar resumeStatusMVar+ return ()++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++type BreakpointCallback = Int# -> Int# -> Bool -> HValue -> IO ()++foreign import ccall "&rts_breakpoint_io_action"+ breakPointIOAction :: Ptr (StablePtr BreakpointCallback)++noBreakStablePtr :: StablePtr BreakpointCallback+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction++noBreakAction :: BreakpointCallback+noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"+noBreakAction _ _ True _ = return () -- exception: just continue++-- Malloc and copy the bytes. We don't have any way to monitor the+-- lifetime of this memory, so it just leaks.+mkString :: ByteString -> IO (RemotePtr ())+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+ ptr <- mallocBytes len+ copyBytes ptr cstr len+ return (castRemotePtr (toRemotePtr ptr))++mkString0 :: ByteString -> IO (RemotePtr ())+mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+ ptr <- mallocBytes (len+1)+ copyBytes ptr cstr len+ pokeElemOff (ptr :: Ptr CChar) len 0+ return (castRemotePtr (toRemotePtr ptr))++mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]+#if defined(PROFILING)+mkCostCentres mod ccs = do+ c_module <- newCString mod+ mapM (mk_one c_module) ccs+ where+ mk_one c_module (decl_path,srcspan) = do+ c_name <- newCString decl_path+ c_srcspan <- newCString srcspan+ toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan++foreign import ccall unsafe "mkCostCentre"+ c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)+#else+mkCostCentres _ _ = return []+#endif++getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)+getIdValFromApStack apStack (I# stackDepth) = do+ case getApStackVal# apStack (stackDepth +# 1#) of+ -- The +1 is magic! I don't know where it comes+ -- from, but this makes things line up. --SDM+ (# ok, result #) ->+ case ok of+ 0# -> return Nothing -- AP_STACK not found+ _ -> return (Just (unsafeCoerce# result))
+ GHCi/Signals.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+module GHCi.Signals (installSignalHandlers) where++import Control.Concurrent+import Control.Exception+import System.Mem.Weak ( deRefWeak )++#ifndef mingw32_HOST_OS+import System.Posix.Signals+#endif++#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler+#endif++-- | Install standard signal handlers for catching ^C, which just throw an+-- exception in the target thread. The current target thread is the+-- thread at the head of the list in the MVar passed to+-- installSignalHandlers.+installSignalHandlers :: IO ()+installSignalHandlers = do+ main_thread <- myThreadId+ wtid <- mkWeakThreadId main_thread++ let interrupt = do+ r <- deRefWeak wtid+ case r of+ Nothing -> return ()+ Just t -> throwTo t UserInterrupt++#if !defined(mingw32_HOST_OS)+ _ <- installHandler sigQUIT (Catch interrupt) Nothing+ _ <- installHandler sigINT (Catch interrupt) Nothing+#else+ -- GHC 6.3+ has support for console events on Windows+ -- NOTE: running GHCi under a bash shell for some reason requires+ -- you to press Ctrl-Break rather than Ctrl-C to provoke+ -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know+ -- why --SDM 17/12/2004+ let sig_handler ControlC = interrupt+ sig_handler Break = interrupt+ sig_handler _ = return ()++ _ <- installHandler (Catch sig_handler)+#endif+ return ()
+ GHCi/TH.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,+ TupleSections, RecordWildCards, InstanceSigs #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Running TH splices+--+module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where++import GHCi.Message+import GHCi.RemoteTypes+import GHC.Serialized++import Control.Exception+import qualified Control.Monad.Fail as Fail+import Data.Binary+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Data+import Data.Dynamic+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import GHC.Desugar+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH+import Unsafe.Coerce++initQState :: Pipe -> QState+initQState p = QState M.empty [] Nothing p++runModFinalizers :: GHCiQ ()+runModFinalizers = go =<< getState+ where+ go s | (f:ff) <- qsFinalizers s = do+ putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go+ go _ = return ()++newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }++data GHCiQException = GHCiQException QState String+ deriving (Show, Typeable)++instance Exception GHCiQException++instance Functor GHCiQ where+ fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s++instance Applicative GHCiQ where+ f <*> a = GHCiQ $ \s ->+ do (f',s') <- runGHCiQ f s+ (a',s'') <- runGHCiQ a s'+ return (f' a', s'')+ pure x = GHCiQ (\s -> return (x,s))++instance Monad GHCiQ where+ m >>= f = GHCiQ $ \s ->+ do (m', s') <- runGHCiQ m s+ (a, s'') <- runGHCiQ (f m') s'+ return (a, s'')++ fail = Fail.fail++instance Fail.MonadFail GHCiQ where+ fail err = GHCiQ $ \s -> throwIO (GHCiQException s err)++getState :: GHCiQ QState+getState = GHCiQ $ \s -> return (s,s)++putState :: QState -> GHCiQ ()+putState s = GHCiQ $ \_ -> return ((),s)++noLoc :: TH.Loc+noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)++ghcCmd :: Binary a => Message (THResult a) -> GHCiQ a+ghcCmd m = GHCiQ $ \s -> do+ r <- remoteCall (qsPipe s) m+ case r of+ THException str -> throwIO (GHCiQException s str)+ THComplete res -> return (res, s)++instance TH.Quasi GHCiQ where+ qNewName str = ghcCmd (NewName str)+ qReport isError msg = ghcCmd (Report isError msg)++ -- See Note [TH recover with -fexternal-interpreter] in TcSplice+ qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do+ remoteCall (qsPipe s) StartRecover+ (r, s') <- a s+ remoteCall (qsPipe s) (EndRecover False)+ return (r,s'))+ `catch`+ \GHCiQException{} -> remoteCall (qsPipe s) (EndRecover True) >> h s+ qLookupName isType occ = ghcCmd (LookupName isType occ)+ qReify name = ghcCmd (Reify name)+ qReifyFixity name = ghcCmd (ReifyFixity name)+ qReifyInstances name tys = ghcCmd (ReifyInstances name tys)+ qReifyRoles name = ghcCmd (ReifyRoles name)++ -- To reify annotations, we send GHC the AnnLookup and also the+ -- TypeRep of the thing we're looking for, to avoid needing to+ -- serialize irrelevant annotations.+ qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]+ qReifyAnnotations lookup =+ map (deserializeWithData . B.unpack) <$>+ ghcCmd (ReifyAnnotations lookup typerep)+ where typerep = typeOf (undefined :: a)++ qReifyModule m = ghcCmd (ReifyModule m)+ qReifyConStrictness name = ghcCmd (ReifyConStrictness name)+ qLocation = fromMaybe noLoc . qsLocation <$> getState+ qRunIO m = GHCiQ $ \s -> fmap (,s) m+ qAddDependentFile file = ghcCmd (AddDependentFile file)+ qAddTopDecls decls = ghcCmd (AddTopDecls decls)+ qAddModFinalizer fin = GHCiQ $ \s ->+ return ((), s { qsFinalizers = fin : qsFinalizers s })+ qGetQ = GHCiQ $ \s ->+ let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a+ lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m+ in return (lookup (qsMap s), s)+ qPutQ k = GHCiQ $ \s ->+ return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })+ qIsExtEnabled x = ghcCmd (IsExtEnabled x)+ qExtsEnabled = ghcCmd ExtsEnabled++startTH :: IO (RemoteRef (IORef QState))+startTH = do+ r <- newIORef (initQState (error "startTH: no pipe"))+ mkRemoteRef r++finishTH :: Pipe -> RemoteRef (IORef QState) -> IO ()+finishTH pipe rstate = do+ qstateref <- localRef rstate+ qstate <- readIORef qstateref+ _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }+ return ()++runTH+ :: Pipe -> RemoteRef (IORef QState) -> HValueRef+ -> THResultType+ -> Maybe TH.Loc+ -> IO ByteString+runTH pipe rstate rhv ty mb_loc = do+ hv <- localRef rhv+ case ty of+ THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)+ THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)+ THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)+ THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])+ THAnnWrapper -> do+ hv <- unsafeCoerce <$> localRef rhv+ case hv :: AnnotationWrapper of+ AnnotationWrapper thing -> return $!+ LB.toStrict (runPut (put (toSerialized serializeWithData thing)))++runTHQ+ :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a+ -> IO ByteString+runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do+ qstateref <- localRef rstate+ qstate <- readIORef qstateref+ let st = qstate { qsLocation = mb_loc, qsPipe = pipe }+ (r,new_state) <- runGHCiQ (TH.runQ ghciq) st+ writeIORef qstateref new_state+ return $! LB.toStrict (runPut (put r))
+ GHCi/TH/Binary.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- This module is full of orphans, unfortunately+module GHCi.TH.Binary () where++import Data.Binary+import qualified Data.ByteString as B+import Data.Typeable+import GHC.Serialized+import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Syntax as TH++-- Put these in a separate module because they take ages to compile++instance Binary TH.Loc+instance Binary TH.Name+instance Binary TH.ModName+instance Binary TH.NameFlavour+instance Binary TH.PkgName+instance Binary TH.NameSpace+instance Binary TH.Module+instance Binary TH.Info+instance Binary TH.Type+instance Binary TH.TyLit+instance Binary TH.TyVarBndr+instance Binary TH.Role+instance Binary TH.Lit+instance Binary TH.Range+instance Binary TH.Stmt+instance Binary TH.Pat+instance Binary TH.Exp+instance Binary TH.Dec+instance Binary TH.Overlap+instance Binary TH.Guard+instance Binary TH.Body+instance Binary TH.Match+instance Binary TH.Fixity+instance Binary TH.TySynEqn+instance Binary TH.FamFlavour+instance Binary TH.FunDep+instance Binary TH.AnnTarget+instance Binary TH.RuleBndr+instance Binary TH.Phases+instance Binary TH.RuleMatch+instance Binary TH.Inline+instance Binary TH.Pragma+instance Binary TH.Safety+instance Binary TH.Callconv+instance Binary TH.Foreign+instance Binary TH.Bang+instance Binary TH.SourceUnpackedness+instance Binary TH.SourceStrictness+instance Binary TH.DecidedStrictness+instance Binary TH.FixityDirection+instance Binary TH.OccName+instance Binary TH.Con+instance Binary TH.AnnLookup+instance Binary TH.ModuleInfo+instance Binary TH.Clause+instance Binary TH.InjectivityAnn+instance Binary TH.FamilyResultSig+instance Binary TH.TypeFamilyHead++-- We need Binary TypeRep for serializing annotations++instance Binary TyCon where+ put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc)+ get = mkTyCon3 <$> get <*> get <*> get++instance Binary TypeRep where+ put type_rep = put (splitTyConApp type_rep)+ get = do+ (ty_con, child_type_reps) <- get+ return (mkTyConApp ty_con child_type_reps)++instance Binary Serialized where+ put (Serialized tyrep wds) = put tyrep >> put (B.pack wds)+ get = Serialized <$> get <*> (B.unpack <$> get)
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2002, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ SizedSeq.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}+module SizedSeq+ ( SizedSeq(..)+ , emptySS+ , addToSS+ , addListToSS+ , ssElts+ , sizeSS+ ) where++import Data.Binary+import Data.List+import GHC.Generics++data SizedSeq a = SizedSeq !Word [a]+ deriving (Generic, Show)++instance Functor SizedSeq where+ fmap f (SizedSeq sz l) = SizedSeq sz (fmap f l)++instance Foldable SizedSeq where+ foldr f c ss = foldr f c (ssElts ss)++instance Traversable SizedSeq where+ traverse f (SizedSeq sz l) = SizedSeq sz . reverse <$> traverse f (reverse l)++instance Binary a => Binary (SizedSeq 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
+ changelog.md view
@@ -0,0 +1,5 @@+## 8.0.1 *Feb 2016*++ * Bundled with GHC 8.0.1++ * Initial version
+ ghci.cabal view
@@ -0,0 +1,72 @@+-- WARNING: ghci.cabal is automatically generated from ghci.cabal.in by+-- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal.++name: ghci+version: 8.0.1+license: BSD3+license-file: LICENSE+category: GHC+maintainer: ghc-devs@haskell.org+bug-reports: https://ghc.haskell.org/trac/ghc/newticket+synopsis: The library supporting GHC's interactive interpreter+description:+ This library offers interfaces which mediate interactions between the+ @ghci@ interactive shell and @iserv@, GHC's out-of-process interpreter+ backend.+cabal-version: >=1.10+build-type: Simple+extra-source-files: changelog.md++source-repository head+ type: git+ location: http://git.haskell.org/ghc.git+ subdir: libraries/ghci++library+ default-language: Haskell2010+ other-extensions:+ BangPatterns+ CPP+ DeriveGeneric+ ExistentialQuantification+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ MagicHash+ MultiParamTypeClasses+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ UnboxedTuples++ exposed-modules:+ GHCi.BreakArray+ GHCi.Message+ GHCi.ResolvedBCO+ GHCi.RemoteTypes+ GHCi.ObjLink+ GHCi.CreateBCO+ GHCi.FFI+ GHCi.InfoTable+ GHCi.Run+ GHCi.Signals+ GHCi.TH+ GHCi.TH.Binary+ SizedSeq++ Build-Depends:+ array == 0.5.*,+ base == 4.9.*,+ binary == 0.8.*,+ bytestring == 0.10.*,+ containers == 0.5.*,+ deepseq == 1.4.*,+ filepath == 1.4.*,+ ghc-boot == 8.0.1,+ template-haskell == 2.11.*,+ transformers == 0.5.*++ if !os(windows)+ Build-Depends: unix == 2.7.*