summaryrefslogtreecommitdiff
path: root/libraries/ghci
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/ghci')
-rw-r--r--libraries/ghci/GHCi/CreateBCO.hs147
-rw-r--r--libraries/ghci/GHCi/FFI.hsc149
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc348
-rw-r--r--libraries/ghci/GHCi/Message.hs386
-rw-r--r--libraries/ghci/GHCi/ObjLink.hs158
-rw-r--r--libraries/ghci/GHCi/RemoteTypes.hs91
-rw-r--r--libraries/ghci/GHCi/ResolvedBCO.hs62
-rw-r--r--libraries/ghci/GHCi/Run.hs308
-rw-r--r--libraries/ghci/GHCi/Signals.hs46
-rw-r--r--libraries/ghci/GHCi/TH.hs175
-rw-r--r--libraries/ghci/GHCi/TH/Binary.hs73
-rw-r--r--libraries/ghci/GNUmakefile4
-rw-r--r--libraries/ghci/LICENSE31
-rw-r--r--libraries/ghci/SizedSeq.hs37
-rw-r--r--libraries/ghci/ghc.mk5
-rw-r--r--libraries/ghci/ghci.cabal41
16 files changed, 2061 insertions, 0 deletions
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
new file mode 100644
index 0000000000..026e3eafbd
--- /dev/null
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -0,0 +1,147 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# 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 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 mkHValueRef 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 <- localHValueRef 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 (ResolvedBCOPtrLocal hv) i = do
+ writePtrsArrayHValue i hv 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#
+
+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 #)
+ }}
diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc
new file mode 100644
index 0000000000..36619aeb5d
--- /dev/null
+++ b/libraries/ghci/GHCi/FFI.hsc
@@ -0,0 +1,149 @@
+-----------------------------------------------------------------------------
+--
+-- libffi bindings
+--
+-- (c) The University of Glasgow 2008
+--
+-----------------------------------------------------------------------------
+
+#include <ffi.h>
+
+{-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-}
+module GHCi.FFI
+ ( FFIType(..)
+ , FFIConv(..)
+ , 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 ()) -- 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 () -> 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 ()
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
new file mode 100644
index 0000000000..d9d63146dd
--- /dev/null
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -0,0 +1,348 @@
+{-# 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
+
+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 ())
+ -- 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
+ deriving Show
+
+platform :: Arch
+platform =
+#if defined(sparc_HOST_ARCH)
+ ArchSparc
+#elif defined(ppc_HOST_ARCH)
+ ArchPPC
+#elif defined(x86_HOST_ARCH)
+ ArchX86
+#elif defined(x86_64_HOST_ARCH)
+ ArchX86_64
+#elif defined(alpha_HOST_ARCH)
+ ArchAlpha
+#elif defined(arm_HOST_ARCH)
+ ArchARM
+#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]
+
+
+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
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
new file mode 100644
index 0000000000..bdf29cbd73
--- /dev/null
+++ b/libraries/ghci/GHCi/Message.hs
@@ -0,0 +1,386 @@
+{-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving,
+ GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
+
+module GHCi.Message
+ ( Message(..), Msg(..)
+ , EvalStatus(..), EvalResult(..), EvalOpts(..), EvalExpr(..)
+ , SerializableException(..)
+ , THResult(..), THResultType(..)
+ , getMessage, putMessage
+ , Pipe(..), remoteCall, readPipe, writePipe
+ ) where
+
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.FFI
+import GHCi.TH.Binary ()
+
+import GHC.LanguageExtensions
+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.IORef
+import Data.Typeable
+import GHC.Generics
+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 :: [ResolvedBCO] -> Message [HValueRef]
+
+ -- | Release 'HValueRef's
+ FreeHValueRefs :: [HValueRef] -> Message ()
+
+ -- | Malloc some data and return a 'RemotePtr' to it
+ MallocData :: ByteString -> Message RemotePtr
+
+ -- | Calls 'GHCi.FFI.prepareForeignCall'
+ PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message RemotePtr
+
+ -- | Free data previously created by 'PrepFFI'
+ FreeFFI :: RemotePtr -> Message ()
+
+ -- | Create an info table for a constructor
+ MkConInfoTable
+ :: Int -- ptr words
+ -> Int -- non-ptr words
+ -> Int -- constr tag
+ -> [Word8] -- constructor desccription
+ -> Message RemotePtr
+
+ -- | Evaluate a statement
+ EvalStmt
+ :: EvalOpts
+ -> EvalExpr HValueRef {- IO [a] -}
+ -> Message (EvalStatus [HValueRef]) {- [a] -}
+
+ -- | Resume evaluation of a statement after a breakpoint
+ ResumeStmt
+ :: EvalOpts
+ -> HValueRef {- ResumeContext -}
+ -> Message (EvalStatus [HValueRef])
+
+ -- | Abandon evaluation of a statement after a breakpoint
+ AbandonStmt
+ :: HValueRef {- ResumeContext -}
+ -> 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 ())
+
+ -- Template Haskell -------------------------------------------
+
+ -- | Start a new TH module, return a state token that should be
+ StartTH :: Message HValueRef {- GHCiQState -}
+
+ -- | Run TH module finalizers, and free the HValueRef
+ FinishTH :: HValueRef {- GHCiQState -} -> 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
+ :: HValueRef {- GHCiQState -}
+ -> 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 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)
+
+ AddDependentFile :: FilePath -> Message (THResult ())
+ AddTopDecls :: [TH.Dec] -> Message (THResult ())
+ IsExtEnabled :: Extension -> Message (THResult Bool)
+ ExtsEnabled :: Message (THResult [Extension])
+
+ -- 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
+
+-- | 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)
+
+data EvalStatus a
+ = EvalComplete Word64 (EvalResult a)
+ | EvalBreak Bool
+ HValueRef{- AP_STACK -}
+ HValueRef{- BreakInfo -}
+ HValueRef{- ResumeContext -}
+ deriving (Generic, Show)
+
+instance Binary a => Binary (EvalStatus a)
+
+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 appropraite 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 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 <$> (PrepFFI <$> get <*> get <*> get)
+ 16 -> Msg <$> FreeFFI <$> get
+ 17 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get)
+ 18 -> Msg <$> (EvalStmt <$> get <*> get)
+ 19 -> Msg <$> (ResumeStmt <$> get <*> get)
+ 20 -> Msg <$> (AbandonStmt <$> get)
+ 21 -> Msg <$> (EvalString <$> get)
+ 22 -> Msg <$> (EvalStringToString <$> get <*> get)
+ 23 -> Msg <$> (EvalIO <$> get)
+ 24 -> Msg <$> return StartTH
+ 25 -> Msg <$> FinishTH <$> get
+ 26 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
+ 27 -> Msg <$> NewName <$> get
+ 28 -> Msg <$> (Report <$> get <*> get)
+ 29 -> Msg <$> (LookupName <$> get <*> get)
+ 30 -> Msg <$> Reify <$> get
+ 31 -> Msg <$> ReifyFixity <$> get
+ 32 -> Msg <$> (ReifyInstances <$> get <*> get)
+ 33 -> Msg <$> ReifyRoles <$> get
+ 34 -> Msg <$> (ReifyAnnotations <$> get <*> get)
+ 35 -> Msg <$> ReifyModule <$> get
+ 36 -> Msg <$> AddDependentFile <$> get
+ 37 -> Msg <$> AddTopDecls <$> get
+ 38 -> Msg <$> (IsExtEnabled <$> get)
+ 39 -> Msg <$> return ExtsEnabled
+ 40 -> Msg <$> return QDone
+ 41 -> 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
+ PrepFFI conv args res -> putWord8 15 >> put conv >> put args >> put res
+ FreeFFI p -> putWord8 16 >> put p
+ MkConInfoTable p n t d -> putWord8 17 >> put p >> put n >> put t >> put d
+ EvalStmt opts val -> putWord8 18 >> put opts >> put val
+ ResumeStmt opts val -> putWord8 19 >> put opts >> put val
+ AbandonStmt val -> putWord8 20 >> put val
+ EvalString val -> putWord8 21 >> put val
+ EvalStringToString str val -> putWord8 22 >> put str >> put val
+ EvalIO val -> putWord8 23 >> put val
+ StartTH -> putWord8 24
+ FinishTH val -> putWord8 25 >> put val
+ RunTH st q loc ty -> putWord8 26 >> put st >> put q >> put loc >> put ty
+ NewName a -> putWord8 27 >> put a
+ Report a b -> putWord8 28 >> put a >> put b
+ LookupName a b -> putWord8 29 >> put a >> put b
+ Reify a -> putWord8 30 >> put a
+ ReifyFixity a -> putWord8 31 >> put a
+ ReifyInstances a b -> putWord8 32 >> put a >> put b
+ ReifyRoles a -> putWord8 33 >> put a
+ ReifyAnnotations a b -> putWord8 34 >> put a >> put b
+ ReifyModule a -> putWord8 35 >> put a
+ AddDependentFile a -> putWord8 36 >> put a
+ AddTopDecls a -> putWord8 37 >> put a
+ IsExtEnabled a -> putWord8 38 >> put a
+ ExtsEnabled -> putWord8 39
+ QDone -> putWord8 40
+ QException a -> putWord8 41 >> put a
+ QFail a -> putWord8 42 >> 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))
diff --git a/libraries/ghci/GHCi/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs
new file mode 100644
index 0000000000..710cffd1a6
--- /dev/null
+++ b/libraries/ghci/GHCi/ObjLink.hs
@@ -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 <$> mkHValueRef (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
diff --git a/libraries/ghci/GHCi/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs
new file mode 100644
index 0000000000..920ce93fe6
--- /dev/null
+++ b/libraries/ghci/GHCi/RemoteTypes.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+module GHCi.RemoteTypes
+ ( RemotePtr(..), toRemotePtr, fromRemotePtr
+ , HValue(..)
+ , HValueRef, mkHValueRef, localHValueRef, freeHValueRef
+ , ForeignHValue, mkForeignHValue, withForeignHValue
+ , unsafeForeignHValueToHValueRef, finalizeForeignHValue
+ ) where
+
+import Data.Word
+import Foreign hiding (newForeignPtr)
+import Foreign.Concurrent
+import Data.Binary
+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 = RemotePtr Word32
+#elif SIZEOF_HSINT == 8
+newtype RemotePtr = RemotePtr Word64
+#endif
+
+toRemotePtr :: Ptr a -> RemotePtr
+toRemotePtr p = RemotePtr (fromIntegral (ptrToWordPtr p))
+
+fromRemotePtr :: RemotePtr -> Ptr a
+fromRemotePtr (RemotePtr p) = wordPtrToPtr (fromIntegral p)
+
+deriving instance Show RemotePtr
+deriving instance Binary RemotePtr
+
+-- -----------------------------------------------------------------------------
+-- HValueRef
+
+newtype HValue = HValue Any
+
+instance Show HValue where
+ show _ = "<HValue>"
+
+newtype HValueRef = HValueRef RemotePtr
+ deriving (Show, Binary)
+
+-- | Make a reference to a local HValue that we can send remotely.
+-- This reference will keep the value that it refers to alive until
+-- 'freeHValueRef' is called.
+mkHValueRef :: HValue -> IO HValueRef
+mkHValueRef (HValue hv) = do
+ sp <- newStablePtr hv
+ return $! HValueRef (toRemotePtr (castStablePtrToPtr sp))
+
+-- | Convert an HValueRef to an HValue. Should only be used if the HValue
+-- originated in this process.
+localHValueRef :: HValueRef -> IO HValue
+localHValueRef (HValueRef w) = do
+ p <- deRefStablePtr (castPtrToStablePtr (fromRemotePtr w))
+ return (HValue p)
+
+-- | Release an HValueRef that originated in this process
+freeHValueRef :: HValueRef -> IO ()
+freeHValueRef (HValueRef w) =
+ freeStablePtr (castPtrToStablePtr (fromRemotePtr w))
+
+-- | An HValueRef with a finalizer
+newtype ForeignHValue = ForeignHValue (ForeignPtr ())
+
+-- | Create a 'ForeignHValue' from an 'HValueRef'. 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).
+mkForeignHValue :: HValueRef -> IO () -> IO ForeignHValue
+mkForeignHValue (HValueRef hvref) finalizer =
+ ForeignHValue <$> newForeignPtr (fromRemotePtr hvref) finalizer
+
+-- | Use a 'ForeignHValue'
+withForeignHValue :: ForeignHValue -> (HValueRef -> IO a) -> IO a
+withForeignHValue (ForeignHValue fp) f =
+ withForeignPtr fp (f . HValueRef . toRemotePtr)
+
+unsafeForeignHValueToHValueRef :: ForeignHValue -> HValueRef
+unsafeForeignHValueToHValueRef (ForeignHValue fp) =
+ HValueRef (toRemotePtr (unsafeForeignPtrToPtr fp))
+
+finalizeForeignHValue :: ForeignHValue -> IO ()
+finalizeForeignHValue (ForeignHValue fp) = finalizeForeignPtr fp
diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs
new file mode 100644
index 0000000000..9234210418
--- /dev/null
+++ b/libraries/ghci/GHCi/ResolvedBCO.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving #-}
+module GHCi.ResolvedBCO
+ ( ResolvedBCO(..)
+ , ResolvedBCOPtr(..)
+ ) where
+
+import SizedSeq
+import GHCi.RemoteTypes
+
+import Data.Array.Unboxed
+import Data.Binary
+import GHC.Generics
+
+-- -----------------------------------------------------------------------------
+-- ResolvedBCO
+
+-- A ResolvedBCO is one in which all the Name references have been
+-- resolved to actual addresses or RemoteHValues.
+
+data ResolvedBCO
+ = ResolvedBCO {
+ resolvedBCOArity :: Int,
+ resolvedBCOInstrs :: UArray Int Word16, -- insns
+ resolvedBCOBitmap :: UArray Int Word, -- bitmap
+ resolvedBCOLits :: UArray Int Word, -- non-ptrs
+ resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs
+ }
+ deriving (Generic, Show)
+
+instance Binary ResolvedBCO
+
+data ResolvedBCOPtr
+ = ResolvedBCORef Int
+ -- ^ reference to the Nth BCO in the current set
+ | ResolvedBCOPtr HValueRef
+ -- ^ reference to a previously created BCO
+ | ResolvedBCOStaticPtr RemotePtr
+ -- ^ reference to a static ptr
+ | ResolvedBCOPtrBCO ResolvedBCO
+ -- ^ a nested BCO
+ | ResolvedBCOPtrLocal HValue
+ -- ^ something local, cannot be serialized
+ deriving (Generic, Show)
+
+-- Manual Binary instance is needed because we cannot serialize
+-- ResolvedBCOPtrLocal. This will go away once we have support for
+-- remote breakpoints.
+instance Binary ResolvedBCOPtr where
+ put (ResolvedBCORef a) = putWord8 0 >> put a
+ put (ResolvedBCOPtr a) = putWord8 1 >> put a
+ put (ResolvedBCOStaticPtr a) = putWord8 2 >> put a
+ put (ResolvedBCOPtrBCO a) = putWord8 3 >> put a
+ put (ResolvedBCOPtrLocal _) =
+ error "Cannot serialize a local pointer. Use -fno-external-interpreter?"
+
+ get = do
+ w <- getWord8
+ case w of
+ 0 -> ResolvedBCORef <$> get
+ 1 -> ResolvedBCOPtr <$> get
+ 2 -> ResolvedBCOStaticPtr <$> get
+ _ -> ResolvedBCOPtrBCO <$> get
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
new file mode 100644
index 0000000000..69f82db689
--- /dev/null
+++ b/libraries/ghci/GHCi/Run.hs
@@ -0,0 +1,308 @@
+{-# LANGUAGE GADTs, RecordWildCards, UnboxedTuples, MagicHash,
+ ScopedTypeVariables #-}
+{-# 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 Control.Concurrent
+import Control.DeepSeq
+import Control.Exception
+import Control.Monad
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Unsafe as B
+import GHC.Exts
+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 bco -> createBCOs bco
+ FreeHValueRefs rs -> mapM_ freeHValueRef 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
+ MallocData bs -> mkString bs
+ 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 mkHValueRef rs
+ where
+ mkIO (EvalThis href) = localHValueRef 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 <- localHValueRef r
+ tryEval (unsafeCoerce io :: IO ())
+
+evalString :: HValueRef -> IO (EvalResult String)
+evalString r = do
+ io <- localHValueRef r
+ tryEval $ do
+ r <- unsafeCoerce io :: IO String
+ evaluate (force r)
+
+evalStringToString :: HValueRef -> String -> IO (EvalResult String)
+evalStringToString r str = do
+ io <- localHValueRef 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 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 is_exception info apStack = do
+ tid <- myThreadId
+ let resume = ResumeContext
+ { resumeBreakMVar = breakMVar
+ , resumeStatusMVar = statusMVar
+ , resumeThreadId = tid }
+ resume_r <- mkHValueRef (unsafeCoerce resume)
+ apStack_r <- mkHValueRef apStack
+ info_r <- mkHValueRef info
+ putMVar statusMVar (EvalBreak is_exception apStack_r info_r resume_r)
+ takeMVar breakMVar
+
+ resetBreakAction stablePtr = do
+ poke breakPointIOAction noBreakStablePtr
+ poke exceptionFlag 0
+ resetStepFlag
+ freeStablePtr stablePtr
+
+data ResumeContext a = ResumeContext
+ { resumeBreakMVar :: MVar ()
+ , resumeStatusMVar :: MVar (EvalStatus a)
+ , resumeThreadId :: ThreadId
+ }
+
+resumeStmt :: EvalOpts -> HValueRef -> IO (EvalStatus [HValueRef])
+resumeStmt opts hvref = do
+ ResumeContext{..} <- unsafeCoerce (localHValueRef 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 :: HValueRef -> IO ()
+abandonStmt hvref = do
+ ResumeContext{..} <- unsafeCoerce (localHValueRef 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
+
+foreign import ccall "&rts_breakpoint_io_action"
+ breakPointIOAction :: Ptr (StablePtr (Bool -> HValue -> HValue -> IO ()))
+
+noBreakStablePtr :: StablePtr (Bool -> HValue -> HValue -> IO ())
+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
+
+noBreakAction :: Bool -> HValue -> HValue -> IO ()
+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 (toRemotePtr ptr)
diff --git a/libraries/ghci/GHCi/Signals.hs b/libraries/ghci/GHCi/Signals.hs
new file mode 100644
index 0000000000..9341b6ccab
--- /dev/null
+++ b/libraries/ghci/GHCi/Signals.hs
@@ -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 ()
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
new file mode 100644
index 0000000000..0121da9426
--- /dev/null
+++ b/libraries/ghci/GHCi/TH.hs
@@ -0,0 +1,175 @@
+{-# 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 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
+
+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>"
+
+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'')
+ return = pure
+ 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)
+ qRecover = undefined
+{-
+ qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> do
+ let r :: Bool -> IO ()
+ r b = do EndRecover' <- sendRequest (EndRecover b)
+ return ()
+ StartRecover' <- sendRequest StartRecover
+ (a s >>= \s' -> r False >> return s') `E.catch`
+ \(GHCiQException s' _ _) -> r 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)
+ 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 HValueRef
+startTH = do
+ r <- newIORef (initQState (error "startTH: no pipe"))
+ mkHValueRef (unsafeCoerce r)
+
+finishTH :: Pipe -> HValueRef -> IO ()
+finishTH pipe rstate = do
+ qstateref <- unsafeCoerce <$> localHValueRef rstate
+ qstate <- readIORef qstateref
+ _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe }
+ freeHValueRef rstate
+ return ()
+
+runTH
+ :: Pipe -> HValueRef -> HValueRef
+ -> THResultType
+ -> Maybe TH.Loc
+ -> IO ByteString
+runTH pipe rstate rhv ty mb_loc = do
+ hv <- localHValueRef 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 <$> localHValueRef rhv
+ case hv :: AnnotationWrapper of
+ AnnotationWrapper thing ->
+ return $! LB.toStrict (runPut (put (toSerialized serializeWithData thing)))
+
+runTHQ :: Binary a => Pipe -> HValueRef -> Maybe TH.Loc -> TH.Q a
+ -> IO ByteString
+runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
+ qstateref <- unsafeCoerce <$> localHValueRef 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))
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
new file mode 100644
index 0000000000..41187fdef9
--- /dev/null
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -0,0 +1,73 @@
+{-# 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.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.Strict
+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)
diff --git a/libraries/ghci/GNUmakefile b/libraries/ghci/GNUmakefile
new file mode 100644
index 0000000000..ce6a24f19b
--- /dev/null
+++ b/libraries/ghci/GNUmakefile
@@ -0,0 +1,4 @@
+dir = libraries/ghci
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
+FAST_MAKE_OPTS += stage=0
diff --git a/libraries/ghci/LICENSE b/libraries/ghci/LICENSE
new file mode 100644
index 0000000000..99fa52679d
--- /dev/null
+++ b/libraries/ghci/LICENSE
@@ -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.
diff --git a/libraries/ghci/SizedSeq.hs b/libraries/ghci/SizedSeq.hs
new file mode 100644
index 0000000000..1c23fff2b7
--- /dev/null
+++ b/libraries/ghci/SizedSeq.hs
@@ -0,0 +1,37 @@
+{-# 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 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
diff --git a/libraries/ghci/ghc.mk b/libraries/ghci/ghc.mk
new file mode 100644
index 0000000000..dc6a891bf3
--- /dev/null
+++ b/libraries/ghci/ghc.mk
@@ -0,0 +1,5 @@
+libraries/ghci_PACKAGE = ghci
+libraries/ghci_dist-install_GROUP = libraries
+$(if $(filter ghci,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/ghci,dist-boot,0)))
+$(if $(filter ghci,$(PACKAGES_STAGE1)),$(eval $(call build-package,libraries/ghci,dist-install,1)))
+$(if $(filter ghci,$(PACKAGES_STAGE2)),$(eval $(call build-package,libraries/ghci,dist-install,2)))
diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal
new file mode 100644
index 0000000000..9e2f04599c
--- /dev/null
+++ b/libraries/ghci/ghci.cabal
@@ -0,0 +1,41 @@
+Name: ghci
+Version: 0.0
+Copyright: XXX
+License: BSD3
+-- XXX License-File: LICENSE
+Author: XXX
+Maintainer: XXX
+Synopsis: XXX
+Description:
+ XXX
+Category: Development
+build-type: Simple
+cabal-version: >=1.10
+
+Library
+ Default-Language: Haskell2010
+ Exposed-Modules: 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: base >= 4 && < 5,
+ binary >= 0.7 && < 0.9,
+ bytestring >= 0.10 && < 0.11,
+ containers >= 0.5 && < 0.6,
+ deepseq >= 1.4 && < 1.5,
+ filepath >= 1.4 && < 1.5,
+ ghc-boot,
+ array >= 0.5 && < 0.6,
+ template-haskell >= 2.11 && < 2.12,
+ transformers >= 0.4 && < 0.6
+
+ if !os(windows)
+ Build-Depends: unix >= 2.7 && < 2.8
View Lorry Controller Status