summaryrefslogtreecommitdiff
path: root/compiler/ghci
diff options
context:
space:
mode:
authorSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
committerSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
commit0065d5ab628975892cea1ec7303f968c3338cbe1 (patch)
tree8e2afe0ab48ee33cf95009809d67c9649573ef92 /compiler/ghci
parent28a464a75e14cece5db40f2765a29348273ff2d2 (diff)
downloadhaskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to Cabal, and with the move to darcs we can now flatten the source tree without losing history, so here goes. The main change is that the ghc/ subdir is gone, and most of what it contained is now at the top level. The build system now makes no pretense at being multi-project, it is just the GHC build system. No doubt this will break many things, and there will be a period of instability while we fix the dependencies. A straightforward build should work, but I haven't yet fixed binary/source distributions. Changes to the Building Guide will follow, too.
Diffstat (limited to 'compiler/ghci')
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs497
-rw-r--r--compiler/ghci/ByteCodeFFI.lhs832
-rw-r--r--compiler/ghci/ByteCodeGen.lhs1358
-rw-r--r--compiler/ghci/ByteCodeInstr.lhs256
-rw-r--r--compiler/ghci/ByteCodeItbls.lhs366
-rw-r--r--compiler/ghci/ByteCodeLink.lhs268
-rw-r--r--compiler/ghci/InteractiveUI.hs1534
-rw-r--r--compiler/ghci/Linker.lhs927
-rw-r--r--compiler/ghci/ObjLink.lhs97
-rw-r--r--compiler/ghci/keepCAFsForGHCi.c15
10 files changed, 6150 insertions, 0 deletions
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
new file mode 100644
index 0000000000..e332413dae
--- /dev/null
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -0,0 +1,497 @@
+%
+% (c) The University of Glasgow 2002
+%
+\section[ByteCodeLink]{Bytecode assembler and linker}
+
+\begin{code}
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module ByteCodeAsm (
+ assembleBCOs, assembleBCO,
+
+ CompiledByteCode(..),
+ UnlinkedBCO(..), BCOPtr(..), bcoFreeNames,
+ SizedSeq, sizeSS, ssElts,
+ iNTERP_STACK_CHECK_THRESH
+ ) where
+
+#include "HsVersions.h"
+
+import ByteCodeInstr
+import ByteCodeItbls ( ItblEnv, mkITbls )
+
+import Name ( Name, getName )
+import NameSet
+import FiniteMap ( addToFM, lookupFM, emptyFM )
+import Literal ( Literal(..) )
+import TyCon ( TyCon )
+import PrimOp ( PrimOp )
+import Constants ( wORD_SIZE )
+import FastString ( FastString(..) )
+import SMRep ( CgRep(..), StgWord )
+import FiniteMap
+import Outputable
+
+import Control.Monad ( foldM )
+import Control.Monad.ST ( runST )
+
+import GHC.Word ( Word(..) )
+import Data.Array.MArray
+import Data.Array.Unboxed ( listArray )
+import Data.Array.Base ( UArray(..) )
+import Data.Array.ST ( castSTUArray )
+import Foreign ( Word16, free )
+import Data.Int ( Int64 )
+import Data.Char ( ord )
+
+import GHC.Base ( ByteArray# )
+import GHC.IOBase ( IO(..) )
+import GHC.Ptr ( Ptr(..) )
+
+-- -----------------------------------------------------------------------------
+-- Unlinked BCOs
+
+-- CompiledByteCode represents the result of byte-code
+-- compiling a bunch of functions and data types
+
+data CompiledByteCode
+ = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings
+ ItblEnv -- A mapping from DataCons to their itbls
+
+instance Outputable CompiledByteCode where
+ ppr (ByteCode bcos _) = ppr bcos
+
+
+data UnlinkedBCO
+ = UnlinkedBCO {
+ unlinkedBCOName :: Name,
+ unlinkedBCOArity :: Int,
+ unlinkedBCOInstrs :: ByteArray#, -- insns
+ unlinkedBCOBitmap :: ByteArray#, -- bitmap
+ unlinkedBCOLits :: (SizedSeq (Either Word FastString)), -- literals
+ -- Either literal words or a pointer to a asciiz
+ -- string, denoting a label whose *address* should
+ -- be determined at link time
+ unlinkedBCOPtrs :: (SizedSeq BCOPtr), -- ptrs
+ unlinkedBCOItbls :: (SizedSeq Name) -- itbl refs
+ }
+
+data BCOPtr
+ = BCOPtrName Name
+ | BCOPtrPrimOp PrimOp
+ | BCOPtrBCO UnlinkedBCO
+
+-- | Finds external references. Remember to remove the names
+-- defined by this group of BCOs themselves
+bcoFreeNames :: UnlinkedBCO -> NameSet
+bcoFreeNames bco
+ = bco_refs bco `minusNameSet` mkNameSet [unlinkedBCOName bco]
+ where
+ bco_refs (UnlinkedBCO _ _ _ _ _ ptrs itbls)
+ = unionManyNameSets (
+ mkNameSet [ n | BCOPtrName n <- ssElts ptrs ] :
+ mkNameSet (ssElts itbls) :
+ map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
+ )
+
+instance Outputable UnlinkedBCO where
+ ppr (UnlinkedBCO nm arity insns bitmap lits ptrs itbls)
+ = sep [text "BCO", ppr nm, text "with",
+ int (sizeSS lits), text "lits",
+ int (sizeSS ptrs), text "ptrs",
+ int (sizeSS itbls), text "itbls"]
+
+-- -----------------------------------------------------------------------------
+-- The bytecode assembler
+
+-- The object format for bytecodes is: 16 bits for the opcode, and 16
+-- for each field -- so the code can be considered a sequence of
+-- 16-bit ints. Each field denotes either a stack offset or number of
+-- items on the stack (eg SLIDE), and index into the pointer table (eg
+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
+-- bytecode address in this BCO.
+
+-- Top level assembler fn.
+assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs proto_bcos tycons
+ = do itblenv <- mkITbls tycons
+ bcos <- mapM assembleBCO proto_bcos
+ return (ByteCode bcos itblenv)
+
+assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO (ProtoBCO nm instrs bitmap bsize arity origin malloced)
+ = let
+ -- pass 1: collect up the offsets of the local labels.
+ -- Remember that the first insn starts at offset 1 since offset 0
+ -- (eventually) will hold the total # of insns.
+ label_env = mkLabelEnv emptyFM 1 instrs
+
+ mkLabelEnv env i_offset [] = env
+ mkLabelEnv env i_offset (i:is)
+ = let new_env
+ = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+ in mkLabelEnv new_env (i_offset + instrSize16s i) is
+
+ findLabel lab
+ = case lookupFM label_env lab of
+ Just bco_offset -> bco_offset
+ Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
+ in
+ do -- pass 2: generate the instruction, ptr and nonptr bits
+ insns <- return emptySS :: IO (SizedSeq Word16)
+ lits <- return emptySS :: IO (SizedSeq (Either Word FastString))
+ ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
+ itbls <- return emptySS :: IO (SizedSeq Name)
+ let init_asm_state = (insns,lits,ptrs,itbls)
+ (final_insns, final_lits, final_ptrs, final_itbls)
+ <- mkBits findLabel init_asm_state instrs
+
+ let asm_insns = ssElts final_insns
+ n_insns = sizeSS final_insns
+
+ insns_arr
+ | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
+ | otherwise = mkInstrArray n_insns asm_insns
+ insns_barr = case insns_arr of UArray _lo _hi barr -> barr
+
+ bitmap_arr = mkBitmapArray bsize bitmap
+ bitmap_barr = case bitmap_arr of UArray _lo _hi barr -> barr
+
+ let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits
+ final_ptrs final_itbls
+
+ -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
+ -- objects, since they might get run too early. Disable this until
+ -- we figure out what to do.
+ -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
+
+ return ul_bco
+ where
+ zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
+ free ptr
+
+mkBitmapArray :: Int -> [StgWord] -> UArray Int StgWord
+mkBitmapArray bsize bitmap
+ = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
+
+mkInstrArray :: Int -> [Word16] -> UArray Int Word16
+mkInstrArray n_insns asm_insns
+ = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
+
+-- instrs nonptrs ptrs itbls
+type AsmState = (SizedSeq Word16,
+ SizedSeq (Either Word FastString),
+ SizedSeq BCOPtr,
+ SizedSeq Name)
+
+data SizedSeq a = SizedSeq !Int [a]
+emptySS = SizedSeq 0 []
+
+-- Why are these two monadic???
+addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
+addListToSS (SizedSeq n r_xs) xs
+ = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
+
+ssElts :: SizedSeq a -> [a]
+ssElts (SizedSeq n r_xs) = reverse r_xs
+
+sizeSS :: SizedSeq a -> Int
+sizeSS (SizedSeq n r_xs) = n
+
+-- Bring in all the bci_ bytecode constants.
+#include "Bytecodes.h"
+
+-- This is where all the action is (pass 2 of the assembler)
+mkBits :: (Int -> Int) -- label finder
+ -> AsmState
+ -> [BCInstr] -- instructions (in)
+ -> IO AsmState
+
+mkBits findLabel st proto_insns
+ = foldM doInstr st proto_insns
+ where
+ doInstr :: AsmState -> BCInstr -> IO AsmState
+ doInstr st i
+ = case i of
+ STKCHECK n -> instr2 st bci_STKCHECK n
+ PUSH_L o1 -> instr2 st bci_PUSH_L o1
+ PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
+ PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
+ PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm)
+ instr2 st2 bci_PUSH_G p
+ PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
+ instr2 st2 bci_PUSH_G p
+ PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 bci_PUSH_G p
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 bci_PUSH_ALTS p
+ PUSH_ALTS_UNLIFTED proto pk -> do
+ ul_bco <- assembleBCO proto
+ (p, st2) <- ptr st (BCOPtrBCO ul_bco)
+ instr2 st2 (push_alts pk) p
+ PUSH_UBX (Left lit) nws
+ -> do (np, st2) <- literal st lit
+ instr3 st2 bci_PUSH_UBX np nws
+ PUSH_UBX (Right aa) nws
+ -> do (np, st2) <- addr st aa
+ instr3 st2 bci_PUSH_UBX np nws
+
+ PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N
+ PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V
+ PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F
+ PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D
+ PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L
+ PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P
+ PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP
+ PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP
+ PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP
+ PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP
+ PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP
+
+ SLIDE n by -> instr3 st bci_SLIDE n by
+ ALLOC_AP n -> instr2 st bci_ALLOC_AP n
+ ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n
+ MKAP off sz -> instr3 st bci_MKAP off sz
+ MKPAP off sz -> instr3 st bci_MKPAP off sz
+ UNPACK n -> instr2 st bci_UNPACK n
+ PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
+ instr3 st2 bci_PACK itbl_no sz
+ LABEL lab -> return st
+ TESTLT_I i l -> do (np, st2) <- int st i
+ instr3 st2 bci_TESTLT_I np (findLabel l)
+ TESTEQ_I i l -> do (np, st2) <- int st i
+ instr3 st2 bci_TESTEQ_I np (findLabel l)
+ TESTLT_F f l -> do (np, st2) <- float st f
+ instr3 st2 bci_TESTLT_F np (findLabel l)
+ TESTEQ_F f l -> do (np, st2) <- float st f
+ instr3 st2 bci_TESTEQ_F np (findLabel l)
+ TESTLT_D d l -> do (np, st2) <- double st d
+ instr3 st2 bci_TESTLT_D np (findLabel l)
+ TESTEQ_D d l -> do (np, st2) <- double st d
+ instr3 st2 bci_TESTEQ_D np (findLabel l)
+ TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l)
+ TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l)
+ CASEFAIL -> instr1 st bci_CASEFAIL
+ SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
+ JMP l -> instr2 st bci_JMP (findLabel l)
+ ENTER -> instr1 st bci_ENTER
+ RETURN -> instr1 st bci_RETURN
+ RETURN_UBX rep -> instr1 st (return_ubx rep)
+ CCALL off m_addr -> do (np, st2) <- addr st m_addr
+ instr3 st2 bci_CCALL off np
+
+ i2s :: Int -> Word16
+ i2s = fromIntegral
+
+ instr1 (st_i0,st_l0,st_p0,st_I0) i1
+ = do st_i1 <- addToSS st_i0 i1
+ return (st_i1,st_l0,st_p0,st_I0)
+
+ instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ return (st_i2,st_l0,st_p0,st_I0)
+
+ instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ st_i3 <- addToSS st_i2 (i2s i3)
+ return (st_i3,st_l0,st_p0,st_I0)
+
+ instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
+ = do st_i1 <- addToSS st_i0 (i2s i1)
+ st_i2 <- addToSS st_i1 (i2s i2)
+ st_i3 <- addToSS st_i2 (i2s i3)
+ st_i4 <- addToSS st_i3 (i2s i4)
+ return (st_i4,st_l0,st_p0,st_I0)
+
+ float (st_i0,st_l0,st_p0,st_I0) f
+ = do let ws = mkLitF f
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ double (st_i0,st_l0,st_p0,st_I0) d
+ = do let ws = mkLitD d
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ int (st_i0,st_l0,st_p0,st_I0) i
+ = do let ws = mkLitI i
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ int64 (st_i0,st_l0,st_p0,st_I0) i
+ = do let ws = mkLitI64 i
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ addr (st_i0,st_l0,st_p0,st_I0) a
+ = do let ws = mkLitPtr a
+ st_l1 <- addListToSS st_l0 (map Left ws)
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ litlabel (st_i0,st_l0,st_p0,st_I0) fs
+ = do st_l1 <- addListToSS st_l0 [Right fs]
+ return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
+
+ ptr (st_i0,st_l0,st_p0,st_I0) p
+ = do st_p1 <- addToSS st_p0 p
+ return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
+
+ itbl (st_i0,st_l0,st_p0,st_I0) dcon
+ = do st_I1 <- addToSS st_I0 (getName dcon)
+ return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
+
+ literal st (MachLabel fs _) = litlabel st fs
+ literal st (MachWord w) = int st (fromIntegral w)
+ literal st (MachInt j) = int st (fromIntegral j)
+ literal st (MachFloat r) = float st (fromRational r)
+ literal st (MachDouble r) = double st (fromRational r)
+ literal st (MachChar c) = int st (ord c)
+ literal st (MachInt64 ii) = int64 st (fromIntegral ii)
+ literal st (MachWord64 ii) = int64 st (fromIntegral ii)
+ literal st other = pprPanic "ByteCodeLink.literal" (ppr other)
+
+
+push_alts NonPtrArg = bci_PUSH_ALTS_N
+push_alts FloatArg = bci_PUSH_ALTS_F
+push_alts DoubleArg = bci_PUSH_ALTS_D
+push_alts VoidArg = bci_PUSH_ALTS_V
+push_alts LongArg = bci_PUSH_ALTS_L
+push_alts PtrArg = bci_PUSH_ALTS_P
+
+return_ubx NonPtrArg = bci_RETURN_N
+return_ubx FloatArg = bci_RETURN_F
+return_ubx DoubleArg = bci_RETURN_D
+return_ubx VoidArg = bci_RETURN_V
+return_ubx LongArg = bci_RETURN_L
+return_ubx PtrArg = bci_RETURN_P
+
+
+-- The size in 16-bit entities of an instruction.
+instrSize16s :: BCInstr -> Int
+instrSize16s instr
+ = case instr of
+ STKCHECK{} -> 2
+ PUSH_L{} -> 2
+ PUSH_LL{} -> 3
+ PUSH_LLL{} -> 4
+ PUSH_G{} -> 2
+ PUSH_PRIMOP{} -> 2
+ PUSH_BCO{} -> 2
+ PUSH_ALTS{} -> 2
+ PUSH_ALTS_UNLIFTED{} -> 2
+ PUSH_UBX{} -> 3
+ PUSH_APPLY_N{} -> 1
+ PUSH_APPLY_V{} -> 1
+ PUSH_APPLY_F{} -> 1
+ PUSH_APPLY_D{} -> 1
+ PUSH_APPLY_L{} -> 1
+ PUSH_APPLY_P{} -> 1
+ PUSH_APPLY_PP{} -> 1
+ PUSH_APPLY_PPP{} -> 1
+ PUSH_APPLY_PPPP{} -> 1
+ PUSH_APPLY_PPPPP{} -> 1
+ PUSH_APPLY_PPPPPP{} -> 1
+ SLIDE{} -> 3
+ ALLOC_AP{} -> 2
+ ALLOC_PAP{} -> 3
+ MKAP{} -> 3
+ MKPAP{} -> 3
+ UNPACK{} -> 2
+ PACK{} -> 3
+ LABEL{} -> 0 -- !!
+ TESTLT_I{} -> 3
+ TESTEQ_I{} -> 3
+ TESTLT_F{} -> 3
+ TESTEQ_F{} -> 3
+ TESTLT_D{} -> 3
+ TESTEQ_D{} -> 3
+ TESTLT_P{} -> 3
+ TESTEQ_P{} -> 3
+ JMP{} -> 2
+ CASEFAIL{} -> 1
+ ENTER{} -> 1
+ RETURN{} -> 1
+ RETURN_UBX{} -> 1
+ CCALL{} -> 3
+ SWIZZLE{} -> 3
+
+-- Make lists of host-sized words for literals, so that when the
+-- words are placed in memory at increasing addresses, the
+-- bit pattern is correct for the host's word size and endianness.
+mkLitI :: Int -> [Word]
+mkLitF :: Float -> [Word]
+mkLitD :: Double -> [Word]
+mkLitPtr :: Ptr () -> [Word]
+mkLitI64 :: Int64 -> [Word]
+
+mkLitF f
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 f
+ f_arr <- castSTUArray arr
+ w0 <- readArray f_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitD d
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 d
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ w1 <- readArray d_arr 1
+ return [w0 :: Word, w1]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 d
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitI64 ii
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newArray_ ((0::Int),1)
+ writeArray arr 0 ii
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ w1 <- readArray d_arr 1
+ return [w0 :: Word,w1]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 ii
+ d_arr <- castSTUArray arr
+ w0 <- readArray d_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitI i
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 i
+ i_arr <- castSTUArray arr
+ w0 <- readArray i_arr 0
+ return [w0 :: Word]
+ )
+
+mkLitPtr a
+ = runST (do
+ arr <- newArray_ ((0::Int),0)
+ writeArray arr 0 a
+ a_arr <- castSTUArray arr
+ w0 <- readArray a_arr 0
+ return [w0 :: Word]
+ )
+
+iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int)
+\end{code}
diff --git a/compiler/ghci/ByteCodeFFI.lhs b/compiler/ghci/ByteCodeFFI.lhs
new file mode 100644
index 0000000000..61e70d64e4
--- /dev/null
+++ b/compiler/ghci/ByteCodeFFI.lhs
@@ -0,0 +1,832 @@
+%
+% (c) The University of Glasgow 2001
+%
+\section[ByteCodeGen]{Generate machine-code sequences for foreign import}
+
+\begin{code}
+module ByteCodeFFI ( mkMarshalCode, moan64 ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import SMRep ( CgRep(..), cgRepSizeW )
+import ForeignCall ( CCallConv(..) )
+import Panic
+
+-- DON'T remove apparently unused imports here ..
+-- there is ifdeffery below
+import Control.Exception ( throwDyn )
+import DATA_BITS ( Bits(..), shiftR, shiftL )
+import Foreign ( newArray )
+import Data.List ( mapAccumL )
+
+import DATA_WORD ( Word8, Word32 )
+import Foreign ( Ptr )
+import System.IO.Unsafe ( unsafePerformIO )
+import IO ( hPutStrLn, stderr )
+import Debug.Trace ( trace )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The platform-dependent marshall-code-generator.}
+%* *
+%************************************************************************
+
+\begin{code}
+
+moan64 :: String -> SDoc -> a
+moan64 msg pp_rep
+ = unsafePerformIO (
+ hPutStrLn stderr (
+ "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++
+ "code properly yet. You can work around this for the time being\n" ++
+ "by compiling this module and all those it imports to object code,\n" ++
+ "and re-starting your GHCi session. The panic below contains information,\n" ++
+ "intended for the GHC implementors, about the exact place where GHC gave up.\n"
+ )
+ )
+ `seq`
+ pprPanic msg pp_rep
+
+
+-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
+#include "nativeGen/NCG.h"
+
+{-
+Make a piece of code which expects to see the Haskell stack
+looking like this. It is given a pointer to the lowest word in
+the stack -- presumably the tag of the placeholder.
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+
+We cope with both ccall and stdcall for the C fn. However, this code
+itself expects only to be called using the ccall convention -- that is,
+we don't clear our own (single) arg off the C stack.
+-}
+mkMarshalCode :: CCallConv
+ -> (Int, CgRep) -> Int -> [(Int, CgRep)]
+ -> IO (Ptr Word8)
+mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
+ = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
+ addr_offW arg_offs_n_reps
+ in trace (show bytes) $ Foreign.newArray bytes
+
+
+
+
+mkMarshalCode_wrk :: CCallConv
+ -> (Int, CgRep) -> Int -> [(Int, CgRep)]
+ -> [Word8]
+
+mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
+
+#if i386_TARGET_ARCH
+
+ = let -- Don't change this without first consulting Intel Corp :-)
+ bytes_per_word = 4
+
+ offsets_to_pushW
+ = concat
+ [ -- reversed because x86 is little-endian
+ reverse [a_offW .. a_offW + cgRepSizeW a_rep - 1]
+
+ -- reversed because args are pushed L -> R onto C stack
+ | (a_offW, a_rep) <- reverse arg_offs_n_reps
+ ]
+
+ arguments_size = bytes_per_word * length offsets_to_pushW
+#if darwin_TARGET_OS
+ -- Darwin: align stack frame size to a multiple of 16 bytes
+ stack_frame_size = (arguments_size + 15) .&. complement 15
+ stack_frame_pad = stack_frame_size - arguments_size
+#else
+ stack_frame_size = arguments_size
+#endif
+
+ -- some helpers to assemble x86 insns.
+ movl_offespmem_esi offB -- movl offB(%esp), %esi
+ = [0x8B, 0xB4, 0x24] ++ lit32 offB
+ movl_offesimem_ecx offB -- movl offB(%esi), %ecx
+ = [0x8B, 0x8E] ++ lit32 offB
+ save_regs -- pushl all intregs except %esp
+ = [0x50, 0x53, 0x51, 0x52, 0x56, 0x57, 0x55]
+ restore_regs -- popl ditto
+ = [0x5D, 0x5F, 0x5E, 0x5A, 0x59, 0x5B, 0x58]
+ pushl_ecx -- pushl %ecx
+ = [0x51]
+ call_star_ecx -- call * %ecx
+ = [0xFF, 0xD1]
+ add_lit_esp lit -- addl $lit, %esp
+ = [0x81, 0xC4] ++ lit32 lit
+ movl_eax_offesimem offB -- movl %eax, offB(%esi)
+ = [0x89, 0x86] ++ lit32 offB
+ movl_edx_offesimem offB -- movl %edx, offB(%esi)
+ = [0x89, 0x96] ++ lit32 offB
+ ret -- ret
+ = [0xC3]
+ fstpl_offesimem offB -- fstpl offB(%esi)
+ = [0xDD, 0x9E] ++ lit32 offB
+ fstps_offesimem offB -- fstps offB(%esi)
+ = [0xD9, 0x9E] ++ lit32 offB
+ {-
+ 2 0000 8BB42478 movl 0x12345678(%esp), %esi
+ 2 563412
+ 3 0007 8B8E7856 movl 0x12345678(%esi), %ecx
+ 3 3412
+ 4
+ 5 000d 50535152 pushl %eax ; pushl %ebx ; pushl %ecx ; pushl %edx
+ 6 0011 565755 pushl %esi ; pushl %edi ; pushl %ebp
+ 7
+ 8 0014 5D5F5E popl %ebp ; popl %edi ; popl %esi
+ 9 0017 5A595B58 popl %edx ; popl %ecx ; popl %ebx ; popl %eax
+ 10
+ 11 001b 51 pushl %ecx
+ 12 001c FFD1 call * %ecx
+ 13
+ 14 001e 81C47856 addl $0x12345678, %esp
+ 14 3412
+ 15 0024 89867856 movl %eax, 0x12345678(%esi)
+ 15 3412
+ 16 002a 89967856 movl %edx, 0x12345678(%esi)
+ 16 3412
+ 17
+ 18 0030 DD967856 fstl 0x12345678(%esi)
+ 18 3412
+ 19 0036 DD9E7856 fstpl 0x12345678(%esi)
+ 19 3412
+ 20 003c D9967856 fsts 0x12345678(%esi)
+ 20 3412
+ 21 0042 D99E7856 fstps 0x12345678(%esi)
+ 18
+ 19 0030 C3 ret
+ 20
+
+ -}
+
+ in
+ --trace (show (map fst arg_offs_n_reps))
+ (
+ {- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is
+ arg passed from the interpreter.
+
+ Push all callee saved regs. Push all of them anyway ...
+ pushl %eax
+ pushl %ebx
+ pushl %ecx
+ pushl %edx
+ pushl %esi
+ pushl %edi
+ pushl %ebp
+ -}
+ save_regs
+
+ {- Now 28+0(%esp) is RA and 28+4(%esp) is the arg (the H stack ptr).
+ We'll use %esi as a temporary to point at the H stack, and
+ %ecx as a temporary to copy via.
+
+ movl 28+4(%esp), %esi
+ -}
+ ++ movl_offespmem_esi 32
+
+#if darwin_TARGET_OS
+ {- On Darwin, add some padding so that the stack stays aligned. -}
+ ++ (if stack_frame_pad /= 0
+ then add_lit_esp (-stack_frame_pad)
+ else [])
+#endif
+
+ {- For each arg in args_offs_n_reps, examine the associated
+ CgRep to determine how many words there are. This gives a
+ bunch of offsets on the H stack to copy to the C stack:
+
+ movl off1(%esi), %ecx
+ pushl %ecx
+ -}
+ ++ concatMap (\offW -> movl_offesimem_ecx (bytes_per_word * offW)
+ ++ pushl_ecx)
+ offsets_to_pushW
+
+ {- Get the addr to call into %ecx, bearing in mind that there's
+ an Addr# tag at the indicated location, and do the call:
+
+ movl 4*(1 /*tag*/ +addr_offW)(%esi), %ecx
+ call * %ecx
+ -}
+ ++ movl_offesimem_ecx (bytes_per_word * addr_offW)
+ ++ call_star_ecx
+
+ {- Nuke the args just pushed and re-establish %esi at the
+ H-stack ptr:
+
+ addl $4*number_of_args_pushed, %esp (ccall only)
+ movl 28+4(%esp), %esi
+ -}
+ ++ (if cconv /= StdCallConv
+ then add_lit_esp stack_frame_size
+ else [])
+ ++ movl_offespmem_esi 32
+
+ {- Depending on what the return type is, get the result
+ from %eax or %edx:%eax or %st(0).
+
+ movl %eax, 4(%esi) -- assuming tagged result
+ or
+ movl %edx, 4(%esi)
+ movl %eax, 8(%esi)
+ or
+ fstpl 4(%esi)
+ or
+ fstps 4(%esi)
+ -}
+ ++ let i32 = movl_eax_offesimem 0
+ i64 = movl_eax_offesimem 0 ++ movl_edx_offesimem 4
+ f32 = fstps_offesimem 0
+ f64 = fstpl_offesimem 0
+ in
+ case r_rep of
+ NonPtrArg -> i32
+ DoubleArg -> f64
+ FloatArg -> f32
+ -- LongArg -> i64
+ VoidArg -> []
+ other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)"
+ (ppr r_rep)
+
+ {- Restore all the pushed regs and go home.
+
+ pushl %ebp
+ pushl %edi
+ pushl %esi
+ pushl %edx
+ pushl %ecx
+ pushl %ebx
+ pushl %eax
+
+ ret
+ -}
+ ++ restore_regs
+ ++ ret
+ )
+
+#elif x86_64_TARGET_ARCH
+
+ =
+ -- the address of the H stack is in %rdi. We need to move it out, so
+ -- we can use %rdi as an arg reg for the following call:
+ pushq_rbp ++
+ movq_rdi_rbp ++
+
+ -- ####### load / push the args
+
+ let
+ (stack_args, fregs_unused, reg_loads) =
+ load_arg_regs arg_offs_n_reps int_loads float_loads []
+
+ tot_arg_size = bytes_per_word * length stack_args
+
+ -- On entry to the called function, %rsp should be aligned
+ -- on a 16-byte boundary +8 (i.e. the first stack arg after
+ -- the return address is 16-byte aligned). In STG land
+ -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just
+ -- need to make sure we push a multiple of 16-bytes of args,
+ -- plus the return address, to get the correct alignment.
+ (real_size, adjust_rsp)
+ | tot_arg_size `rem` 16 == 0 = (tot_arg_size, [])
+ | otherwise = (tot_arg_size + 8, subq_lit_rsp 8)
+
+ (stack_pushes, stack_words) =
+ push_args stack_args [] 0
+
+ -- we need to know the number of SSE regs used in the call, see later
+ n_sse_regs_used = length float_loads - length fregs_unused
+ in
+ concat reg_loads
+ ++ adjust_rsp
+ ++ concat stack_pushes -- push in reverse order
+
+ -- ####### make the call
+
+ -- use %r10 to make the call, because we don't have to save it.
+ -- movq 8*addr_offW(%rbp), %r10
+ ++ movq_rbpoff_r10 (bytes_per_word * addr_offW)
+
+ -- The x86_64 ABI requires us to set %al to the number of SSE
+ -- registers that contain arguments, if the called routine
+ -- is a varargs function. We don't know whether it's a
+ -- varargs function or not, so we have to assume it is.
+ --
+ -- It's not safe to omit this assignment, even if the number
+ -- of SSE regs in use is zero. If %al is larger than 8
+ -- on entry to a varargs function, seg faults ensue.
+ ++ movq_lit_rax n_sse_regs_used
+ ++ call_star_r10
+
+ -- pop the args from the stack, only in ccall mode
+ -- (in stdcall the callee does it).
+ ++ (if cconv /= StdCallConv
+ then addq_lit_rsp real_size
+ else [])
+
+ -- ####### place the result in the right place and return
+
+ ++ assign_result
+ ++ popq_rbp
+ ++ ret
+
+ where
+ bytes_per_word = 8
+
+ -- int arg regs: rdi,rsi,rdx,rcx,r8,r9
+ -- flt arg regs: xmm0..xmm7
+ int_loads = [ movq_rbpoff_rdi, movq_rbpoff_rsi, movq_rbpoff_rdx,
+ movq_rbpoff_rcx, movq_rbpoff_r8, movq_rbpoff_r9 ]
+ float_loads = [ (mov_f32_rbpoff_xmm n, mov_f64_rbpoff_xmm n) | n <- [0..7] ]
+
+ load_arg_regs args [] [] code = (args, [], code)
+ load_arg_regs [] iregs fregs code = ([], fregs, code)
+ load_arg_regs ((off,rep):args) iregs fregs code
+ | FloatArg <- rep, ((mov_f32,_):frest) <- fregs =
+ load_arg_regs args iregs frest (mov_f32 (bytes_per_word * off) : code)
+ | DoubleArg <- rep, ((_,mov_f64):frest) <- fregs =
+ load_arg_regs args iregs frest (mov_f64 (bytes_per_word * off) : code)
+ | (mov_reg:irest) <- iregs =
+ load_arg_regs args irest fregs (mov_reg (bytes_per_word * off) : code)
+ | otherwise =
+ push_this_arg
+ where
+ push_this_arg = ((off,rep):args',fregs', code')
+ where (args',fregs',code') = load_arg_regs args iregs fregs code
+
+ push_args [] code pushed_words = (code, pushed_words)
+ push_args ((off,rep):args) code pushed_words
+ | FloatArg <- rep =
+ push_args args (push_f32_rbpoff (bytes_per_word * off) : code)
+ (pushed_words+1)
+ | DoubleArg <- rep =
+ push_args args (push_f64_rbpoff (bytes_per_word * off) : code)
+ (pushed_words+1)
+ | otherwise =
+ push_args args (pushq_rbpoff (bytes_per_word * off) : code)
+ (pushed_words+1)
+
+
+ assign_result =
+ case r_rep of
+ DoubleArg -> f64
+ FloatArg -> f32
+ VoidArg -> []
+ _other -> i64
+ where
+ i64 = movq_rax_rbpoff 0
+ f32 = mov_f32_xmm0_rbpoff 0
+ f64 = mov_f64_xmm0_rbpoff 0
+
+-- ######### x86_64 machine code:
+
+-- 0: 48 89 fd mov %rdi,%rbp
+-- 3: 48 8b bd 78 56 34 12 mov 0x12345678(%rbp),%rdi
+-- a: 48 8b b5 78 56 34 12 mov 0x12345678(%rbp),%rsi
+-- 11: 48 8b 95 78 56 34 12 mov 0x12345678(%rbp),%rdx
+-- 18: 48 8b 8d 78 56 34 12 mov 0x12345678(%rbp),%rcx
+-- 1f: 4c 8b 85 78 56 34 12 mov 0x12345678(%rbp),%r8
+-- 26: 4c 8b 8d 78 56 34 12 mov 0x12345678(%rbp),%r9
+-- 2d: 4c 8b 95 78 56 34 12 mov 0x12345678(%rbp),%r10
+-- 34: 48 c7 c0 78 56 34 12 mov $0x12345678,%rax
+-- 3b: 48 89 85 78 56 34 12 mov %rax,0x12345678(%rbp)
+-- 42: f3 0f 10 85 78 56 34 12 movss 0x12345678(%rbp),%xmm0
+-- 4a: f2 0f 10 85 78 56 34 12 movsd 0x12345678(%rbp),%xmm0
+-- 52: f3 0f 11 85 78 56 34 12 movss %xmm0,0x12345678(%rbp)
+-- 5a: f2 0f 11 85 78 56 34 12 movsd %xmm0,0x12345678(%rbp)
+-- 62: ff b5 78 56 34 12 pushq 0x12345678(%rbp)
+-- 68: f3 44 0f 11 04 24 movss %xmm8,(%rsp)
+-- 6e: f2 44 0f 11 04 24 movsd %xmm8,(%rsp)
+-- 74: 48 81 ec 78 56 34 12 sub $0x12345678,%rsp
+-- 7b: 48 81 c4 78 56 34 12 add $0x12345678,%rsp
+-- 82: 41 ff d2 callq *%r10
+-- 85: c3 retq
+
+ movq_rdi_rbp = [0x48,0x89,0xfd]
+ movq_rbpoff_rdi off = [0x48, 0x8b, 0xbd] ++ lit32 off
+ movq_rbpoff_rsi off = [0x48, 0x8b, 0xb5] ++ lit32 off
+ movq_rbpoff_rdx off = [0x48, 0x8b, 0x95] ++ lit32 off
+ movq_rbpoff_rcx off = [0x48, 0x8b, 0x8d] ++ lit32 off
+ movq_rbpoff_r8 off = [0x4c, 0x8b, 0x85] ++ lit32 off
+ movq_rbpoff_r9 off = [0x4c, 0x8b, 0x8d] ++ lit32 off
+ movq_rbpoff_r10 off = [0x4c, 0x8b, 0x95] ++ lit32 off
+ movq_lit_rax lit = [0x48, 0xc7, 0xc0] ++ lit32 lit
+ movq_rax_rbpoff off = [0x48, 0x89, 0x85] ++ lit32 off
+ mov_f32_rbpoff_xmm n off = [0xf3, 0x0f, 0x10, 0x85 + n`shiftL`3] ++ lit32 off
+ mov_f64_rbpoff_xmm n off = [0xf2, 0x0f, 0x10, 0x85 + n`shiftL`3] ++ lit32 off
+ mov_f32_xmm0_rbpoff off = [0xf3, 0x0f, 0x11, 0x85] ++ lit32 off
+ mov_f64_xmm0_rbpoff off = [0xf2, 0x0f, 0x11, 0x85] ++ lit32 off
+ pushq_rbpoff off = [0xff, 0xb5] ++ lit32 off
+ push_f32_rbpoff off =
+ mov_f32_rbpoff_xmm 8 off ++ -- movss off(%rbp), %xmm8
+ [0xf3, 0x44, 0x0f, 0x11, 0x04, 0x24] ++ -- movss %xmm8, (%rsp)
+ subq_lit_rsp 8 -- subq $8, %rsp
+ push_f64_rbpoff off =
+ mov_f64_rbpoff_xmm 8 off ++ -- movsd off(%rbp), %xmm8
+ [0xf2, 0x44, 0x0f, 0x11, 0x04, 0x24] ++ -- movsd %xmm8, (%rsp)
+ subq_lit_rsp 8 -- subq $8, %rsp
+ subq_lit_rsp lit = [0x48, 0x81, 0xec] ++ lit32 lit
+ addq_lit_rsp lit = [0x48, 0x81, 0xc4] ++ lit32 lit
+ call_star_r10 = [0x41,0xff,0xd2]
+ ret = [0xc3]
+ pushq_rbp = [0x55]
+ popq_rbp = [0x5d]
+
+#elif sparc_TARGET_ARCH
+
+ = let -- At least for sparc V8
+ bytes_per_word = 4
+
+ -- speaks for itself
+ w32_to_w8s_bigEndian :: Word32 -> [Word8]
+ w32_to_w8s_bigEndian w
+ = [fromIntegral (0xFF .&. (w `shiftR` 24)),
+ fromIntegral (0xFF .&. (w `shiftR` 16)),
+ fromIntegral (0xFF .&. (w `shiftR` 8)),
+ fromIntegral (0xFF .&. w)]
+
+ offsets_to_pushW
+ = concat
+ [ [a_offW .. a_offW + cgRepSizeW a_rep - 1]
+
+ | (a_offW, a_rep) <- arg_offs_n_reps
+ ]
+
+ total_argWs = length offsets_to_pushW
+ argWs_on_stack = if total_argWs > 6 then total_argWs - 6
+ else 0
+
+ -- The stack pointer must be kept 8-byte aligned, which means
+ -- we need to calculate this quantity too
+ argWs_on_stack_ROUNDED_UP
+ | odd argWs_on_stack = 1 + argWs_on_stack
+ | otherwise = argWs_on_stack
+
+ -- some helpers to assemble sparc insns.
+ -- REGS
+ iReg, oReg, gReg, fReg :: Int -> Word32
+ iReg = fromIntegral . (+ 24)
+ oReg = fromIntegral . (+ 8)
+ gReg = fromIntegral . (+ 0)
+ fReg = fromIntegral
+
+ sp = oReg 6
+ i0 = iReg 0
+ i7 = iReg 7
+ o0 = oReg 0
+ o1 = oReg 1
+ o7 = oReg 7
+ g0 = gReg 0
+ g1 = gReg 1
+ f0 = fReg 0
+ f1 = fReg 1
+
+ -- INSN templates
+ insn_r_r_i :: Word32 -> Word32 -> Word32 -> Int -> Word32
+ insn_r_r_i op3 rs1 rd imm13
+ = (3 `shiftL` 30)
+ .|. (rs1 `shiftL` 25)
+ .|. (op3 `shiftL` 19)
+ .|. (rd `shiftL` 14)
+ .|. (1 `shiftL` 13)
+ .|. mkSimm13 imm13
+
+ insn_r_i_r :: Word32 -> Word32 -> Int -> Word32 -> Word32
+ insn_r_i_r op3 rs1 imm13 rd
+ = (2 `shiftL` 30)
+ .|. (rd `shiftL` 25)
+ .|. (op3 `shiftL` 19)
+ .|. (rs1 `shiftL` 14)
+ .|. (1 `shiftL` 13)
+ .|. mkSimm13 imm13
+
+ mkSimm13 :: Int -> Word32
+ mkSimm13 imm13
+ = let imm13w = (fromIntegral imm13) :: Word32
+ in imm13w .&. 0x1FFF
+
+ -- REAL (non-synthetic) insns
+ -- or %rs1, %rs2, %rd
+ mkOR :: Word32 -> Word32 -> Word32 -> Word32
+ mkOR rs1 rs2 rd
+ = (2 `shiftL` 30)
+ .|. (rd `shiftL` 25)
+ .|. (op3_OR `shiftL` 19)
+ .|. (rs1 `shiftL` 14)
+ .|. (0 `shiftL` 13)
+ .|. rs2
+ where op3_OR = 2 :: Word32
+
+ -- ld(int) [%rs + imm13], %rd
+ mkLD rs1 imm13 rd = insn_r_r_i 0x00{-op3_LD-} rd rs1 imm13
+
+ -- st(int) %rs, [%rd + imm13]
+ mkST = insn_r_r_i 0x04 -- op3_ST
+
+ -- st(float) %rs, [%rd + imm13]
+ mkSTF = insn_r_r_i 0x24 -- op3_STF
+
+ -- jmpl %rs + imm13, %rd
+ mkJMPL = insn_r_i_r 0x38 -- op3_JMPL
+
+ -- save %rs + imm13, %rd
+ mkSAVE = insn_r_i_r 0x3C -- op3_SAVE
+
+ -- restore %rs + imm13, %rd
+ mkRESTORE = insn_r_i_r 0x3D -- op3_RESTORE
+
+ -- SYNTHETIC insns
+ mkNOP = mkOR g0 g0 g0
+ mkCALL reg = mkJMPL reg 0 o7
+ mkRET = mkJMPL i7 8 g0
+ mkRESTORE_TRIVIAL = mkRESTORE g0 0 g0
+ in
+ --trace (show (map fst arg_offs_n_reps))
+ concatMap w32_to_w8s_bigEndian (
+
+ {- On entry, %o0 is the arg passed from the interpreter. After
+ the initial save insn, it will be in %i0. Studying the sparc
+ docs one would have thought that the minimum frame size is 92
+ bytes, but gcc always uses at least 112, and indeed there are
+ segfaults a-plenty with 92. So I use 112 here as well. I
+ don't understand why, tho.
+ -}
+ [mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp]
+
+ {- For each arg in args_offs_n_reps, examine the associated
+ CgRep to determine how many words there are. This gives a
+ bunch of offsets on the H stack. Move the first 6 words into
+ %o0 .. %o5 and the rest on the stack, starting at [%sp+92].
+ Use %g1 as a temp.
+ -}
+ ++ let doArgW (offW, wordNo)
+ | wordNo < 6
+ = [mkLD i0 (bytes_per_word * offW) (oReg wordNo)]
+ | otherwise
+ = [mkLD i0 (bytes_per_word * offW) g1,
+ mkST g1 sp (92 + bytes_per_word * (wordNo - 6))]
+ in
+ concatMap doArgW (zip offsets_to_pushW [0 ..])
+
+ {- Get the addr to call into %g1, bearing in mind that there's
+ an Addr# tag at the indicated location, and do the call:
+
+ ld [4*(1 /*tag*/ +addr_offW) + %i0], %g1
+ call %g1
+ -}
+ ++ [mkLD i0 (bytes_per_word * addr_offW) g1,
+ mkCALL g1,
+ mkNOP]
+
+ {- Depending on what the return type is, get the result
+ from %o0 or %o1:%o0 or %f0 or %f1:%f0.
+
+ st %o0, [%i0 + 4] -- 32 bit int
+ or
+ st %o0, [%i0 + 4] -- 64 bit int
+ st %o1, [%i0 + 8] -- or the other way round?
+ or
+ st %f0, [%i0 + 4] -- 32 bit float
+ or
+ st %f0, [%i0 + 4] -- 64 bit float
+ st %f1, [%i0 + 8] -- or the other way round?
+
+ -}
+ ++ let i32 = [mkST o0 i0 0]
+ i64 = [mkST o0 i0 0, mkST o1 i0 4]
+ f32 = [mkSTF f0 i0 0]
+ f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4]
+ in
+ case r_rep of
+ NonPtrArg -> i32
+ DoubleArg -> f64
+ FloatArg -> f32
+ VoidArg -> []
+ other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)"
+ (ppr r_rep)
+
+ ++ [mkRET,
+ mkRESTORE_TRIVIAL] -- this is in the delay slot of the RET
+ )
+#elif powerpc_TARGET_ARCH && darwin_TARGET_OS
+
+ = let
+ bytes_per_word = 4
+
+ -- speaks for itself
+ w32_to_w8s_bigEndian :: Word32 -> [Word8]
+ w32_to_w8s_bigEndian w
+ = [fromIntegral (0xFF .&. (w `shiftR` 24)),
+ fromIntegral (0xFF .&. (w `shiftR` 16)),
+ fromIntegral (0xFF .&. (w `shiftR` 8)),
+ fromIntegral (0xFF .&. w)]
+
+ -- addr and result bits offsetsW
+ a_off = addr_offW * bytes_per_word
+ result_off = r_offW * bytes_per_word
+
+ linkageArea = 24
+ parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word
+ | (_, a_rep) <- arg_offs_n_reps ]
+ savedRegisterArea = 4
+ frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea)
+ padTo16 x = case x `mod` 16 of
+ 0 -> x
+ y -> x - y + 16
+
+ pass_parameters [] _ _ = []
+ pass_parameters ((a_offW, a_rep):args) nextFPR offsetW =
+ let
+ haskellArgOffset = a_offW * bytes_per_word
+ offsetW' = offsetW + cgRepSizeW a_rep
+
+ pass_word w
+ | offsetW + w < 8 =
+ [0x801f0000 -- lwz rX, src(r31)
+ .|. (fromIntegral src .&. 0xFFFF)
+ .|. (fromIntegral (offsetW+w+3) `shiftL` 21)]
+ | otherwise =
+ [0x801f0000 -- lwz r0, src(r31)
+ .|. (fromIntegral src .&. 0xFFFF),
+ 0x90010000 -- stw r0, dst(r1)
+ .|. (fromIntegral dst .&. 0xFFFF)]
+ where
+ src = haskellArgOffset + w*bytes_per_word
+ dst = linkageArea + (offsetW+w) * bytes_per_word
+ in
+ case a_rep of
+ FloatArg | nextFPR < 14 ->
+ (0xc01f0000 -- lfs fX, haskellArgOffset(r31)
+ .|. (fromIntegral haskellArgOffset .&. 0xFFFF)
+ .|. (fromIntegral nextFPR `shiftL` 21))
+ : pass_parameters args (nextFPR+1) offsetW'
+ DoubleArg | nextFPR < 14 ->
+ (0xc81f0000 -- lfd fX, haskellArgOffset(r31)
+ .|. (fromIntegral haskellArgOffset .&. 0xFFFF)
+ .|. (fromIntegral nextFPR `shiftL` 21))
+ : pass_parameters args (nextFPR+1) offsetW'
+ _ ->
+ concatMap pass_word [0 .. cgRepSizeW a_rep - 1]
+ ++ pass_parameters args nextFPR offsetW'
+
+ gather_result = case r_rep of
+ VoidArg -> []
+ FloatArg ->
+ [0xd03f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
+ -- stfs f1, result_off(r31)
+ DoubleArg ->
+ [0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
+ -- stfd f1, result_off(r31)
+ _ | cgRepSizeW r_rep == 2 ->
+ [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF),
+ 0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)]
+ -- stw r3, result_off(r31)
+ -- stw r4, result_off+4(r31)
+ _ | cgRepSizeW r_rep == 1 ->
+ [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)]
+ -- stw r3, result_off(r31)
+ in
+ concatMap w32_to_w8s_bigEndian $ [
+ 0x7c0802a6, -- mflr r0
+ 0x93e1fffc, -- stw r31,-4(r1)
+ 0x90010008, -- stw r0,8(r1)
+ 0x94210000 .|. (fromIntegral (-frameSize) .&. 0xFFFF),
+ -- stwu r1, -frameSize(r1)
+ 0x7c7f1b78 -- mr r31, r3
+ ] ++ pass_parameters arg_offs_n_reps 1 0 ++ [
+ 0x819f0000 .|. (fromIntegral a_off .&. 0xFFFF),
+ -- lwz r12, a_off(r31)
+ 0x7d8903a6, -- mtctr r12
+ 0x4e800421 -- bctrl
+ ] ++ gather_result ++ [
+ 0x80210000, -- lwz r1, 0(r1)
+ 0x83e1fffc, -- lwz r31, -4(r1)
+ 0x80010008, -- lwz r0, 8(r1)
+ 0x7c0803a6, -- mtlr r0
+ 0x4e800020 -- blr
+ ]
+
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+
+ -- All offsets here are measured in Words (not bytes). This includes
+ -- arguments to the load/store machine code generators, alignment numbers
+ -- and the final 'framesize' among others.
+
+ = concatMap w32_to_w8s_bigEndian $ [
+ 0x7c0802a6, -- mflr r0
+ 0x93e1fffc, -- stw r31,-4(r1)
+ 0x90010008, -- stw r0,8(r1)
+ 0x94210000 .|. offset (-framesize), -- stwu r1, -frameSize(r1)
+ 0x7c7f1b78 -- mr r31, r3
+ ] ++ pass_parameters ++ -- pass the parameters
+ loadWord 12 addr_offW ++ [ -- lwz r12, a_off(r31)
+ 0x7d8903a6, -- mtctr r12
+ 0x4e800421 -- bctrl
+ ] ++ gather_result ++ [ -- save the return value
+ 0x80210000, -- lwz r1, 0(r1)
+ 0x83e1fffc, -- lwz r31, -4(r1)
+ 0x80010008, -- lwz r0, 8(r1)
+ 0x7c0803a6, -- mtlr r0
+ 0x4e800020 -- blr
+ ]
+
+ where
+ gather_result :: [Word32]
+ gather_result = case r_rep of
+ VoidArg -> []
+ FloatArg -> storeFloat 1 r_offW
+ DoubleArg -> storeDouble 1 r_offW
+ LongArg -> storeLong 3 r_offW
+ _ -> storeWord 3 r_offW
+
+ pass_parameters :: [Word32]
+ pass_parameters = concat params
+
+ -- vector aligned (4 word = 16 bytes) with 8 extra words of buffer space
+ framesize = alignedTo 4 (argsize + 8)
+
+ ((_,_,argsize), params) = mapAccumL loadparam (3,1,2) arg_offs_n_reps
+
+ -- handle one argument, returning machine code and the updated state
+ loadparam :: (Int, Int, Int) -> (Int, CgRep) ->
+ ((Int, Int, Int), [Word32])
+
+ loadparam (gpr, fpr, stack) (ofs, rep) = case rep of
+ FloatArg | fpr <= 8 -> ( (gpr, fpr + 1, stack), loadFloat fpr ofs )
+ FloatArg -> ( (gpr, fpr, stack + 1), stackWord stack ofs )
+
+ DoubleArg | fpr <= 8 -> ( (gpr, fpr + 1, stack), loadDouble fpr ofs )
+ DoubleArg -> ( (gpr, fpr, astack + 2), stackLong astack ofs )
+
+ LongArg | even gpr -> loadparam (gpr + 1, fpr, stack) (ofs, rep)
+ LongArg | gpr <= 9 -> ( (gpr + 2, fpr, stack), loadLong gpr ofs )
+ LongArg -> ( (gpr, fpr, astack + 2), stackLong astack ofs )
+
+ _ | gpr <= 10 -> ( (gpr + 1, fpr, stack), loadWord gpr ofs )
+ _ -> ( (gpr, fpr, stack + 1), stackWord stack ofs )
+ where astack = alignedTo 2 stack
+
+ alignedTo :: Int -> Int -> Int
+ alignedTo alignment x = case x `mod` alignment of
+ 0 -> x
+ y -> x - y + alignment
+
+ -- convenience macros to do multiple-instruction data moves
+ stackWord dst src = loadWord 0 src ++ storeWordC 0 dst
+ stackLong dst src = stackWord dst src ++ stackWord (dst + 1) (src + 1)
+ loadLong dst src = loadWord dst src ++ loadWord (dst + 1) (src + 1)
+ storeLong dst src = storeWord dst src ++ storeWord (dst + 1) (src + 1)
+
+ -- load data from the Haskell stack (relative to r31)
+ loadFloat = loadstoreInstr 0xc01f0000 -- lfs fpr, ofs(r31)
+ loadDouble = loadstoreInstr 0xc81f0000 -- lfd fpr, ofs(r31)
+ loadWord = loadstoreInstr 0x801f0000 -- lwz gpr, ofs(r31)
+
+ -- store data to the Haskell stack (relative to r31)
+ storeFloat = loadstoreInstr 0xd01f0000 -- stfs fpr, ofs(r31)
+ storeDouble = loadstoreInstr 0xd81f0000 -- stfd fpr, ofs(r31)
+ storeWord = loadstoreInstr 0x901f0000 -- stw gpr, ofs(r31)
+
+ -- store data to the C stack (relative to r1)
+ storeWordC = loadstoreInstr 0x90010000 -- stw gpr, ofs(r1)
+
+ -- machine code building blocks
+ loadstoreInstr :: Word32 -> Int -> Int -> [Word32]
+ loadstoreInstr code reg ofs = [ code .|. register reg .|. offset ofs ]
+
+ register :: Int -> Word32
+ register reg = fromIntegral reg `shiftL` 21
+
+ offset :: Int -> Word32
+ offset ofs = fromIntegral (ofs * 4) .&. 0xFFFF
+
+ -- speaks for itself
+ w32_to_w8s_bigEndian :: Word32 -> [Word8]
+ w32_to_w8s_bigEndian w = [fromIntegral (0xFF .&. (w `shiftR` 24)),
+ fromIntegral (0xFF .&. (w `shiftR` 16)),
+ fromIntegral (0xFF .&. (w `shiftR` 8)),
+ fromIntegral (0xFF .&. w)]
+
+#else
+
+ = throwDyn (InstallationError "foreign import is not implemented for GHCi on this platform.")
+
+#endif
+
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+lit32 :: Int -> [Word8]
+lit32 i = let w32 = (fromIntegral i) :: Word32
+ in map (fromIntegral . ( .&. 0xFF))
+ [w32, w32 `shiftR` 8,
+ w32 `shiftR` 16, w32 `shiftR` 24]
+#endif
+\end{code}
+
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
new file mode 100644
index 0000000000..19db7af16b
--- /dev/null
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -0,0 +1,1358 @@
+%
+% (c) The University of Glasgow 2002
+%
+\section[ByteCodeGen]{Generate bytecode from Core}
+
+\begin{code}
+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
+
+#include "HsVersions.h"
+
+import ByteCodeInstr
+import ByteCodeFFI ( mkMarshalCode, moan64 )
+import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO,
+ assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
+import ByteCodeLink ( lookupStaticPtr )
+
+import Outputable
+import Name ( Name, getName, mkSystemVarName )
+import Id
+import FiniteMap
+import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
+import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses )
+import CoreUtils ( exprType )
+import CoreSyn
+import PprCore ( pprCoreExpr )
+import Literal ( Literal(..), literalType )
+import PrimOp ( PrimOp(..) )
+import CoreFVs ( freeVars )
+import Type ( isUnLiftedType, splitTyConApp_maybe )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
+ isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId,
+ dataConRepArity )
+import TyCon ( TyCon, tyConFamilySize, isDataTyCon,
+ tyConDataCons, isUnboxedTupleTyCon )
+import Class ( Class, classTyCon )
+import Type ( Type, repType, splitFunTys, dropForAlls, pprType )
+import Util
+import DataCon ( dataConRepArity )
+import Var ( isTyVar )
+import VarSet ( VarSet, varSetElems )
+import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon
+ )
+import DynFlags ( DynFlags, DynFlag(..) )
+import ErrUtils ( showPass, dumpIfSet_dyn )
+import Unique ( mkPseudoUniqueE )
+import FastString ( FastString(..), unpackFS )
+import Panic ( GhcException(..) )
+import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord,
+ CgRep(..), cgRepSizeW, isFollowableArg, idCgRep )
+import Bitmap ( intsToReverseBitmap, mkBitmap )
+import OrdList
+import Constants ( wORD_SIZE )
+
+import Data.List ( intersperse, sortBy, zip4, zip6, partition )
+import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8,
+ withForeignPtr )
+import Foreign.C ( CInt )
+import Control.Exception ( throwDyn )
+
+import GHC.Exts ( Int(..), ByteArray# )
+
+import Control.Monad ( when )
+import Data.Char ( ord, chr )
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for a complete module
+
+byteCodeGen :: DynFlags
+ -> [CoreBind]
+ -> [TyCon]
+ -> IO CompiledByteCode
+byteCodeGen dflags binds tycs
+ = do showPass dflags "ByteCodeGen"
+
+ let flatBinds = [ (bndr, freeVars rhs)
+ | (bndr, rhs) <- flattenBinds binds]
+
+ (BcM_State final_ctr mallocd, proto_bcos)
+ <- runBc (mapM schemeTopBind flatBinds)
+
+ when (notNull mallocd)
+ (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
+
+ dumpIfSet_dyn dflags Opt_D_dump_BCOs
+ "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+
+ assembleBCOs proto_bcos tycs
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for an expression
+
+-- Returns: (the root BCO for this expression,
+-- a list of auxilary BCOs resulting from compiling closures)
+coreExprToBCOs :: DynFlags
+ -> CoreExpr
+ -> IO UnlinkedBCO
+coreExprToBCOs dflags expr
+ = do showPass dflags "ByteCodeGen"
+
+ -- create a totally bogus name for the top-level BCO; this
+ -- should be harmless, since it's never used for anything
+ let invented_name = mkSystemVarName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel")
+ invented_id = mkLocalId invented_name (panic "invented_id's type")
+
+ (BcM_State final_ctr mallocd, proto_bco)
+ <- runBc (schemeTopBind (invented_id, freeVars expr))
+
+ when (notNull mallocd)
+ (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
+
+ dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
+
+ assembleBCO proto_bco
+
+
+-- -----------------------------------------------------------------------------
+-- Compilation schema for the bytecode generator
+
+type BCInstrList = OrdList BCInstr
+
+type Sequel = Int -- back off to this depth before ENTER
+
+-- Maps Ids to the offset from the stack _base_ so we don't have
+-- to mess with it after each push/pop.
+type BCEnv = FiniteMap Id Int -- To find vars on the stack
+
+ppBCEnv :: BCEnv -> SDoc
+ppBCEnv p
+ = text "begin-env"
+ $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
+ $$ text "end-env"
+ where
+ pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
+ cmp_snd x y = compare (snd x) (snd y)
+
+-- Create a BCO and do a spot of peephole optimisation on the insns
+-- at the same time.
+mkProtoBCO
+ :: name
+ -> BCInstrList
+ -> Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)
+ -> Int
+ -> Int
+ -> [StgWord]
+ -> Bool -- True <=> is a return point, rather than a function
+ -> [Ptr ()]
+ -> ProtoBCO name
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
+ is_ret mallocd_blocks
+ = ProtoBCO {
+ protoBCOName = nm,
+ protoBCOInstrs = maybe_with_stack_check,
+ protoBCOBitmap = bitmap,
+ protoBCOBitmapSize = bitmap_size,
+ protoBCOArity = arity,
+ protoBCOExpr = origin,
+ protoBCOPtrs = mallocd_blocks
+ }
+ where
+ -- Overestimate the stack usage (in words) of this BCO,
+ -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+ -- stack check. (The interpreter always does a stack check
+ -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+ -- BCO anyway, so we only need to add an explicit on in the
+ -- (hopefully rare) cases when the (overestimated) stack use
+ -- exceeds iNTERP_STACK_CHECK_THRESH.
+ maybe_with_stack_check
+ | is_ret = peep_d
+ -- don't do stack checks at return points;
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function)
+ | stack_overest >= 65535
+ = pprPanic "mkProtoBCO: stack use won't fit in 16 bits"
+ (int stack_overest)
+ | stack_overest >= iNTERP_STACK_CHECK_THRESH
+ = STKCHECK stack_overest : peep_d
+ | otherwise
+ = peep_d -- the supposedly common case
+
+ stack_overest = sum (map bciStackUse peep_d)
+
+ -- Merge local pushes
+ peep_d = peep (fromOL instrs_ordlist)
+
+ peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
+ = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
+ peep (PUSH_L off1 : PUSH_L off2 : rest)
+ = PUSH_LL off1 (off2-1) : peep rest
+ peep (i:rest)
+ = i : peep rest
+ peep []
+ = []
+
+argBits :: [CgRep] -> [Bool]
+argBits [] = []
+argBits (rep : args)
+ | isFollowableArg rep = False : argBits args
+ | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
+
+-- -----------------------------------------------------------------------------
+-- schemeTopBind
+
+-- Compile code for the right-hand side of a top-level binding
+
+schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
+
+
+schemeTopBind (id, rhs)
+ | Just data_con <- isDataConWorkId_maybe id,
+ isNullaryRepDataCon data_con
+ = -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
+ -- If we feed it into schemeR, we'll get
+ -- Nil = Nil
+ -- because mkConAppCode treats nullary constructor applications
+ -- by just re-using the single top-level definition. So
+ -- for the worker itself, we must allocate it directly.
+ emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+
+ | otherwise
+ = schemeR [{- No free variables -}] (id, rhs)
+
+-- -----------------------------------------------------------------------------
+-- schemeR
+
+-- Compile code for a right-hand side, to give a BCO that,
+-- when executed with the free variables and arguments on top of the stack,
+-- will return with a pointer to the result on top of the stack, after
+-- removing the free variables and arguments.
+--
+-- Park the resulting BCO in the monad. Also requires the
+-- variable to which this value was bound, so as to give the
+-- resulting BCO a name.
+
+schemeR :: [Id] -- Free vars of the RHS, ordered as they
+ -- will appear in the thunk. Empty for
+ -- top-level things, which have no free vars.
+ -> (Id, AnnExpr Id VarSet)
+ -> BcM (ProtoBCO Name)
+schemeR fvs (nm, rhs)
+{-
+ | trace (showSDoc (
+ (char ' '
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+ $$ pprCoreExpr (deAnnotate rhs)
+ $$ char ' '
+ ))) False
+ = undefined
+ | otherwise
+-}
+ = schemeR_wrk fvs nm rhs (collect [] rhs)
+
+collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e
+collect xs (_, not_lambda) = (reverse xs, not_lambda)
+
+schemeR_wrk fvs nm original_body (args, body)
+ = let
+ all_args = reverse args ++ fvs
+ arity = length all_args
+ -- all_args are the args in reverse order. We're compiling a function
+ -- \fv1..fvn x1..xn -> e
+ -- i.e. the fvs come first
+
+ szsw_args = map idSizeW all_args
+ szw_args = sum szsw_args
+ p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
+
+ -- make the arg bitmap
+ bits = argBits (reverse (map idCgRep all_args))
+ bitmap_size = length bits
+ bitmap = mkBitmap bits
+ in
+ schemeE szw_args 0 p_init body `thenBc` \ body_code ->
+ emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
+ arity bitmap_size bitmap False{-not alts-})
+
+
+fvsToEnv :: BCEnv -> VarSet -> [Id]
+-- Takes the free variables of a right-hand side, and
+-- delivers an ordered list of the local variables that will
+-- be captured in the thunk for the RHS
+-- The BCEnv argument tells which variables are in the local
+-- environment: these are the ones that should be captured
+--
+-- The code that constructs the thunk, and the code that executes
+-- it, have to agree about this layout
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+ isId v, -- Could be a type variable
+ v `elemFM` p]
+
+-- -----------------------------------------------------------------------------
+-- schemeE
+
+-- Compile code to apply the given expression to the remaining args
+-- on the stack, returning a HNF.
+schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+
+-- Delegate tail-calls to schemeT.
+schemeE d s p e@(AnnApp f a)
+ = schemeT d s p e
+
+schemeE d s p e@(AnnVar v)
+ | not (isUnLiftedType v_type)
+ = -- Lifted-type thing; push it in the normal way
+ schemeT d s p e
+
+ | otherwise
+ = -- Returning an unlifted value.
+ -- Heave it on the stack, SLIDE, and RETURN.
+ pushAtom d p (AnnVar v) `thenBc` \ (push, szw) ->
+ returnBc (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX v_rep) -- go
+ where
+ v_type = idType v
+ v_rep = typeCgRep v_type
+
+schemeE d s p (AnnLit literal)
+ = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) ->
+ let l_rep = typeCgRep (literalType literal)
+ in returnBc (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX l_rep) -- go
+
+
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+ | (AnnVar v, args_r_to_l) <- splitApp rhs,
+ Just data_con <- isDataConWorkId_maybe v,
+ dataConRepArity data_con == length args_r_to_l
+ = -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
+ mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code ->
+ schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code ->
+ returnBc (alloc_code `appOL` body_code)
+
+-- General case for let. Generates correct, if inefficient, code in
+-- all situations.
+schemeE d s p (AnnLet binds (_,body))
+ = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
+ AnnRec xs_n_rhss -> unzip xs_n_rhss
+ n_binds = length xs
+
+ fvss = map (fvsToEnv p' . fst) rhss
+
+ -- Sizes of free vars
+ sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
+
+ -- the arity of each rhs
+ arities = map (length . fst . collect []) rhss
+
+ -- This p', d' defn is safe because all the items being pushed
+ -- are ptrs, so all have size 1. d' and p' reflect the stack
+ -- after the closures have been allocated in the heap (but not
+ -- filled in), and pointers to them parked on the stack.
+ p' = addListToFM p (zipE xs (mkStackOffsets d (nOfThem n_binds 1)))
+ d' = d + n_binds
+ zipE = zipEqual "schemeE"
+
+ -- ToDo: don't build thunks for things with no free variables
+ build_thunk dd [] size bco off arity
+ = returnBc (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
+ where
+ mkap | arity == 0 = MKAP
+ | otherwise = MKPAP
+ build_thunk dd (fv:fvs) size bco off arity = do
+ (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
+ more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
+ returnBc (push_code `appOL` more_push_code)
+
+ alloc_code = toOL (zipWith mkAlloc sizes arities)
+ where mkAlloc sz 0 = ALLOC_AP sz
+ mkAlloc sz arity = ALLOC_PAP arity sz
+
+ compile_bind d' fvs x rhs size arity off = do
+ bco <- schemeR fvs (x,rhs)
+ build_thunk d' fvs size bco off arity
+
+ compile_binds =
+ [ compile_bind d' fvs x rhs size arity n
+ | (fvs, x, rhs, size, arity, n) <-
+ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+ ]
+ in do
+ body_code <- schemeE d' s p' body
+ thunk_codes <- sequence compile_binds
+ returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
+
+
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
+ | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
+ -- Convert
+ -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- becuse the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
+
+ = --trace "automagic mashing of case alts (# VoidArg, a #)" $
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+
+ | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
+ = --trace "automagic mashing of case alts (# a, VoidArg #)" $
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
+ | isUnboxedTupleCon dc
+ -- Similarly, convert
+ -- case .... of x { (# a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ = --trace "automagic mashing of case alts (# a #)" $
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+
+schemeE d s p (AnnCase scrut bndr _ alts)
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+
+schemeE d s p (AnnNote note (_, body))
+ = schemeE d s p body
+
+schemeE d s p other
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ (pprCoreExpr (deAnnotate' other))
+
+
+-- Compile code to do a tail call. Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter. Four cases:
+--
+-- 0. (Nasty hack).
+-- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
+-- The int will be on the stack. Generate a code sequence
+-- to convert it to the relevant constructor, SLIDE and ENTER.
+--
+-- 1. The fn denotes a ccall. Defer to generateCCall.
+--
+-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat
+-- it simply as b -- since the representations are identical
+-- (the VoidArg takes up zero stack space). Also, spot
+-- (# b #) and treat it as b.
+--
+-- 3. Application of a constructor, by defn saturated.
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- then the ptrs, and then do PACK and RETURN.
+--
+-- 4. Otherwise, it must be a function call. Push the args
+-- right to left, SLIDE and ENTER.
+
+schemeT :: Int -- Stack depth
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr' Id VarSet
+ -> BcM BCInstrList
+
+schemeT d s p app
+
+-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
+-- = panic "schemeT ?!?!"
+
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
+-- = error "?!?!"
+
+ -- Case 0
+ | Just (arg, constr_names) <- maybe_is_tagToEnum_call
+ = pushAtom d p arg `thenBc` \ (push, arg_words) ->
+ implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
+ returnBc (push `appOL` tagToId_sequence
+ `appOL` mkSLIDE 1 (d+arg_words-s)
+ `snocOL` ENTER)
+
+ -- Case 1
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = generateCCall d s p ccall_spec fn args_r_to_l
+
+ -- Case 2: Constructor application
+ | Just con <- maybe_saturated_dcon,
+ isUnboxedTupleCon con
+ = case args_r_to_l of
+ [arg1,arg2] | isVoidArgAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidArgAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
+
+ -- Case 3: Ordinary data constructor
+ | Just con <- maybe_saturated_dcon
+ = mkConAppCode d s p con args_r_to_l `thenBc` \ alloc_con ->
+ returnBc (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
+
+ -- Case 4: Tail call of function
+ | otherwise
+ = doTailCall d s p fn args_r_to_l
+
+ where
+ -- Detect and extract relevant info for the tagToEnum kludge.
+ maybe_is_tagToEnum_call
+ = let extract_constr_Names ty
+ | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
+ = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ in
+ case app of
+ (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+ -> case isPrimOpId_maybe v of
+ Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
+ other -> Nothing
+ other -> Nothing
+
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
+ (AnnVar fn, args_r_to_l) = splitApp app
+
+ -- Only consider this to be a constructor application iff it is
+ -- saturated. Otherwise, we'll call the constructor wrapper.
+ n_args = length args_r_to_l
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application,
+-- leaving it on top of the stack
+
+mkConAppCode :: Int -> Sequel -> BCEnv
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
+
+mkConAppCode orig_d s p con [] -- Nullary constructor
+ = ASSERT( isNullaryRepDataCon con )
+ returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d s p con args_r_to_l
+ = ASSERT( dataConRepArity con == length args_r_to_l )
+ do_pushery orig_d (non_ptr_args ++ ptr_args)
+ where
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
+ (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
+
+ do_pushery d (arg:args)
+ = pushAtom d p arg `thenBc` \ (push, arg_words) ->
+ do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
+ returnBc (push `appOL` more_push_code)
+ do_pushery d []
+ = returnBc (unitOL (PACK con n_arg_words))
+ where
+ n_arg_words = d - orig_d
+
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type. We always just return.
+
+unboxedTupleReturn
+ :: Int -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = do
+ (push, sz) <- pushAtom d p arg
+ returnBc (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+ :: Int -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
+doTailCall init_d s p fn args
+ = do_pushes init_d args (map atomRep args)
+ where
+ do_pushes d [] reps = do
+ ASSERT( null reps ) return ()
+ (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ ASSERT( sz == 1 ) return ()
+ returnBc (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
+ do_pushes d args reps = do
+ let (push_apply, n, rest_of_reps) = findPushSeq reps
+ (these_args, rest_of_args) = splitAt n args
+ (next_d, push_code) <- push_seq d these_args
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
+ returnBc (push_code `appOL` (push_apply `consOL` instrs))
+
+ push_seq d [] = return (d, nilOL)
+ push_seq d (arg:args) = do
+ (push_code, sz) <- pushAtom d p arg
+ (final_d, more_push_code) <- push_seq (d+sz) args
+ return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (PtrArg: PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (PtrArg: PtrArg: rest)
+ = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (PtrArg: rest)
+ = (PUSH_APPLY_P, 1, rest)
+findPushSeq (VoidArg: rest)
+ = (PUSH_APPLY_V, 1, rest)
+findPushSeq (NonPtrArg: rest)
+ = (PUSH_APPLY_N, 1, rest)
+findPushSeq (FloatArg: rest)
+ = (PUSH_APPLY_F, 1, rest)
+findPushSeq (DoubleArg: rest)
+ = (PUSH_APPLY_D, 1, rest)
+findPushSeq (LongArg: rest)
+ = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+ = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase :: Int -> Sequel -> BCEnv
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p (_,scrut)
+ bndr alts is_unboxed_tuple
+ = let
+ -- Top of stack is the return itbl, as usual.
+ -- underneath it is the pointer to the alt_code BCO.
+ -- When an alt is entered, it assumes the returned value is
+ -- on top of the itbl.
+ ret_frame_sizeW = 2
+
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
+
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + idSizeW bndr
+
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
+ d_alts = d_bndr + unlifted_itbl_sizeW
+
+ -- Env in which to compile the alts, not including
+ -- any vars bound by the alts themselves
+ p_alts = addToFM p bndr (d_bndr - 1)
+
+ bndr_ty = idType bndr
+ isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
+
+ -- given an alt, return a discr and code for it.
+ codeALt alt@(DEFAULT, _, (_,rhs))
+ = schemeE d_alts s p_alts rhs `thenBc` \ rhs_code ->
+ returnBc (NoDiscr, rhs_code)
+ codeAlt alt@(discr, bndrs, (_,rhs))
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
+ returnBc (my_discr alt, rhs_code)
+ -- algebraic alt with some binders
+ | ASSERT(isAlgCase) otherwise =
+ let
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+ ptr_sizes = map idSizeW ptrs
+ nptrs_sizes = map idSizeW nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = addListToFM p_alts
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ in do
+ rhs_code <- schemeE (d_alts+size) s p' rhs
+ return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
+ where
+ real_bndrs = filter (not.isTyVar) bndrs
+
+
+ my_discr (DEFAULT, binds, rhs) = NoDiscr {-shouldn't really happen-}
+ my_discr (DataAlt dc, binds, rhs)
+ | isUnboxedTupleCon dc
+ = unboxedTupleException
+ | otherwise
+ = DiscrP (dataConTag dc - fIRST_TAG)
+ my_discr (LitAlt l, binds, rhs)
+ = case l of MachInt i -> DiscrI (fromInteger i)
+ MachFloat r -> DiscrF (fromRational r)
+ MachDouble r -> DiscrD (fromRational r)
+ MachChar i -> DiscrI (ord i)
+ _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+ maybe_ncons
+ | not isAlgCase = Nothing
+ | otherwise
+ = case [dc | (DataAlt dc, _, _) <- alts] of
+ [] -> Nothing
+ (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
+ bitmap = intsToReverseBitmap d{-size-} (sortLe (<=) rel_slots)
+ where
+ binds = fmToList p
+ rel_slots = concat (map spread binds)
+ spread (id, offset)
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
+
+ in do
+ alt_stuff <- mapM codeAlt alts
+ alt_final <- mkMultiBranch maybe_ncons alt_stuff
+ let
+ alt_bco_name = getName bndr
+ alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
+ 0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}
+ -- in
+-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+-- "\n bitmap = " ++ show bitmap) $ do
+ scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
+ alt_bco' <- emitBc alt_bco
+ let push_alts
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+ returnBc (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays. Then, generate the marshalling
+-- (machine) code for the ccall, and create bytecodes to call that and
+-- then return in the right way.
+
+generateCCall :: Int -> Sequel -- stack and sequel depths
+ -> BCEnv
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id VarSet] -- args (atoms)
+ -> BcM BCInstrList
+
+generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
+ = let
+ -- useful constants
+ addr_sizeW = cgRepSizeW NonPtrArg
+
+ -- Get the args on the stack, with tags and suitably
+ -- dereferenced for the CCall. For each arg, return the
+ -- depth to the first word of the bits for that arg, and the
+ -- CgRep of what was actually pushed.
+
+ pargs d [] = returnBc []
+ pargs d (a:az)
+ = let arg_ty = repType (exprType (deAnnotate' a))
+
+ in case splitTyConApp_maybe arg_ty of
+ -- Don't push the FO; instead push the Addr# it
+ -- contains.
+ Just (t, _)
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrPtrsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,NonPtrArg):rest)
+
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ -> pargs (d + addr_sizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrWordsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,NonPtrArg):rest)
+
+ -- Default case: push taggedly, but otherwise intact.
+ other
+ -> pushAtom d p a `thenBc` \ (code_a, sz_a) ->
+ pargs (d+sz_a) az `thenBc` \ rest ->
+ returnBc ((code_a, atomRep a) : rest)
+
+ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
+ -- the stack but then advance it over the headers, so as to
+ -- point to the payload.
+ parg_ArrayishRep hdrSize d p a
+ = pushAtom d p a `thenBc` \ (push_fo, _) ->
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr#.
+ returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize)
+
+ in
+ pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
+ let
+ (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+
+ push_args = concatOL pushs_arg
+ d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l)
+ a_reps_pushed_RAW
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg
+ = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
+ | otherwise
+ = reverse (tail a_reps_pushed_r_to_l)
+
+ -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+ -- push_args is the code to do that.
+ -- d_after_args is the stack depth once the args are on.
+
+ -- Get the result rep.
+ (returns_void, r_rep)
+ = case maybe_getCCallReturnRep (idType fn) of
+ Nothing -> (True, VoidArg)
+ Just rr -> (False, rr)
+ {-
+ Because the Haskell stack grows down, the a_reps refer to
+ lowest to highest addresses in that order. The args for the call
+ are on the stack. Now push an unboxed Addr# indicating
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
+ Addr# just pushed, and a literal field holding the mallocville
+ address of the piece of marshalling code we generate.
+ So, just prior to the CCALL insn, the stack looks like this
+ (growing down, as usual):
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+
+ The interpreter then calls the marshall code mentioned
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
+ that is, the addr of the topmost word in the stack.
+ When this returns, the placeholder will have been
+ filled in. The placeholder is slid down to the sequel
+ depth, and we RETURN.
+
+ This arrangement makes it simple to do f-i-dynamic since the Addr#
+ value is the first arg anyway.
+
+ The marshalling code is generated specifically for this
+ call site, and so knows exactly the (Haskell) stack
+ offsets of the args, fn address and placeholder. It
+ copies the args to the C stack, calls the stacked addr,
+ and parks the result back in the placeholder. The interpreter
+ calls it as a normal C call, assuming it has a signature
+ void marshall_code ( StgWord* ptr_to_top_of_stack )
+ -}
+ -- resolve static address
+ get_target_info
+ = case target of
+ DynamicTarget
+ -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
+ StaticTarget target
+ -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
+ returnBc (True, res)
+ in
+ get_target_info `thenBc` \ (is_static, static_target_addr) ->
+ let
+
+ -- Get the arg reps, zapping the leading Addr# in the dynamic case
+ a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+ | is_static = a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
+ then panic "ByteCodeGen.generateCCall: dyn with no args"
+ else tail a_reps_pushed_RAW
+
+ -- push the Addr#
+ (push_Addr, d_after_Addr)
+ | is_static
+ = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
+ d_after_args + addr_sizeW)
+ | otherwise -- is already on the stack
+ = (nilOL, d_after_args)
+
+ -- Push the return placeholder. For a call returning nothing,
+ -- this is a VoidArg (tag).
+ r_sizeW = cgRepSizeW r_rep
+ d_after_r = d_after_Addr + r_sizeW
+ r_lit = mkDummyLiteral r_rep
+ push_r = (if returns_void
+ then nilOL
+ else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
+
+ -- generate the marshalling code we're going to call
+ r_offW = 0
+ addr_offW = r_sizeW
+ arg1_offW = r_sizeW + addr_sizeW
+ args_offW = map (arg1_offW +)
+ (init (scanl (+) 0 (map cgRepSizeW a_reps)))
+ in
+ ioToBc (mkMarshalCode cconv
+ (r_offW, r_rep) addr_offW
+ (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
+ recordMallocBc addr_of_marshaller `thenBc_`
+ let
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
+ stk_offset = d_after_r - s
+
+ -- do the call
+ do_call = unitOL (CCALL stk_offset (castPtr addr_of_marshaller))
+ -- slide and return
+ wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
+ `snocOL` RETURN_UBX r_rep
+ in
+ --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $
+ returnBc (
+ push_args `appOL`
+ push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+ )
+
+
+-- Make a dummy literal, to be used as a placeholder for FFI return
+-- values on the stack.
+mkDummyLiteral :: CgRep -> Literal
+mkDummyLiteral pr
+ = case pr of
+ NonPtrArg -> MachWord 0
+ DoubleArg -> MachDouble 0
+ FloatArg -> MachFloat 0
+ _ -> moan64 "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
+--
+-- to Just IntRep
+-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd.
+--
+-- Alternatively, for call-targets returning nothing, convert
+--
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
+--
+-- to Nothing
+
+maybe_getCCallReturnRep :: Type -> Maybe CgRep
+maybe_getCCallReturnRep fn_ty
+ = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+ maybe_r_rep_to_go
+ = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
+ (r_tycon, r_reps)
+ = case splitTyConApp_maybe (repType r_ty) of
+ (Just (tyc, tys)) -> (tyc, map typeCgRep tys)
+ Nothing -> blargh
+ ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps)
+ || r_reps == [VoidArg] )
+ && isUnboxedTupleTyCon r_tycon
+ && case maybe_r_rep_to_go of
+ Nothing -> True
+ Just r_rep -> r_rep /= PtrArg
+ -- if it was, it would be impossible
+ -- to create a valid return value
+ -- placeholder on the stack
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ (pprType fn_ty)
+ in
+ --trace (showSDoc (ppr (a_reps, r_reps))) $
+ if ok then maybe_r_rep_to_go else blargh
+
+-- Compile code which expects an unboxed Int on the top of stack,
+-- (call it i), and pushes the i'th closure in the supplied list
+-- as a consequence.
+implement_tagToId :: [Name] -> BcM BCInstrList
+implement_tagToId names
+ = ASSERT( notNull names )
+ getLabelsBc (length names) `thenBc` \ labels ->
+ getLabelBc `thenBc` \ label_fail ->
+ getLabelBc `thenBc` \ label_exit ->
+ zip4 labels (tail labels ++ [label_fail])
+ [0 ..] names `bind` \ infos ->
+ map (mkStep label_exit) infos `bind` \ steps ->
+ returnBc (concatOL steps
+ `appOL`
+ toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
+ where
+ mkStep l_exit (my_label, next_label, n, name_for_n)
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G name_for_n,
+ JMP l_exit]
+
+
+-- -----------------------------------------------------------------------------
+-- pushAtom
+
+-- Push an atom onto the stack, returning suitable code & number of
+-- stack words used.
+--
+-- The env p must map each variable to the highest- numbered stack
+-- slot for it. For example, if the stack has depth 4 and we
+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],
+-- the tag in stack[5], the stack will have depth 6, and p must map v
+-- to 5 and not to 4. Stack locations are numbered from zero, so a
+-- depth 6 stack has valid words 0 .. 5.
+
+pushAtom :: Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
+
+pushAtom d p (AnnApp f (_, AnnType _))
+ = pushAtom d p (snd f)
+
+pushAtom d p (AnnNote note e)
+ = pushAtom d p (snd e)
+
+pushAtom d p (AnnLam x e)
+ | isTyVar x
+ = pushAtom d p (snd e)
+
+pushAtom d p (AnnVar v)
+
+ | idCgRep v == VoidArg
+ = returnBc (nilOL, 0)
+
+ | isFCallId v
+ = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
+
+ | Just primop <- isPrimOpId_maybe v
+ = returnBc (unitOL (PUSH_PRIMOP primop), 1)
+
+ | Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
+ = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
+
+ | otherwise -- v must be a global variable
+ = ASSERT(sz == 1)
+ returnBc (unitOL (PUSH_G (getName v)), sz)
+
+ where
+ sz = idSizeW v
+
+
+pushAtom d p (AnnLit lit)
+ = case lit of
+ MachLabel fs _ -> code NonPtrArg
+ MachWord w -> code NonPtrArg
+ MachInt i -> code PtrArg
+ MachFloat r -> code FloatArg
+ MachDouble r -> code DoubleArg
+ MachChar c -> code NonPtrArg
+ MachStr s -> pushStr s
+ where
+ code rep
+ = let size_host_words = cgRepSizeW rep
+ in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
+ size_host_words)
+
+ pushStr s
+ = let getMallocvilleAddr
+ = case s of
+ FastString _ n _ fp _ ->
+ -- we could grab the Ptr from the ForeignPtr,
+ -- but then we have no way to control its lifetime.
+ -- In reality it'll probably stay alive long enoungh
+ -- by virtue of the global FastString table, but
+ -- to be on the safe side we copy the string into
+ -- a malloc'd area of memory.
+ ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
+ recordMallocBc ptr `thenBc_`
+ ioToBc (
+ withForeignPtr fp $ \p -> do
+ memcpy ptr p (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ return ptr
+ )
+ other -> panic "ByteCodeGen.pushAtom.pushStr"
+ in
+ getMallocvilleAddr `thenBc` \ addr ->
+ -- Get the addr on the stack, untaggedly
+ returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
+
+pushAtom d p other
+ = pprPanic "ByteCodeGen.pushAtom"
+ (pprCoreExpr (deAnnotate (undefined, other)))
+
+foreign import ccall unsafe "memcpy"
+ memcpy :: Ptr a -> Ptr b -> CInt -> IO ()
+
+
+-- -----------------------------------------------------------------------------
+-- Given a bunch of alts code and their discrs, do the donkey work
+-- of making a multiway branch using a switch tree.
+-- What a load of hassle!
+
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+ -- a hint; generates better code
+ -- Nothing is always safe
+ -> [(Discr, BCInstrList)]
+ -> BcM BCInstrList
+mkMultiBranch maybe_ncons raw_ways
+ = let d_way = filter (isNoDiscr.fst) raw_ways
+ notd_ways = sortLe
+ (\w1 w2 -> leAlt (fst w1) (fst w2))
+ (filter (not.isNoDiscr.fst) raw_ways)
+
+ mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
+ mkTree [] range_lo range_hi = returnBc the_default
+
+ mkTree [val] range_lo range_hi
+ | range_lo `eqAlt` range_hi
+ = returnBc (snd val)
+ | otherwise
+ = getLabelBc `thenBc` \ label_neq ->
+ returnBc (mkTestEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
+
+ mkTree vals range_lo range_hi
+ = let n = length vals `div` 2
+ vals_lo = take n vals
+ vals_hi = drop n vals
+ v_mid = fst (head vals_hi)
+ in
+ getLabelBc `thenBc` \ label_geq ->
+ mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
+ mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
+ returnBc (mkTestLT v_mid label_geq
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
+ = case d_way of [] -> unitOL CASEFAIL
+ [(_, def)] -> def
+
+ -- None of these will be needed if there are no non-default alts
+ (mkTestLT, mkTestEQ, init_lo, init_hi)
+ | null notd_ways
+ = panic "mkMultiBranch: awesome foursome"
+ | otherwise
+ = case fst (head notd_ways) of {
+ DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
+ \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
+ DiscrI minBound,
+ DiscrI maxBound );
+ DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
+ \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
+ DiscrF minF,
+ DiscrF maxF );
+ DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
+ \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
+ DiscrD minD,
+ DiscrD maxD );
+ DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
+ \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
+ DiscrP algMinBound,
+ DiscrP algMaxBound )
+ }
+
+ (algMinBound, algMaxBound)
+ = case maybe_ncons of
+ Just n -> (0, n - 1)
+ Nothing -> (minBound, maxBound)
+
+ (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
+ (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
+ (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
+ (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
+ NoDiscr `eqAlt` NoDiscr = True
+ _ `eqAlt` _ = False
+
+ (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
+ (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
+ (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
+ (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
+ NoDiscr `leAlt` NoDiscr = True
+ _ `leAlt` _ = False
+
+ isNoDiscr NoDiscr = True
+ isNoDiscr _ = False
+
+ dec (DiscrI i) = DiscrI (i-1)
+ dec (DiscrP i) = DiscrP (i-1)
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
+
+ -- same snotty comment applies to the following
+ minF, maxF :: Float
+ minD, maxD :: Double
+ minF = -1.0e37
+ maxF = 1.0e37
+ minD = -1.0e308
+ maxD = 1.0e308
+ in
+ mkTree notd_ways init_lo init_hi
+
+
+-- -----------------------------------------------------------------------------
+-- Supporting junk for the compilation schemes
+
+-- Describes case alts
+data Discr
+ = DiscrI Int
+ | DiscrF Float
+ | DiscrD Double
+ | DiscrP Int
+ | NoDiscr
+
+instance Outputable Discr where
+ ppr (DiscrI i) = int i
+ ppr (DiscrF f) = text (show f)
+ ppr (DiscrD d) = text (show d)
+ ppr (DiscrP i) = int i
+ ppr NoDiscr = text "DEF"
+
+
+lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
+lookupBCEnv_maybe = lookupFM
+
+idSizeW :: Id -> Int
+idSizeW id = cgRepSizeW (typeCgRep (idType id))
+
+unboxedTupleException :: a
+unboxedTupleException
+ = throwDyn
+ (Panic
+ ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++
+ "\tto foreign import/export decls in source. Workaround:\n" ++
+ "\tcompile this module to a .o file, then restart session."))
+
+
+mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
+bind x f = f x
+
+splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
+ -- The arguments are returned in *right-to-left* order
+splitApp (AnnApp (_,f) (_,a))
+ | isTypeAtom a = splitApp f
+ | otherwise = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp (AnnNote n (_,e)) = splitApp e
+splitApp e = (e, [])
+
+
+isTypeAtom :: AnnExpr' id ann -> Bool
+isTypeAtom (AnnType _) = True
+isTypeAtom _ = False
+
+isVoidArgAtom :: AnnExpr' id ann -> Bool
+isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg
+isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e
+isVoidArgAtom _ = False
+
+atomRep :: AnnExpr' Id ann -> CgRep
+atomRep (AnnVar v) = typeCgRep (idType v)
+atomRep (AnnLit l) = typeCgRep (literalType l)
+atomRep (AnnNote n b) = atomRep (snd b)
+atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
+atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
+atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
+
+isPtrAtom :: AnnExpr' Id ann -> Bool
+isPtrAtom e = atomRep e == PtrArg
+
+-- Let szsw be the sizes in words of some items pushed onto the stack,
+-- which has initial depth d'. Return the values which the stack environment
+-- should map these items to.
+mkStackOffsets :: Int -> [Int] -> [Int]
+mkStackOffsets original_depth szsw
+ = map (subtract 1) (tail (scanl (+) original_depth szsw))
+
+-- -----------------------------------------------------------------------------
+-- The bytecode generator's monad
+
+data BcM_State
+ = BcM_State {
+ nextlabel :: Int, -- for generating local labels
+ malloced :: [Ptr ()] } -- ptrs malloced for current BCO
+ -- Should be free()d when it is GCd
+
+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
+
+ioToBc :: IO a -> BcM a
+ioToBc io = BcM $ \st -> do
+ x <- io
+ return (st, x)
+
+runBc :: BcM r -> IO (BcM_State, r)
+runBc (BcM m) = m (BcM_State 0 [])
+
+thenBc :: BcM a -> (a -> BcM b) -> BcM b
+thenBc (BcM expr) cont = BcM $ \st0 -> do
+ (st1, q) <- expr st0
+ let BcM k = cont q
+ (st2, r) <- k st1
+ return (st2, r)
+
+thenBc_ :: BcM a -> BcM b -> BcM b
+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
+ (st1, q) <- expr st0
+ (st2, r) <- cont st1
+ return (st2, r)
+
+returnBc :: a -> BcM a
+returnBc result = BcM $ \st -> (return (st, result))
+
+instance Monad BcM where
+ (>>=) = thenBc
+ (>>) = thenBc_
+ return = returnBc
+
+emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+ = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
+
+recordMallocBc :: Ptr a -> BcM ()
+recordMallocBc a
+ = BcM $ \st -> return (st{malloced = castPtr a : malloced st}, ())
+
+getLabelBc :: BcM Int
+getLabelBc
+ = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
+
+getLabelsBc :: Int -> BcM [Int]
+getLabelsBc n
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+\end{code}
diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
new file mode 100644
index 0000000000..7bd4408fff
--- /dev/null
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -0,0 +1,256 @@
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeInstrs]{Bytecode instruction definitions}
+
+\begin{code}
+module ByteCodeInstr (
+ BCInstr(..), ProtoBCO(..), bciStackUse
+ ) where
+
+#include "HsVersions.h"
+#include "../includes/MachDeps.h"
+
+import Outputable
+import Name ( Name )
+import Id ( Id )
+import CoreSyn
+import PprCore ( pprCoreExpr, pprCoreAlt )
+import Literal ( Literal )
+import DataCon ( DataCon )
+import VarSet ( VarSet )
+import PrimOp ( PrimOp )
+import SMRep ( StgWord, CgRep )
+import GHC.Ptr
+
+-- ----------------------------------------------------------------------------
+-- Bytecode instructions
+
+data ProtoBCO a
+ = ProtoBCO {
+ protoBCOName :: a, -- name, in some sense
+ protoBCOInstrs :: [BCInstr], -- instrs
+ -- arity and GC info
+ protoBCOBitmap :: [StgWord],
+ protoBCOBitmapSize :: Int,
+ protoBCOArity :: Int,
+ -- what the BCO came from
+ protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
+ -- malloc'd pointers
+ protoBCOPtrs :: [Ptr ()]
+ }
+
+type LocalLabel = Int
+
+data BCInstr
+ -- Messing with the stack
+ = STKCHECK Int
+
+ -- Push locals (existing bits of the stack)
+ | PUSH_L Int{-offset-}
+ | PUSH_LL Int Int{-2 offsets-}
+ | PUSH_LLL Int Int Int{-3 offsets-}
+
+ -- Push a ptr (these all map to PUSH_G really)
+ | PUSH_G Name
+ | PUSH_PRIMOP PrimOp
+ | PUSH_BCO (ProtoBCO Name)
+
+ -- Push an alt continuation
+ | PUSH_ALTS (ProtoBCO Name)
+ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
+
+ -- Pushing literals
+ | PUSH_UBX (Either Literal (Ptr ())) Int
+ -- push this int/float/double/addr, on the stack. Int
+ -- is # of words to copy from literal pool. Eitherness reflects
+ -- the difficulty of dealing with MachAddr here, mostly due to
+ -- the excessive (and unnecessary) restrictions imposed by the
+ -- designers of the new Foreign library. In particular it is
+ -- quite impossible to convert an Addr to any other integral
+ -- type, and it appears impossible to get hold of the bits of
+ -- an addr, even though we need to to assemble BCOs.
+
+ -- various kinds of application
+ | PUSH_APPLY_N
+ | PUSH_APPLY_V
+ | PUSH_APPLY_F
+ | PUSH_APPLY_D
+ | PUSH_APPLY_L
+ | PUSH_APPLY_P
+ | PUSH_APPLY_PP
+ | PUSH_APPLY_PPP
+ | PUSH_APPLY_PPPP
+ | PUSH_APPLY_PPPPP
+ | PUSH_APPLY_PPPPPP
+
+ | SLIDE Int{-this many-} Int{-down by this much-}
+
+ -- To do with the heap
+ | ALLOC_AP Int -- make an AP with this many payload words
+ | ALLOC_PAP Int Int -- make a PAP with this arity / payload words
+ | MKAP Int{-ptr to AP is this far down stack-} Int{-# words-}
+ | MKPAP Int{-ptr to PAP is this far down stack-} Int{-# words-}
+ | UNPACK Int -- unpack N words from t.o.s Constr
+ | PACK DataCon Int
+ -- after assembly, the DataCon is an index into the
+ -- itbl array
+ -- For doing case trees
+ | LABEL LocalLabel
+ | TESTLT_I Int LocalLabel
+ | TESTEQ_I Int LocalLabel
+ | TESTLT_F Float LocalLabel
+ | TESTEQ_F Float LocalLabel
+ | TESTLT_D Double LocalLabel
+ | TESTEQ_D Double LocalLabel
+
+ -- The Int value is a constructor number and therefore
+ -- stored in the insn stream rather than as an offset into
+ -- the literal pool.
+ | TESTLT_P Int LocalLabel
+ | TESTEQ_P Int LocalLabel
+
+ | CASEFAIL
+ | JMP LocalLabel
+
+ -- For doing calls to C (via glue code generated by ByteCodeFFI)
+ | CCALL Int -- stack frame size
+ (Ptr ()) -- addr of the glue code
+
+ -- For doing magic ByteArray passing to foreign calls
+ | SWIZZLE Int -- to the ptr N words down the stack,
+ Int -- add M (interpreted as a signed 16-bit entity)
+
+ -- To Infinity And Beyond
+ | ENTER
+ | RETURN -- return a lifted value
+ | RETURN_UBX CgRep -- return an unlifted value, here's its rep
+
+-- -----------------------------------------------------------------------------
+-- Printing bytecode instructions
+
+instance Outputable a => Outputable (ProtoBCO a) where
+ ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
+ = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
+ <+> text (show malloced) <> colon)
+ $$ nest 6 (text "bitmap: " <+> text (show bsize) <+> text (show bitmap))
+ $$ nest 6 (vcat (map ppr instrs))
+ $$ case origin of
+ Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
+ Right rhs -> pprCoreExpr (deAnnotate rhs)
+
+instance Outputable BCInstr where
+ ppr (STKCHECK n) = text "STKCHECK" <+> int n
+ ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
+ ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
+ ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
+ ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
+ ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
+ <> ppr op
+ ppr (PUSH_BCO bco) = text "PUSH_BCO" <+> nest 3 (ppr bco)
+ ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco
+ ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
+
+ ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
+ ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa)
+ ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
+ ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
+ ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
+ ppr PUSH_APPLY_D = text "PUSH_APPLY_D"
+ ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
+ ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
+ ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
+ ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
+ ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
+ ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
+ ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
+
+ ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
+ ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
+ ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz
+ ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
+ <+> int offset <+> text "stkoff"
+ ppr (UNPACK sz) = text "UNPACK " <+> int sz
+ ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
+ ppr (LABEL lab) = text "__" <> int lab <> colon
+ ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
+ ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
+ ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
+ ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
+ ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
+ ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
+ ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
+ ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
+ ppr (JMP lab) = text "JMP" <+> int lab
+ ppr CASEFAIL = text "CASEFAIL"
+ ppr ENTER = text "ENTER"
+ ppr RETURN = text "RETURN"
+ ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
+ ppr (CCALL off marshall_addr) = text "CCALL " <+> int off
+ <+> text "marshall code at"
+ <+> text (show marshall_addr)
+ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
+ <+> text "by" <+> int n
+
+-- -----------------------------------------------------------------------------
+-- The stack use, in words, of each bytecode insn. These _must_ be
+-- correct, or overestimates of reality, to be safe.
+
+-- NOTE: we aggregate the stack use from case alternatives too, so that
+-- we can do a single stack check at the beginning of a function only.
+
+-- This could all be made more accurate by keeping track of a proper
+-- stack high water mark, but it doesn't seem worth the hassle.
+
+protoBCOStackUse :: ProtoBCO a -> Int
+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
+
+bciStackUse :: BCInstr -> Int
+bciStackUse STKCHECK{} = 0
+bciStackUse PUSH_L{} = 1
+bciStackUse PUSH_LL{} = 2
+bciStackUse PUSH_LLL{} = 3
+bciStackUse PUSH_G{} = 1
+bciStackUse PUSH_PRIMOP{} = 1
+bciStackUse PUSH_BCO{} = 1
+bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_UBX _ nw) = nw
+bciStackUse PUSH_APPLY_N{} = 1
+bciStackUse PUSH_APPLY_V{} = 1
+bciStackUse PUSH_APPLY_F{} = 1
+bciStackUse PUSH_APPLY_D{} = 1
+bciStackUse PUSH_APPLY_L{} = 1
+bciStackUse PUSH_APPLY_P{} = 1
+bciStackUse PUSH_APPLY_PP{} = 1
+bciStackUse PUSH_APPLY_PPP{} = 1
+bciStackUse PUSH_APPLY_PPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPP{} = 1
+bciStackUse PUSH_APPLY_PPPPPP{} = 1
+bciStackUse ALLOC_AP{} = 1
+bciStackUse ALLOC_PAP{} = 1
+bciStackUse (UNPACK sz) = sz
+bciStackUse LABEL{} = 0
+bciStackUse TESTLT_I{} = 0
+bciStackUse TESTEQ_I{} = 0
+bciStackUse TESTLT_F{} = 0
+bciStackUse TESTEQ_F{} = 0
+bciStackUse TESTLT_D{} = 0
+bciStackUse TESTEQ_D{} = 0
+bciStackUse TESTLT_P{} = 0
+bciStackUse TESTEQ_P{} = 0
+bciStackUse CASEFAIL{} = 0
+bciStackUse JMP{} = 0
+bciStackUse ENTER{} = 0
+bciStackUse RETURN{} = 0
+bciStackUse RETURN_UBX{} = 1
+bciStackUse CCALL{} = 0
+bciStackUse SWIZZLE{} = 0
+
+-- These insns actually reduce stack use, but we need the high-tide level,
+-- so can't use this info. Not that it matters much.
+bciStackUse SLIDE{} = 0
+bciStackUse MKAP{} = 0
+bciStackUse MKPAP{} = 0
+bciStackUse PACK{} = 1 -- worst case is PACK 0 words
+\end{code}
diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
new file mode 100644
index 0000000000..74346c6218
--- /dev/null
+++ b/compiler/ghci/ByteCodeItbls.lhs
@@ -0,0 +1,366 @@
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
+
+\begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
+
+#include "HsVersions.h"
+
+import Name ( Name, getName )
+import NameEnv
+import SMRep ( typeCgRep )
+import DataCon ( DataCon, dataConRepArgTys )
+import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
+import Constants ( mIN_PAYLOAD_SIZE, wORD_SIZE )
+import CgHeapery ( mkVirtHeapOffsets )
+import FastString ( FastString(..) )
+import Util ( lengthIs, listLengthCmp )
+
+import Foreign
+import Foreign.C
+import DATA_BITS ( Bits(..), shiftR )
+
+import GHC.Exts ( Int(I#), addr2Int# )
+#if __GLASGOW_HASKELL__ < 503
+import Ptr ( Ptr(..) )
+#else
+import GHC.Ptr ( Ptr(..) )
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Manufacturing of info tables for DataCons}
+%* *
+%************************************************************************
+
+\begin{code}
+type ItblPtr = Ptr StgInfoTable
+type ItblEnv = NameEnv (Name, ItblPtr)
+ -- We need the Name in the range so we know which
+ -- elements to filter out when unloading a module
+
+mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
+mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
+
+
+-- Make info tables for the data decls in this module
+mkITbls :: [TyCon] -> IO ItblEnv
+mkITbls [] = return emptyNameEnv
+mkITbls (tc:tcs) = do itbls <- mkITbl tc
+ itbls2 <- mkITbls tcs
+ return (itbls `plusNameEnv` itbls2)
+
+mkITbl :: TyCon -> IO ItblEnv
+mkITbl tc
+ | not (isDataTyCon tc)
+ = return emptyNameEnv
+ | dcs `lengthIs` n -- paranoia; this is an assertion.
+ = make_constr_itbls dcs
+ where
+ dcs = tyConDataCons tc
+ n = tyConFamilySize tc
+
+#include "../includes/ClosureTypes.h"
+cONSTR :: Int -- Defined in ClosureTypes.h
+cONSTR = CONSTR
+
+-- Assumes constructors are numbered from zero, not one
+make_constr_itbls :: [DataCon] -> IO ItblEnv
+make_constr_itbls cons
+ | listLengthCmp cons 8 /= GT -- <= 8 elements in the list
+ = do is <- mapM mk_vecret_itbl (zip cons [0..])
+ return (mkItblEnv is)
+ | otherwise
+ = do is <- mapM mk_dirret_itbl (zip cons [0..])
+ return (mkItblEnv is)
+ where
+ mk_vecret_itbl (dcon, conNo)
+ = mk_itbl dcon conNo (vecret_entry conNo)
+ mk_dirret_itbl (dcon, conNo)
+ = mk_itbl dcon conNo stg_interp_constr_entry
+
+ mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
+ mk_itbl dcon conNo entry_addr
+ = let rep_args = [ (typeCgRep arg,arg)
+ | arg <- dataConRepArgTys dcon ]
+ (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
+
+ ptrs = ptr_wds
+ nptrs = tot_wds - ptr_wds
+ nptrs_really
+ | ptrs + nptrs >= mIN_PAYLOAD_SIZE = nptrs
+ | otherwise = mIN_PAYLOAD_SIZE - ptrs
+ itbl = StgInfoTable {
+ ptrs = fromIntegral ptrs,
+ nptrs = fromIntegral nptrs_really,
+ tipe = fromIntegral cONSTR,
+ srtlen = fromIntegral conNo,
+ code = code
+ }
+ -- Make a piece of code to jump to "entry_label".
+ -- This is the only arch-dependent bit.
+ code = mkJumpToAddr entry_addr
+ in
+ do addr <- malloc_exec (sizeOf itbl)
+ --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
+ --putStrLn ("# ptrs of itbl is " ++ show ptrs)
+ --putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
+ poke addr itbl
+ return (getName dcon, addr `plusPtr` (2 * wORD_SIZE))
+
+
+-- Make code which causes a jump to the given address. This is the
+-- only arch-dependent bit of the itbl story. The returned list is
+-- itblCodeLength elements (bytes) long.
+
+-- For sparc_TARGET_ARCH, i386_TARGET_ARCH, etc.
+#include "nativeGen/NCG.h"
+
+itblCodeLength :: Int
+itblCodeLength = length (mkJumpToAddr undefined)
+
+mkJumpToAddr :: Ptr () -> [ItblCode]
+
+ptrToInt (Ptr a#) = I# (addr2Int# a#)
+
+#if sparc_TARGET_ARCH
+-- After some consideration, we'll try this, where
+-- 0x55555555 stands in for the address to jump to.
+-- According to ghc/includes/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
+
+type ItblCode = Word32
+mkJumpToAddr a
+ = let w32 = fromIntegral (ptrToInt a)
+
+ hi22, lo10 :: Word32 -> Word32
+ lo10 x = x .&. 0x3FF
+ hi22 x = (x `shiftR` 10) .&. 0x3FFFF
+
+ in [ 0x07000000 .|. (hi22 w32),
+ 0x8610E000 .|. (lo10 w32),
+ 0x81C0C000,
+ 0x01000000 ]
+
+#elif powerpc_TARGET_ARCH
+-- We'll use r12, for no particular reason.
+-- 0xDEADBEEF stands for the adress:
+-- 3D80DEAD lis r12,0xDEAD
+-- 618CBEEF ori r12,r12,0xBEEF
+-- 7D8903A6 mtctr r12
+-- 4E800420 bctr
+
+type ItblCode = Word32
+mkJumpToAddr a =
+ let w32 = fromIntegral (ptrToInt a)
+ hi16 x = (x `shiftR` 16) .&. 0xFFFF
+ lo16 x = x .&. 0xFFFF
+ in [
+ 0x3D800000 .|. hi16 w32,
+ 0x618C0000 .|. lo16 w32,
+ 0x7D8903A6, 0x4E800420
+ ]
+
+#elif i386_TARGET_ARCH
+-- Let the address to jump to be 0xWWXXYYZZ.
+-- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
+-- which is
+-- B8 ZZ YY XX WW FF E0
+
+type ItblCode = Word8
+mkJumpToAddr a
+ = let w32 = fromIntegral (ptrToInt a) :: Word32
+ insnBytes :: [Word8]
+ insnBytes
+ = [0xB8, byte0 w32, byte1 w32,
+ byte2 w32, byte3 w32,
+ 0xFF, 0xE0]
+ in
+ insnBytes
+
+#elif x86_64_TARGET_ARCH
+-- Generates:
+-- jmpq *.L1(%rip)
+-- .align 8
+-- .L1:
+-- .quad <addr>
+--
+-- 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.
+
+type ItblCode = Word8
+mkJumpToAddr a
+ = let w64 = fromIntegral (ptrToInt 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
+ insnBytes
+
+#elif alpha_TARGET_ARCH
+type ItblCode = Word32
+mkJumpToAddr a
+ = [ 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) ]
+ where w64 = fromIntegral (ptrToInt a) :: Word64
+
+#else
+type ItblCode = Word32
+mkJumpToAddr a
+ = undefined
+#endif
+
+
+byte0, byte1, byte2, byte3, byte4, byte5, byte6, byte7
+ :: (Integral w, Bits w) => w -> Word8
+byte0 w = fromIntegral w
+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)
+
+
+vecret_entry 0 = stg_interp_constr1_entry
+vecret_entry 1 = stg_interp_constr2_entry
+vecret_entry 2 = stg_interp_constr3_entry
+vecret_entry 3 = stg_interp_constr4_entry
+vecret_entry 4 = stg_interp_constr5_entry
+vecret_entry 5 = stg_interp_constr6_entry
+vecret_entry 6 = stg_interp_constr7_entry
+vecret_entry 7 = stg_interp_constr8_entry
+
+#ifndef __HADDOCK__
+-- entry point for direct returns for created constr itbls
+foreign import ccall "&stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
+-- and the 8 vectored ones
+foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: Ptr ()
+foreign import ccall "&stg_interp_constr8_entry" stg_interp_constr8_entry :: Ptr ()
+#endif
+
+
+
+
+-- Ultra-minimalist version specially for constructors
+#if SIZEOF_VOID_P == 8
+type HalfWord = Word32
+#else
+type HalfWord = Word16
+#endif
+
+data StgInfoTable = StgInfoTable {
+ ptrs :: HalfWord,
+ nptrs :: HalfWord,
+ tipe :: HalfWord,
+ srtlen :: HalfWord,
+ code :: [ItblCode]
+}
+
+instance Storable StgInfoTable where
+
+ sizeOf itbl
+ = sum
+ [fieldSz ptrs itbl,
+ fieldSz nptrs itbl,
+ fieldSz tipe itbl,
+ fieldSz srtlen itbl,
+ fieldSz (head.code) itbl * itblCodeLength]
+
+ alignment itbl
+ = SIZEOF_VOID_P
+
+ poke a0 itbl
+ = runState (castPtr a0)
+ $ do store (ptrs itbl)
+ store (nptrs itbl)
+ store (tipe itbl)
+ store (srtlen itbl)
+ sequence_ (map store (code itbl))
+
+ peek a0
+ = runState (castPtr a0)
+ $ do ptrs <- load
+ nptrs <- load
+ tipe <- load
+ srtlen <- load
+ code <- sequence (replicate itblCodeLength load)
+ return
+ StgInfoTable {
+ ptrs = ptrs,
+ nptrs = nptrs,
+ tipe = tipe,
+ srtlen = srtlen,
+ code = code
+ }
+
+fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
+fieldSz sel x = sizeOf (sel x)
+
+newtype State s m a = State (s -> m (s, a))
+
+instance Monad m => Monad (State s m) where
+ return a = State (\s -> return (s, a))
+ State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
+ fail str = State (\s -> fail str)
+
+class (Monad m, Monad (t m)) => MonadT t m where
+ lift :: m a -> t m a
+
+instance Monad m => MonadT (State s) m where
+ lift m = State (\s -> m >>= \a -> return (s, a))
+
+runState :: (Monad m) => s -> State s m a -> m a
+runState s (State m) = m s >>= return . snd
+
+type PtrIO = State (Ptr Word8) IO
+
+advance :: Storable a => PtrIO (Ptr a)
+advance = State adv where
+ adv addr = case castPtr addr of { addrCast -> return
+ (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
+
+sizeOfPointee :: (Storable a) => Ptr a -> Int
+sizeOfPointee addr = sizeOf (typeHack addr)
+ where typeHack = undefined :: Ptr a -> a
+
+store :: Storable a => a -> PtrIO ()
+store x = do addr <- advance
+ lift (poke addr x)
+
+load :: Storable a => PtrIO a
+load = do addr <- advance
+ lift (peek addr)
+
+foreign import ccall unsafe "stgMallocBytesRWX"
+ _stgMallocBytesRWX :: CInt -> IO (Ptr a)
+
+malloc_exec :: Int -> IO (Ptr a)
+malloc_exec bytes = _stgMallocBytesRWX (fromIntegral bytes)
+
+\end{code}
diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs
new file mode 100644
index 0000000000..875f1d6331
--- /dev/null
+++ b/compiler/ghci/ByteCodeLink.lhs
@@ -0,0 +1,268 @@
+%
+% (c) The University of Glasgow 2000
+%
+\section[ByteCodeLink]{Bytecode assembler and linker}
+
+\begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
+module ByteCodeLink (
+ HValue,
+ ClosureEnv, emptyClosureEnv, extendClosureEnv,
+ linkBCO, lookupStaticPtr
+ ) where
+
+#include "HsVersions.h"
+
+import ByteCodeItbls ( ItblEnv, ItblPtr )
+import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
+import ObjLink ( lookupSymbol )
+
+import Name ( Name, nameModule, nameOccName, isExternalName )
+import NameEnv
+import OccName ( occNameFS )
+import PrimOp ( PrimOp, primOpOcc )
+import Module ( moduleFS )
+import FastString ( FastString(..), unpackFS, zEncodeFS )
+import Outputable
+import Panic ( GhcException(..) )
+
+-- Standard libraries
+import GHC.Word ( Word(..) )
+
+import Data.Array.IArray ( listArray )
+import Data.Array.Base
+import GHC.Arr ( STArray(..) )
+
+import Control.Exception ( throwDyn )
+import Control.Monad ( zipWithM )
+import Control.Monad.ST ( stToIO )
+
+import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
+ ByteArray#, Array#, addrToHValue#, mkApUpd0# )
+
+import GHC.Arr ( Array(..) )
+import GHC.IOBase ( IO(..) )
+import GHC.Ptr ( Ptr(..) )
+import GHC.Base ( writeArray#, RealWorld, Int(..) )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Linking interpretables into something we can run}
+%* *
+%************************************************************************
+
+\begin{code}
+type ClosureEnv = NameEnv (Name, HValue)
+newtype HValue = HValue (forall a . a)
+
+emptyClosureEnv = emptyNameEnv
+
+extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
+extendClosureEnv cl_env pairs
+ = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Linking interpretables into something we can run}
+%* *
+%************************************************************************
+
+\begin{code}
+{-
+data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
+ ByteArray# -- literals :: Array Word32#
+ PtrArray# -- ptrs :: Array HValue
+ ByteArray# -- itbls :: Array Addr#
+-}
+
+linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
+linkBCO ie ce ul_bco
+ = do BCO bco# <- linkBCO' ie ce ul_bco
+ -- SDM: Why do we need mkApUpd0 here? I *think* it's because
+ -- otherwise top-level interpreted CAFs don't get updated
+ -- after evaluation. A top-level BCO will evaluate itself and
+ -- return its value when entered, but it won't update itself.
+ -- Wrapping the BCO in an AP_UPD thunk will take care of the
+ -- update for us.
+ --
+ -- Update: the above is true, but now we also have extra invariants:
+ -- (a) An AP thunk *must* point directly to a BCO
+ -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
+ -- (c) An AP is always fully saturated, so we *can't* wrap
+ -- non-zero arity BCOs in an AP thunk.
+ --
+ if (unlinkedBCOArity ul_bco > 0)
+ then return (unsafeCoerce# bco#)
+ else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
+
+
+linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
+ -- Raises an IO exception on failure
+ = do let literals = ssElts literalsSS
+ ptrs = ssElts ptrsSS
+ itbls = ssElts itblsSS
+
+ linked_itbls <- mapM (lookupIE ie) itbls
+ linked_literals <- mapM lookupLiteral literals
+
+ let n_literals = sizeSS literalsSS
+ n_ptrs = sizeSS ptrsSS
+ n_itbls = sizeSS itblsSS
+
+ ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
+
+ let
+ ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
+
+ itbls_arr = listArray (0, n_itbls-1) linked_itbls
+ :: UArray Int ItblPtr
+ itbls_barr = case itbls_arr of UArray lo hi barr -> barr
+
+ literals_arr = listArray (0, n_literals-1) linked_literals
+ :: UArray Int Word
+ literals_barr = case literals_arr of UArray lo hi barr -> barr
+
+ (I# arity#) = arity
+
+ newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
+
+
+-- we recursively link any sub-BCOs while making the ptrs array
+mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
+mkPtrsArray ie ce n_ptrs ptrs = do
+ marr <- newArray_ (0, n_ptrs-1)
+ let
+ fill (BCOPtrName n) i = do
+ ptr <- lookupName ce n
+ unsafeWrite marr i ptr
+ fill (BCOPtrPrimOp op) i = do
+ ptr <- lookupPrimOp op
+ unsafeWrite marr i ptr
+ fill (BCOPtrBCO ul_bco) i = do
+ BCO bco# <- linkBCO' ie ce ul_bco
+ writeArrayBCO marr i bco#
+ zipWithM fill ptrs [0..]
+ unsafeFreeze marr
+
+newtype IOArray i e = IOArray (STArray RealWorld i e)
+
+instance HasBounds IOArray where
+ bounds (IOArray marr) = bounds marr
+
+instance MArray IOArray e IO where
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOArray marr)
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOArray marr)
+ unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
+ unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
+writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
+writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
+ case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
+ (# s#, () #) }
+
+data BCO = BCO BCO#
+
+newBCO :: ByteArray# -> ByteArray# -> Array# a
+ -> ByteArray# -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs itbls arity bitmap
+ = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
+ (# s1, bco #) -> (# s1, BCO bco #)
+
+
+lookupLiteral :: Either Word FastString -> IO Word
+lookupLiteral (Left lit) = return lit
+lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
+ return (W# (unsafeCoerce# addr))
+ -- Can't be bothered to find the official way to convert Addr# to Word#;
+ -- the FFI/Foreign designers make it too damn difficult
+ -- Hence we apply the Blunt Instrument, which works correctly
+ -- on all reasonable architectures anyway
+
+lookupStaticPtr :: FastString -> IO (Ptr ())
+lookupStaticPtr addr_of_label_string
+ = do let label_to_find = unpackFS addr_of_label_string
+ m <- lookupSymbol label_to_find
+ case m of
+ Just ptr -> return ptr
+ Nothing -> linkFail "ByteCodeLink: can't find label"
+ label_to_find
+
+lookupPrimOp :: PrimOp -> IO HValue
+lookupPrimOp primop
+ = do let sym_to_find = primopToCLabel primop "closure"
+ m <- lookupSymbol sym_to_find
+ case m of
+ Just (Ptr addr) -> case addrToHValue# addr of
+ (# hval #) -> return hval
+ Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+
+lookupName :: ClosureEnv -> Name -> IO HValue
+lookupName ce nm
+ = case lookupNameEnv ce nm of
+ Just (_,aa) -> return aa
+ Nothing
+ -> ASSERT2(isExternalName nm, ppr nm)
+ do let sym_to_find = nameToCLabel nm "closure"
+ m <- lookupSymbol sym_to_find
+ case m of
+ Just (Ptr addr) -> case addrToHValue# addr of
+ (# hval #) -> return hval
+ Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
+
+lookupIE :: ItblEnv -> Name -> IO (Ptr a)
+lookupIE ie con_nm
+ = case lookupNameEnv ie con_nm of
+ Just (_, Ptr a) -> return (Ptr a)
+ Nothing
+ -> do -- try looking up in the object files.
+ let sym_to_find1 = nameToCLabel con_nm "con_info"
+ m <- lookupSymbol sym_to_find1
+ case m of
+ Just addr -> return addr
+ Nothing
+ -> do -- perhaps a nullary constructor?
+ let sym_to_find2 = nameToCLabel con_nm "static_info"
+ n <- lookupSymbol sym_to_find2
+ case n of
+ Just addr -> return addr
+ Nothing -> linkFail "ByteCodeLink.lookupIE"
+ (sym_to_find1 ++ " or " ++ sym_to_find2)
+
+linkFail :: String -> String -> IO a
+linkFail who what
+ = throwDyn (ProgramError $
+ unlines [ ""
+ , "During interactive linking, GHCi couldn't find the following symbol:"
+ , ' ' : ' ' : what
+ , "This may be due to you not asking GHCi to load extra object files,"
+ , "archives or DLLs needed by your current session. Restart GHCi, specifying"
+ , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
+ , "flags, or simply by naming the relevant files on the GHCi command line."
+ , "Alternatively, this link failure might indicate a bug in GHCi."
+ , "If you suspect the latter, please send a bug report to:"
+ , " glasgow-haskell-bugs@haskell.org"
+ ])
+
+-- HACKS!!! ToDo: cleaner
+nameToCLabel :: Name -> String{-suffix-} -> String
+nameToCLabel n suffix
+ = unpackFS (zEncodeFS (moduleFS (nameModule n)))
+ ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix
+
+primopToCLabel :: PrimOp -> String{-suffix-} -> String
+primopToCLabel primop suffix
+ = let str = "GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
+ in --trace ("primopToCLabel: " ++ str)
+ str
+\end{code}
+
diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
new file mode 100644
index 0000000000..9e9c262052
--- /dev/null
+++ b/compiler/ghci/InteractiveUI.hs
@@ -0,0 +1,1534 @@
+{-# OPTIONS -#include "Linker.h" #-}
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive User Interface
+--
+-- (c) The GHC Team 2005
+--
+-----------------------------------------------------------------------------
+module InteractiveUI (
+ interactiveUI,
+ ghciWelcomeMsg
+ ) where
+
+#include "HsVersions.h"
+
+#if defined(GHCI) && defined(BREAKPOINT)
+import GHC.Exts ( Int(..), Ptr(..), int2Addr# )
+import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
+import System.IO.Unsafe ( unsafePerformIO )
+import Var ( Id, globaliseId, idName, idType )
+import HscTypes ( Session(..), InteractiveContext(..), HscEnv(..)
+ , extendTypeEnvWithIds )
+import RdrName ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
+import NameEnv ( delListFromNameEnv )
+import TcType ( tidyTopType )
+import qualified Id ( setIdType )
+import IdInfo ( GlobalIdDetails(..) )
+import Linker ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker )
+import PrelNames ( breakpointJumpName )
+#endif
+
+-- The GHC interface
+import qualified GHC
+import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..),
+ TargetId(..), DynFlags(..),
+ pprModule, Type, Module, SuccessFlag(..),
+ TyThing(..), Name, LoadHowMuch(..), Phase,
+ GhcException(..), showGhcException,
+ CheckedModule(..), SrcLoc )
+import DynFlags ( allFlags )
+import Packages ( PackageState(..) )
+import PackageConfig ( InstalledPackageInfo(..) )
+import UniqFM ( eltsUFM )
+import PprTyThing
+import Outputable
+
+-- for createtags (should these come via GHC?)
+import Module ( moduleString )
+import Name ( nameSrcLoc, nameModule, nameOccName )
+import OccName ( pprOccName )
+import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+
+-- Other random utilities
+import Digraph ( flattenSCCs )
+import BasicTypes ( failed, successIf )
+import Panic ( panic, installSignalHandlers )
+import Config
+import StaticFlags ( opt_IgnoreDotGhci )
+import Linker ( showLinkerState )
+import Util ( removeSpaces, handle, global, toArgs,
+ looksLikeModuleName, prefixMatch, sortLe )
+
+#ifndef mingw32_HOST_OS
+import System.Posix
+#if __GLASGOW_HASKELL__ > 504
+ hiding (getEnv)
+#endif
+#else
+import GHC.ConsoleHandler ( flushConsole )
+#endif
+
+#ifdef USE_READLINE
+import Control.Concurrent ( yield ) -- Used in readline loop
+import System.Console.Readline as Readline
+#endif
+
+--import SystemExts
+
+import Control.Exception as Exception
+import Data.Dynamic
+-- import Control.Concurrent
+
+import Numeric
+import Data.List
+import Data.Int ( Int64 )
+import Data.Maybe ( isJust, fromMaybe, catMaybes )
+import System.Cmd
+import System.CPUTime
+import System.Environment
+import System.Exit ( exitWith, ExitCode(..) )
+import System.Directory
+import System.IO
+import System.IO.Error as IO
+import Data.Char
+import Control.Monad as Monad
+import Foreign.StablePtr ( newStablePtr )
+import Text.Printf
+
+import GHC.Exts ( unsafeCoerce# )
+import GHC.IOBase ( IOErrorType(InvalidArgument) )
+
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+
+import System.Posix.Internals ( setNonBlockingFD )
+
+-----------------------------------------------------------------------------
+
+ghciWelcomeMsg =
+ " ___ ___ _\n"++
+ " / _ \\ /\\ /\\/ __(_)\n"++
+ " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
+ "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
+ "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
+
+type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+cmdName (n,_,_,_) = n
+
+GLOBAL_VAR(commands, builtin_commands, [Command])
+
+builtin_commands :: [Command]
+builtin_commands = [
+ ("add", keepGoingPaths addModule, False, completeFilename),
+ ("browse", keepGoing browseCmd, False, completeModule),
+ ("cd", keepGoing changeDirectory, False, completeFilename),
+ ("def", keepGoing defineMacro, False, completeIdentifier),
+ ("help", keepGoing help, False, completeNone),
+ ("?", keepGoing help, False, completeNone),
+ ("info", keepGoing info, False, completeIdentifier),
+ ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
+ ("module", keepGoing setContext, False, completeModule),
+ ("main", keepGoing runMain, False, completeIdentifier),
+ ("reload", keepGoing reloadModule, False, completeNone),
+ ("check", keepGoing checkModule, False, completeHomeModule),
+ ("set", keepGoing setCmd, True, completeSetOptions),
+ ("show", keepGoing showCmd, False, completeNone),
+ ("etags", keepGoing createETagsFileCmd, False, completeFilename),
+ ("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
+ ("type", keepGoing typeOfExpr, False, completeIdentifier),
+ ("kind", keepGoing kindOfType, False, completeIdentifier),
+ ("unset", keepGoing unsetOptions, True, completeSetOptions),
+ ("undef", keepGoing undefineMacro, False, completeMacro),
+ ("quit", quit, False, completeNone)
+ ]
+
+keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
+keepGoing a str = a str >> return False
+
+keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
+keepGoingPaths a str = a (toArgs str) >> return False
+
+shortHelpText = "use :? for help.\n"
+
+-- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
+helpText =
+ " Commands available from the prompt:\n" ++
+ "\n" ++
+ " <stmt> evaluate/run <stmt>\n" ++
+ " :add <filename> ... add module(s) to the current target set\n" ++
+ " :browse [*]<module> display the names defined by <module>\n" ++
+ " :cd <dir> change directory to <dir>\n" ++
+ " :def <cmd> <expr> define a command :<cmd>\n" ++
+ " :help, :? display this list of commands\n" ++
+ " :info [<name> ...] display information about the given names\n" ++
+ " :load <filename> ... load module(s) and their dependents\n" ++
+ " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
+ " :main [<arguments> ...] run the main function with the given arguments\n" ++
+ " :reload reload the current module set\n" ++
+ "\n" ++
+ " :set <option> ... set options\n" ++
+ " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
+ " :set prog <progname> set the value returned by System.getProgName\n" ++
+ " :set prompt <prompt> set the prompt used in GHCi\n" ++
+ "\n" ++
+ " :show modules show the currently loaded modules\n" ++
+ " :show bindings show the current bindings made at the prompt\n" ++
+ "\n" ++
+ " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
+ " :etags [<file>] create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ " :type <expr> show the type of <expr>\n" ++
+ " :kind <type> show the kind of <type>\n" ++
+ " :undef <cmd> undefine user-defined command :<cmd>\n" ++
+ " :unset <option> ... unset options\n" ++
+ " :quit exit GHCi\n" ++
+ " :!<command> run the shell command <command>\n" ++
+ "\n" ++
+ " Options for ':set' and ':unset':\n" ++
+ "\n" ++
+ " +r revert top-level expressions after each evaluation\n" ++
+ " +s print timing/memory stats after each evaluation\n" ++
+ " +t print type after evaluation\n" ++
+ " -<flags> most GHC command line flags can also be set here\n" ++
+ " (eg. -v2, -fglasgow-exts, etc.)\n"
+
+
+#if defined(GHCI) && defined(BREAKPOINT)
+globaliseAndTidy :: Id -> Id
+globaliseAndTidy id
+-- Give the Id a Global Name, and tidy its type
+ = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
+ where
+ tidy_type = tidyTopType (idType id)
+
+
+printScopeMsg :: Session -> String -> [Id] -> IO ()
+printScopeMsg session location ids
+ = GHC.getPrintUnqual session >>= \unqual ->
+ printForUser stdout unqual $
+ text "Local bindings in scope:" $$
+ nest 2 (pprWithCommas showId ids)
+ where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
+
+jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
+jumpFunction session@(Session ref) (I# idsPtr) hValues location b
+ = unsafePerformIO $
+ do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
+ let names = map idName ids
+ ASSERT (length names == length hValues) return ()
+ printScopeMsg session location ids
+ hsc_env <- readIORef ref
+
+ let ictxt = hsc_IC hsc_env
+ global_ids = map globaliseAndTidy ids
+ rn_env = ic_rn_local_env ictxt
+ type_env = ic_type_env ictxt
+ bound_names = map idName global_ids
+ new_rn_env = extendLocalRdrEnv rn_env bound_names
+ -- Remove any shadowed bindings from the type_env;
+ -- they are inaccessible but might, I suppose, cause
+ -- a space leak if we leave them there
+ shadowed = [ n | name <- bound_names,
+ let rdr_name = mkRdrUnqual (nameOccName name),
+ Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+ filtered_type_env = delListFromNameEnv type_env shadowed
+ new_type_env = extendTypeEnvWithIds filtered_type_env global_ids
+ new_ic = ictxt { ic_rn_local_env = new_rn_env,
+ ic_type_env = new_type_env }
+ writeIORef ref (hsc_env { hsc_IC = new_ic })
+ withExtendedLinkEnv (zip names hValues) $
+ startGHCi (runGHCi [] Nothing)
+ GHCiState{ progname = "<interactive>",
+ args = [],
+ prompt = location++"> ",
+ session = session,
+ options = [] }
+ writeIORef ref hsc_env
+ putStrLn $ "Returning to normal execution..."
+ return b
+#endif
+
+interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
+interactiveUI session srcs maybe_expr = do
+#if defined(GHCI) && defined(BREAKPOINT)
+ initDynLinker =<< GHC.getSessionDynFlags session
+ extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))]
+#endif
+ -- HACK! If we happen to get into an infinite loop (eg the user
+ -- types 'let x=x in x' at the prompt), then the thread will block
+ -- on a blackhole, and become unreachable during GC. The GC will
+ -- detect that it is unreachable and send it the NonTermination
+ -- exception. However, since the thread is unreachable, everything
+ -- it refers to might be finalized, including the standard Handles.
+ -- This sounds like a bug, but we don't have a good solution right
+ -- now.
+ newStablePtr stdin
+ newStablePtr stdout
+ newStablePtr stderr
+
+ hFlush stdout
+ hSetBuffering stdout NoBuffering
+
+ -- Initialise buffering for the *interpreted* I/O system
+ initInterpBuffering session
+
+ -- We don't want the cmd line to buffer any input that might be
+ -- intended for the program, so unbuffer stdin.
+ hSetBuffering stdin NoBuffering
+
+ -- initial context is just the Prelude
+ GHC.setContext session [] [prelude_mod]
+
+#ifdef USE_READLINE
+ Readline.initialize
+ Readline.setAttemptedCompletionFunction (Just completeWord)
+ --Readline.parseAndBind "set show-all-if-ambiguous 1"
+
+ let symbols = "!#$%&*+/<=>?@\\^|-~"
+ specials = "(),;[]`{}"
+ spaces = " \t\n"
+ word_break_chars = spaces ++ specials ++ symbols
+
+ Readline.setBasicWordBreakCharacters word_break_chars
+ Readline.setCompleterWordBreakCharacters word_break_chars
+#endif
+
+ startGHCi (runGHCi srcs maybe_expr)
+ GHCiState{ progname = "<interactive>",
+ args = [],
+ prompt = "%s> ",
+ session = session,
+ options = [] }
+
+#ifdef USE_READLINE
+ Readline.resetTerminal Nothing
+#endif
+
+ return ()
+
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
+runGHCi paths maybe_expr = do
+ let read_dot_files = not opt_IgnoreDotGhci
+
+ when (read_dot_files) $ do
+ -- Read in ./.ghci.
+ let file = "./.ghci"
+ exists <- io (doesFileExist file)
+ when exists $ do
+ dir_ok <- io (checkPerms ".")
+ file_ok <- io (checkPerms file)
+ when (dir_ok && file_ok) $ do
+ either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
+ case either_hdl of
+ Left e -> return ()
+ Right hdl -> fileLoop hdl False
+
+ when (read_dot_files) $ do
+ -- Read in $HOME/.ghci
+ either_dir <- io (IO.try (getEnv "HOME"))
+ case either_dir of
+ Left e -> return ()
+ Right dir -> do
+ cwd <- io (getCurrentDirectory)
+ when (dir /= cwd) $ do
+ let file = dir ++ "/.ghci"
+ ok <- io (checkPerms file)
+ when ok $ do
+ either_hdl <- io (IO.try (openFile file ReadMode))
+ case either_hdl of
+ Left e -> return ()
+ Right hdl -> fileLoop hdl False
+
+ -- Perform a :load for files given on the GHCi command line
+ -- When in -e mode, if the load fails then we want to stop
+ -- immediately rather than going on to evaluate the expression.
+ when (not (null paths)) $ do
+ ok <- ghciHandle (\e -> do showException e; return Failed) $
+ loadModule paths
+ when (isJust maybe_expr && failed ok) $
+ io (exitWith (ExitFailure 1))
+
+ -- if verbosity is greater than 0, or we are connected to a
+ -- terminal, display the prompt in the interactive loop.
+ is_tty <- io (hIsTerminalDevice stdin)
+ dflags <- getDynFlags
+ let show_prompt = verbosity dflags > 0 || is_tty
+
+ case maybe_expr of
+ Nothing ->
+#if defined(mingw32_HOST_OS)
+ do
+ -- The win32 Console API mutates the first character of
+ -- type-ahead when reading from it in a non-buffered manner. Work
+ -- around this by flushing the input buffer of type-ahead characters,
+ -- but only if stdin is available.
+ flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
+ case flushed of
+ Left err | isDoesNotExistError err -> return ()
+ | otherwise -> io (ioError err)
+ Right () -> return ()
+#endif
+ -- enter the interactive loop
+ interactiveLoop is_tty show_prompt
+ Just expr -> do
+ -- just evaluate the expression we were given
+ runCommandEval expr
+ return ()
+
+ -- and finally, exit
+ io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+
+
+interactiveLoop is_tty show_prompt =
+ -- Ignore ^C exceptions caught here
+ ghciHandleDyn (\e -> case e of
+ Interrupted -> do
+#if defined(mingw32_HOST_OS)
+ io (putStrLn "")
+#endif
+ interactiveLoop is_tty show_prompt
+ _other -> return ()) $
+
+ ghciUnblock $ do -- unblock necessary if we recursed from the
+ -- exception handler above.
+
+ -- read commands from stdin
+#ifdef USE_READLINE
+ if (is_tty)
+ then readlineLoop
+ else fileLoop stdin show_prompt
+#else
+ fileLoop stdin show_prompt
+#endif
+
+
+-- NOTE: We only read .ghci files if they are owned by the current user,
+-- and aren't world writable. Otherwise, we could be accidentally
+-- running code planted by a malicious third party.
+
+-- Furthermore, We only read ./.ghci if . is owned by the current user
+-- and isn't writable by anyone else. I think this is sufficient: we
+-- don't need to check .. and ../.. etc. because "." always refers to
+-- the same directory while a process is running.
+
+checkPerms :: String -> IO Bool
+checkPerms name =
+#ifdef mingw32_HOST_OS
+ return True
+#else
+ Util.handle (\_ -> return False) $ do
+ st <- getFileStatus name
+ me <- getRealUserID
+ if fileOwner st /= me then do
+ putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
+ return False
+ else do
+ let mode = fileMode st
+ if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
+ || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
+ then do
+ putStrLn $ "*** WARNING: " ++ name ++
+ " is writable by someone else, IGNORING!"
+ return False
+ else return True
+#endif
+
+fileLoop :: Handle -> Bool -> GHCi ()
+fileLoop hdl show_prompt = do
+ session <- getSession
+ (mod,imports) <- io (GHC.getContext session)
+ st <- getGHCiState
+ when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
+ l <- io (IO.try (hGetLine hdl))
+ case l of
+ Left e | isEOFError e -> return ()
+ | InvalidArgument <- etype -> return ()
+ | otherwise -> io (ioError e)
+ where etype = ioeGetErrorType e
+ -- treat InvalidArgument in the same way as EOF:
+ -- this can happen if the user closed stdin, or
+ -- perhaps did getContents which closes stdin at
+ -- EOF.
+ Right l ->
+ case removeSpaces l of
+ "" -> fileLoop hdl show_prompt
+ l -> do quit <- runCommand l
+ if quit then return () else fileLoop hdl show_prompt
+
+stringLoop :: [String] -> GHCi ()
+stringLoop [] = return ()
+stringLoop (s:ss) = do
+ case removeSpaces s of
+ "" -> stringLoop ss
+ l -> do quit <- runCommand l
+ if quit then return () else stringLoop ss
+
+mkPrompt toplevs exports prompt
+ = showSDoc $ f prompt
+ where
+ f ('%':'s':xs) = perc_s <> f xs
+ f ('%':'%':xs) = char '%' <> f xs
+ f (x:xs) = char x <> f xs
+ f [] = empty
+
+ perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
+ hsep (map pprModule exports)
+
+
+#ifdef USE_READLINE
+readlineLoop :: GHCi ()
+readlineLoop = do
+ session <- getSession
+ (mod,imports) <- io (GHC.getContext session)
+ io yield
+ saveSession -- for use by completion
+ st <- getGHCiState
+ l <- io (readline (mkPrompt mod imports (prompt st))
+ `finally` setNonBlockingFD 0)
+ -- readline sometimes puts stdin into blocking mode,
+ -- so we need to put it back for the IO library
+ splatSavedSession
+ case l of
+ Nothing -> return ()
+ Just l ->
+ case removeSpaces l of
+ "" -> readlineLoop
+ l -> do
+ io (addHistory l)
+ quit <- runCommand l
+ if quit then return () else readlineLoop
+#endif
+
+runCommand :: String -> GHCi Bool
+runCommand c = ghciHandle handler (doCommand c)
+ where
+ doCommand (':' : command) = specialCommand command
+ doCommand stmt
+ = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
+ return False
+
+-- This version is for the GHC command-line option -e. The only difference
+-- from runCommand is that it catches the ExitException exception and
+-- exits, rather than printing out the exception.
+runCommandEval c = ghciHandle handleEval (doCommand c)
+ where
+ handleEval (ExitException code) = io (exitWith code)
+ handleEval e = do showException e
+ io (exitWith (ExitFailure 1))
+
+ doCommand (':' : command) = specialCommand command
+ doCommand stmt
+ = do nms <- runStmt stmt
+ case nms of
+ Nothing -> io (exitWith (ExitFailure 1))
+ -- failure to run the command causes exit(1) for ghc -e.
+ _ -> finishEvalExpr nms
+
+-- This is the exception handler for exceptions generated by the
+-- user's code; it normally just prints out the exception. The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception. We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
+handler exception = do
+ flushInterpBuffers
+ io installSignalHandlers
+ ghciHandle handler (showException exception >> return False)
+
+showException (DynException dyn) =
+ case fromDynamic dyn of
+ Nothing -> io (putStrLn ("*** Exception: (unknown)"))
+ Just Interrupted -> io (putStrLn "Interrupted.")
+ Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
+ Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
+ Just other_ghc_ex -> io (print other_ghc_ex)
+
+showException other_exception
+ = io (putStrLn ("*** Exception: " ++ show other_exception))
+
+runStmt :: String -> GHCi (Maybe [Name])
+runStmt stmt
+ | null (filter (not.isSpace) stmt) = return (Just [])
+ | otherwise
+ = do st <- getGHCiState
+ session <- getSession
+ result <- io $ withProgName (progname st) $ withArgs (args st) $
+ GHC.runStmt session stmt
+ case result of
+ GHC.RunFailed -> return Nothing
+ GHC.RunException e -> throw e -- this is caught by runCommand(Eval)
+ GHC.RunOk names -> return (Just names)
+
+-- possibly print the type and revert CAFs after evaluating an expression
+finishEvalExpr mb_names
+ = do b <- isOptionSet ShowType
+ session <- getSession
+ case mb_names of
+ Nothing -> return ()
+ Just names -> when b (mapM_ (showTypeOfName session) names)
+
+ flushInterpBuffers
+ io installSignalHandlers
+ b <- isOptionSet RevertCAFs
+ io (when b revertCAFs)
+ return True
+
+showTypeOfName :: Session -> Name -> GHCi ()
+showTypeOfName session n
+ = do maybe_tything <- io (GHC.lookupName session n)
+ case maybe_tything of
+ Nothing -> return ()
+ Just thing -> showTyThing thing
+
+showForUser :: SDoc -> GHCi String
+showForUser doc = do
+ session <- getSession
+ unqual <- io (GHC.getPrintUnqual session)
+ return $! showSDocForUser unqual doc
+
+specialCommand :: String -> GHCi Bool
+specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
+specialCommand str = do
+ let (cmd,rest) = break isSpace str
+ maybe_cmd <- io (lookupCommand cmd)
+ case maybe_cmd of
+ Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
+ ++ shortHelpText) >> return False)
+ Just (_,f,_,_) -> f (dropWhile isSpace rest)
+
+lookupCommand :: String -> IO (Maybe Command)
+lookupCommand str = do
+ cmds <- readIORef commands
+ -- look for exact match first, then the first prefix match
+ case [ c | c <- cmds, str == cmdName c ] of
+ c:_ -> return (Just c)
+ [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+ [] -> return Nothing
+ c:_ -> return (Just c)
+
+-----------------------------------------------------------------------------
+-- To flush buffers for the *interpreted* computation we need
+-- to refer to *its* stdout/stderr handles
+
+GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
+GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
+
+no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
+ " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
+flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
+
+initInterpBuffering :: Session -> IO ()
+initInterpBuffering session
+ = do maybe_hval <- GHC.compileExpr session no_buf_cmd
+
+ case maybe_hval of
+ Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
+ other -> panic "interactiveUI:setBuffering"
+
+ maybe_hval <- GHC.compileExpr session flush_cmd
+ case maybe_hval of
+ Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
+ _ -> panic "interactiveUI:flush"
+
+ turnOffBuffering -- Turn it off right now
+
+ return ()
+
+
+flushInterpBuffers :: GHCi ()
+flushInterpBuffers
+ = io $ do Monad.join (readIORef flush_interp)
+ return ()
+
+turnOffBuffering :: IO ()
+turnOffBuffering
+ = do Monad.join (readIORef turn_off_buffering)
+ return ()
+
+-----------------------------------------------------------------------------
+-- Commands
+
+help :: String -> GHCi ()
+help _ = io (putStr helpText)
+
+info :: String -> GHCi ()
+info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info s = do { let names = words s
+ ; session <- getSession
+ ; dflags <- getDynFlags
+ ; let exts = dopt Opt_GlasgowExts dflags
+ ; mapM_ (infoThing exts session) names }
+ where
+ infoThing exts session str = io $ do
+ names <- GHC.parseName session str
+ let filtered = filterOutChildren names
+ mb_stuffs <- mapM (GHC.getInfo session) filtered
+ unqual <- GHC.getPrintUnqual session
+ putStrLn (showSDocForUser unqual $
+ vcat (intersperse (text "") $
+ [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+
+ -- Filter out names whose parent is also there Good
+ -- example is '[]', which is both a type and data
+ -- constructor in the same type
+filterOutChildren :: [Name] -> [Name]
+filterOutChildren names = filter (not . parent_is_there) names
+ where parent_is_there n
+ | Just p <- GHC.nameParent_maybe n = p `elem` names
+ | otherwise = False
+
+pprInfo exts (thing, fixity, insts)
+ = pprTyThingInContextLoc exts thing
+ $$ show_fixity fixity
+ $$ vcat (map GHC.pprInstance insts)
+ where
+ show_fixity fix
+ | fix == GHC.defaultFixity = empty
+ | otherwise = ppr fix <+> ppr (GHC.getName thing)
+
+-----------------------------------------------------------------------------
+-- Commands
+
+runMain :: String -> GHCi ()
+runMain args = do
+ let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
+ runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
+ return ()
+
+addModule :: [FilePath] -> GHCi ()
+addModule files = do
+ io (revertCAFs) -- always revert CAFs on load/add.
+ files <- mapM expandPath files
+ targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
+ session <- getSession
+ io (mapM_ (GHC.addTarget session) targets)
+ ok <- io (GHC.load session LoadAllTargets)
+ afterLoad ok session
+
+changeDirectory :: String -> GHCi ()
+changeDirectory dir = do
+ session <- getSession
+ graph <- io (GHC.getModuleGraph session)
+ when (not (null graph)) $
+ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
+ io (GHC.setTargets session [])
+ io (GHC.load session LoadAllTargets)
+ setContextAfterLoad session []
+ io (GHC.workingDirectoryChanged session)
+ dir <- expandPath dir
+ io (setCurrentDirectory dir)
+
+defineMacro :: String -> GHCi ()
+defineMacro s = do
+ let (macro_name, definition) = break isSpace s
+ cmds <- io (readIORef commands)
+ if (null macro_name)
+ then throwDyn (CmdLineError "invalid macro name")
+ else do
+ if (macro_name `elem` map cmdName cmds)
+ then throwDyn (CmdLineError
+ ("command '" ++ macro_name ++ "' is already defined"))
+ else do
+
+ -- give the expression a type signature, so we can be sure we're getting
+ -- something of the right type.
+ let new_expr = '(' : definition ++ ") :: String -> IO String"
+
+ -- compile the expression
+ cms <- getSession
+ maybe_hv <- io (GHC.compileExpr cms new_expr)
+ case maybe_hv of
+ Nothing -> return ()
+ Just hv -> io (writeIORef commands --
+ (cmds ++ [(macro_name, keepGoing (runMacro hv), False, completeNone)]))
+
+runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi ()
+runMacro fun s = do
+ str <- io ((unsafeCoerce# fun :: String -> IO String) s)
+ stringLoop (lines str)
+
+undefineMacro :: String -> GHCi ()
+undefineMacro macro_name = do
+ cmds <- io (readIORef commands)
+ if (macro_name `elem` map cmdName builtin_commands)
+ then throwDyn (CmdLineError
+ ("command '" ++ macro_name ++ "' cannot be undefined"))
+ else do
+ if (macro_name `notElem` map cmdName cmds)
+ then throwDyn (CmdLineError
+ ("command '" ++ macro_name ++ "' not defined"))
+ else do
+ io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+
+
+loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
+loadModule fs = timeIt (loadModule' fs)
+
+loadModule_ :: [FilePath] -> GHCi ()
+loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
+
+loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
+loadModule' files = do
+ session <- getSession
+
+ -- unload first
+ io (GHC.setTargets session [])
+ io (GHC.load session LoadAllTargets)
+
+ -- expand tildes
+ let (filenames, phases) = unzip files
+ exp_filenames <- mapM expandPath filenames
+ let files' = zip exp_filenames phases
+ targets <- io (mapM (uncurry GHC.guessTarget) files')
+
+ -- NOTE: we used to do the dependency anal first, so that if it
+ -- fails we didn't throw away the current set of modules. This would
+ -- require some re-working of the GHC interface, so we'll leave it
+ -- as a ToDo for now.
+
+ io (GHC.setTargets session targets)
+ ok <- io (GHC.load session LoadAllTargets)
+ afterLoad ok session
+ return ok
+
+checkModule :: String -> GHCi ()
+checkModule m = do
+ let modl = GHC.mkModule m
+ session <- getSession
+ result <- io (GHC.checkModule session modl)
+ case result of
+ Nothing -> io $ putStrLn "Nothing"
+ Just r -> io $ putStrLn (showSDoc (
+ case checkedModuleInfo r of
+ Just cm | Just scope <- GHC.modInfoTopLevelScope cm ->
+ let
+ (local,global) = partition ((== modl) . GHC.nameModule) scope
+ in
+ (text "global names: " <+> ppr global) $$
+ (text "local names: " <+> ppr local)
+ _ -> empty))
+ afterLoad (successIf (isJust result)) session
+
+reloadModule :: String -> GHCi ()
+reloadModule "" = do
+ io (revertCAFs) -- always revert CAFs on reload.
+ session <- getSession
+ ok <- io (GHC.load session LoadAllTargets)
+ afterLoad ok session
+reloadModule m = do
+ io (revertCAFs) -- always revert CAFs on reload.
+ session <- getSession
+ ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
+ afterLoad ok session
+
+afterLoad ok session = do
+ io (revertCAFs) -- always revert CAFs on load.
+ graph <- io (GHC.getModuleGraph session)
+ graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
+ setContextAfterLoad session graph'
+ modulesLoadedMsg ok (map GHC.ms_mod graph')
+#if defined(GHCI) && defined(BREAKPOINT)
+ io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))])
+#endif
+
+setContextAfterLoad session [] = do
+ io (GHC.setContext session [] [prelude_mod])
+setContextAfterLoad session ms = do
+ -- load a target if one is available, otherwise load the topmost module.
+ targets <- io (GHC.getTargets session)
+ case [ m | Just m <- map (findTarget ms) targets ] of
+ [] ->
+ let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
+ load_this (last graph')
+ (m:_) ->
+ load_this m
+ where
+ findTarget ms t
+ = case filter (`matches` t) ms of
+ [] -> Nothing
+ (m:_) -> Just m
+
+ summary `matches` Target (TargetModule m) _
+ = GHC.ms_mod summary == m
+ summary `matches` Target (TargetFile f _) _
+ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
+ summary `matches` target
+ = False
+
+ load_this summary | m <- GHC.ms_mod summary = do
+ b <- io (GHC.moduleIsInterpreted session m)
+ if b then io (GHC.setContext session [m] [])
+ else io (GHC.setContext session [] [prelude_mod,m])
+
+
+modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
+modulesLoadedMsg ok mods = do
+ dflags <- getDynFlags
+ when (verbosity dflags > 0) $ do
+ let mod_commas
+ | null mods = text "none."
+ | otherwise = hsep (
+ punctuate comma (map pprModule mods)) <> text "."
+ case ok of
+ Failed ->
+ io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
+ Succeeded ->
+ io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
+
+
+typeOfExpr :: String -> GHCi ()
+typeOfExpr str
+ = do cms <- getSession
+ maybe_ty <- io (GHC.exprType cms str)
+ case maybe_ty of
+ Nothing -> return ()
+ Just ty -> do ty' <- cleanType ty
+ tystr <- showForUser (ppr ty')
+ io (putStrLn (str ++ " :: " ++ tystr))
+
+kindOfType :: String -> GHCi ()
+kindOfType str
+ = do cms <- getSession
+ maybe_ty <- io (GHC.typeKind cms str)
+ case maybe_ty of
+ Nothing -> return ()
+ Just ty -> do tystr <- showForUser (ppr ty)
+ io (putStrLn (str ++ " :: " ++ tystr))
+
+quit :: String -> GHCi Bool
+quit _ = return True
+
+shellEscape :: String -> GHCi Bool
+shellEscape str = io (system str >> return False)
+
+-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
+
+createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
+createCTagsFileCmd file = ghciCreateTagsFile CTags file
+
+createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
+createETagsFileCmd file = ghciCreateTagsFile ETags file
+
+data TagsKind = ETags | CTags
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+ session <- getSession
+ io $ createTagsFile session kind file
+
+-- ToDo:
+-- - remove restriction that all modules must be interpreted
+-- (problem: we don't know source locations for entities unless
+-- we compiled the module.
+--
+-- - extract createTagsFile so it can be used from the command-line
+-- (probably need to fix first problem before this is useful).
+--
+createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
+createTagsFile session tagskind tagFile = do
+ graph <- GHC.getModuleGraph session
+ let ms = map GHC.ms_mod graph
+ tagModule m = do
+ is_interpreted <- GHC.moduleIsInterpreted session m
+ -- should we just skip these?
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
+
+ mbModInfo <- GHC.getModuleInfo session m
+ let unqual
+ | Just modinfo <- mbModInfo,
+ Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
+ | otherwise = GHC.alwaysQualify
+
+ case mbModInfo of
+ Just modInfo -> return $! listTags unqual modInfo
+ _ -> return []
+
+ mtags <- mapM tagModule ms
+ either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
+ case either_res of
+ Left e -> hPutStrLn stderr $ ioeGetErrorString e
+ Right _ -> return ()
+
+listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
+listTags unqual modInfo =
+ [ tagInfo unqual name loc
+ | name <- GHC.modInfoExports modInfo
+ , let loc = nameSrcLoc name
+ , isGoodSrcLoc loc
+ ]
+
+type TagInfo = (String -- tag name
+ ,String -- file name
+ ,Int -- line number
+ ,Int -- column number
+ )
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
+tagInfo unqual name loc
+ = ( showSDocForUser unqual $ pprOccName (nameOccName name)
+ , showSDocForUser unqual $ ftext (srcLocFile loc)
+ , srcLocLine loc
+ , srcLocCol loc
+ )
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
+ let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
+ IO.try (writeFile file tags)
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+ let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
+ groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
+ tagGroups <- mapM tagFileGroup groups
+ IO.try (writeFile file $ concat tagGroups)
+ where
+ tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
+ tagFileGroup group@((_,fileName,_,_):_) = do
+ file <- readFile fileName -- need to get additional info from sources..
+ let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
+ sortedGroup = sortLe byLine group
+ tags = unlines $ perFile sortedGroup 1 0 $ lines file
+ return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
+ perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
+ perFile (tagInfo:tags) (count+1) (pos+length line) lines
+ perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
+ showETag tagInfo line pos : perFile tags count pos lines
+ perFile tags count pos lines = []
+
+-- simple ctags format, for Vim et al
+showTag :: TagInfo -> String
+showTag (tag,file,lineNo,colNo)
+ = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String -> Int -> String
+showETag (tag,file,lineNo,colNo) line charPos
+ = take colNo line ++ tag
+ ++ "\x7f" ++ tag
+ ++ "\x01" ++ show lineNo
+ ++ "," ++ show charPos
+
+-----------------------------------------------------------------------------
+-- Browsing a module's contents
+
+browseCmd :: String -> GHCi ()
+browseCmd m =
+ case words m of
+ ['*':m] | looksLikeModuleName m -> browseModule m False
+ [m] | looksLikeModuleName m -> browseModule m True
+ _ -> throwDyn (CmdLineError "syntax: :browse <module>")
+
+browseModule m exports_only = do
+ s <- getSession
+
+ let modl = GHC.mkModule m
+ is_interpreted <- io (GHC.moduleIsInterpreted s modl)
+ when (not is_interpreted && not exports_only) $
+ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+
+ -- Temporarily set the context to the module we're interested in,
+ -- just so we can get an appropriate PrintUnqualified
+ (as,bs) <- io (GHC.getContext s)
+ io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
+ else GHC.setContext s [modl] [])
+ unqual <- io (GHC.getPrintUnqual s)
+ io (GHC.setContext s as bs)
+
+ mb_mod_info <- io $ GHC.getModuleInfo s modl
+ case mb_mod_info of
+ Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ Just mod_info -> do
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
+
+ filtered = filterOutChildren names
+
+ things <- io $ mapM (GHC.lookupName s) filtered
+
+ dflags <- getDynFlags
+ let exts = dopt Opt_GlasgowExts dflags
+ io (putStrLn (showSDocForUser unqual (
+ vcat (map (pprTyThingInContext exts) (catMaybes things))
+ )))
+ -- ToDo: modInfoInstances currently throws an exception for
+ -- package modules. When it works, we can do this:
+ -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+
+-----------------------------------------------------------------------------
+-- Setting the module context
+
+setContext str
+ | all sensible mods = fn mods
+ | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
+ where
+ (fn, mods) = case str of
+ '+':stuff -> (addToContext, words stuff)
+ '-':stuff -> (removeFromContext, words stuff)
+ stuff -> (newContext, words stuff)
+
+ sensible ('*':m) = looksLikeModuleName m
+ sensible m = looksLikeModuleName m
+
+newContext mods = do
+ session <- getSession
+ (as,bs) <- separate session mods [] []
+ let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
+ io (GHC.setContext session as bs')
+
+separate :: Session -> [String] -> [Module] -> [Module]
+ -> GHCi ([Module],[Module])
+separate session [] as bs = return (as,bs)
+separate session (('*':m):ms) as bs = do
+ let modl = GHC.mkModule m
+ b <- io (GHC.moduleIsInterpreted session modl)
+ if b then separate session ms (modl:as) bs
+ else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs)
+
+prelude_mod = GHC.mkModule "Prelude"
+
+
+addToContext mods = do
+ cms <- getSession
+ (as,bs) <- io (GHC.getContext cms)
+
+ (as',bs') <- separate cms mods [] []
+
+ let as_to_add = as' \\ (as ++ bs)
+ bs_to_add = bs' \\ (as ++ bs)
+
+ io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
+
+
+removeFromContext mods = do
+ cms <- getSession
+ (as,bs) <- io (GHC.getContext cms)
+
+ (as_to_remove,bs_to_remove) <- separate cms mods [] []
+
+ let as' = as \\ (as_to_remove ++ bs_to_remove)
+ bs' = bs \\ (as_to_remove ++ bs_to_remove)
+
+ io (GHC.setContext cms as' bs')
+
+----------------------------------------------------------------------------
+-- Code for `:set'
+
+-- set options in the interpreter. Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected. ToDo:
+-- figure out which ones & disallow them.
+
+setCmd :: String -> GHCi ()
+setCmd ""
+ = do st <- getGHCiState
+ let opts = options st
+ io $ putStrLn (showSDoc (
+ text "options currently set: " <>
+ if null opts
+ then text "none."
+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+ ))
+setCmd str
+ = case words str of
+ ("args":args) -> setArgs args
+ ("prog":prog) -> setProg prog
+ ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
+ wds -> setOptions wds
+
+setArgs args = do
+ st <- getGHCiState
+ setGHCiState st{ args = args }
+
+setProg [prog] = do
+ st <- getGHCiState
+ setGHCiState st{ progname = prog }
+setProg _ = do
+ io (hPutStrLn stderr "syntax: :set prog <progname>")
+
+setPrompt value = do
+ st <- getGHCiState
+ if null value
+ then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
+ else setGHCiState st{ prompt = remQuotes value }
+ where
+ remQuotes ('\"':xs) | not (null xs) && last xs == '\"' = init xs
+ remQuotes x = x
+
+setOptions wds =
+ do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let (plus_opts, minus_opts) = partition isPlus wds
+ mapM_ setOpt plus_opts
+
+ -- then, dynamic flags
+ dflags <- getDynFlags
+ (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
+ setDynFlags dflags'
+
+ -- update things if the users wants more packages
+{- TODO:
+ let new_packages = pkgs_after \\ pkgs_before
+ when (not (null new_packages)) $
+ newPackages new_packages
+-}
+
+ if (not (null leftovers))
+ then throwDyn (CmdLineError ("unrecognised flags: " ++
+ unwords leftovers))
+ else return ()
+
+
+unsetOptions :: String -> GHCi ()
+unsetOptions str
+ = do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partition isPlus rest1
+
+ if (not (null rest2))
+ then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
+ else do
+
+ mapM_ unsetOpt plus_opts
+
+ -- can't do GHC flags for now
+ if (not (null minus_opts))
+ then throwDyn (CmdLineError "can't unset GHC command-line flags")
+ else return ()
+
+isMinus ('-':s) = True
+isMinus _ = False
+
+isPlus ('+':s) = True
+isPlus _ = False
+
+setOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Just o -> setOption o
+
+unsetOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
+ Just o -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt "r" = Just RevertCAFs
+strToGHCiOpt _ = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr ShowTiming = "s"
+optToStr ShowType = "t"
+optToStr RevertCAFs = "r"
+
+{- ToDo
+newPackages new_pkgs = do -- The new packages are already in v_Packages
+ session <- getSession
+ io (GHC.setTargets session [])
+ io (GHC.load session Nothing)
+ dflags <- getDynFlags
+ io (linkPackages dflags new_pkgs)
+ setContextAfterLoad []
+-}
+
+-- ---------------------------------------------------------------------------
+-- code for `:show'
+
+showCmd str =
+ case words str of
+ ["modules" ] -> showModules
+ ["bindings"] -> showBindings
+ ["linker"] -> io showLinkerState
+ _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
+
+showModules = do
+ session <- getSession
+ let show_one ms = do m <- io (GHC.showModule session ms)
+ io (putStrLn m)
+ graph <- io (GHC.getModuleGraph session)
+ mapM_ show_one graph
+
+showBindings = do
+ s <- getSession
+ unqual <- io (GHC.getPrintUnqual s)
+ bindings <- io (GHC.getBindings s)
+ mapM_ showTyThing bindings
+ return ()
+
+showTyThing (AnId id) = do
+ ty' <- cleanType (GHC.idType id)
+ str <- showForUser (ppr id <> text " :: " <> ppr ty')
+ io (putStrLn str)
+showTyThing _ = return ()
+
+-- if -fglasgow-exts is on we show the foralls, otherwise we don't.
+cleanType :: Type -> GHCi Type
+cleanType ty = do
+ dflags <- getDynFlags
+ if dopt Opt_GlasgowExts dflags
+ then return ty
+ else return $! GHC.dropForAlls ty
+
+-- -----------------------------------------------------------------------------
+-- Completion
+
+completeNone :: String -> IO [String]
+completeNone w = return []
+
+#ifdef USE_READLINE
+completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
+completeWord w start end = do
+ line <- Readline.getLineBuffer
+ case w of
+ ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
+ _other
+ | Just c <- is_cmd line -> do
+ maybe_cmd <- lookupCommand c
+ let (n,w') = selectWord (words' 0 line)
+ case maybe_cmd of
+ Nothing -> return Nothing
+ Just (_,_,False,complete) -> wrapCompleter complete w
+ Just (_,_,True,complete) -> let complete' w = do rets <- complete w
+ return (map (drop n) rets)
+ in wrapCompleter complete' w'
+ | otherwise -> do
+ --printf "complete %s, start = %d, end = %d\n" w start end
+ wrapCompleter completeIdentifier w
+ where words' _ [] = []
+ words' n str = let (w,r) = break isSpace str
+ (s,r') = span isSpace r
+ in (n,w):words' (n+length w+length s) r'
+ -- In a Haskell expression we want to parse 'a-b' as three words
+ -- where a compiler flag (ie. -fno-monomorphism-restriction) should
+ -- only be a single word.
+ selectWord [] = (0,w)
+ selectWord ((offset,x):xs)
+ | offset+length x >= start = (start-offset,take (end-offset) x)
+ | otherwise = selectWord xs
+
+is_cmd line
+ | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
+ | otherwise = Nothing
+
+completeCmd w = do
+ cmds <- readIORef commands
+ return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
+
+completeMacro w = do
+ cmds <- readIORef commands
+ let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
+ return (filter (w `isPrefixOf`) cmds')
+
+completeIdentifier w = do
+ s <- restoreSession
+ rdrs <- GHC.getRdrNamesInScope s
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
+
+completeModule w = do
+ s <- restoreSession
+ dflags <- GHC.getSessionDynFlags s
+ let pkg_mods = allExposedModules dflags
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
+
+completeHomeModule w = do
+ s <- restoreSession
+ g <- GHC.getModuleGraph s
+ let home_mods = map GHC.ms_mod g
+ return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
+
+completeSetOptions w = do
+ return (filter (w `isPrefixOf`) options)
+ where options = "args":"prog":allFlags
+
+completeFilename = Readline.filenameCompletionFunction
+
+completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
+
+unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
+unionComplete f1 f2 w = do
+ s1 <- f1 w
+ s2 <- f2 w
+ return (s1 ++ s2)
+
+wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
+wrapCompleter fun w = do
+ strs <- fun w
+ case strs of
+ [] -> return Nothing
+ [x] -> return (Just (x,[]))
+ xs -> case getCommonPrefix xs of
+ "" -> return (Just ("",xs))
+ pref -> return (Just (pref,xs))
+
+getCommonPrefix :: [String] -> String
+getCommonPrefix [] = ""
+getCommonPrefix (s:ss) = foldl common s ss
+ where common s "" = s
+ common "" s = ""
+ common (c:cs) (d:ds)
+ | c == d = c : common cs ds
+ | otherwise = ""
+
+allExposedModules :: DynFlags -> [Module]
+allExposedModules dflags
+ = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ where
+ pkg_db = pkgIdMap (pkgState dflags)
+#else
+completeCmd = completeNone
+completeMacro = completeNone
+completeIdentifier = completeNone
+completeModule = completeNone
+completeHomeModule = completeNone
+completeSetOptions = completeNone
+completeFilename = completeNone
+completeHomeModuleOrFile=completeNone
+#endif
+
+-----------------------------------------------------------------------------
+-- GHCi monad
+
+data GHCiState = GHCiState
+ {
+ progname :: String,
+ args :: [String],
+ prompt :: String,
+ session :: GHC.Session,
+ options :: [GHCiOption]
+ }
+
+data GHCiOption
+ = ShowTiming -- show time/allocs after evaluation
+ | ShowType -- show the type of expressions
+ | RevertCAFs -- revert CAFs after every evaluation
+ deriving Eq
+
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
+
+startGHCi :: GHCi a -> GHCiState -> IO a
+startGHCi g state = do ref <- newIORef state; unGHCi g ref
+
+instance Monad GHCi where
+ (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
+ return a = GHCi $ \s -> return a
+
+ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
+ghciHandleDyn h (GHCi m) = GHCi $ \s ->
+ Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
+
+getGHCiState = GHCi $ \r -> readIORef r
+setGHCiState s = GHCi $ \r -> writeIORef r s
+
+-- for convenience...
+getSession = getGHCiState >>= return . session
+
+GLOBAL_VAR(saved_sess, no_saved_sess, Session)
+no_saved_sess = error "no saved_ses"
+saveSession = getSession >>= io . writeIORef saved_sess
+splatSavedSession = io (writeIORef saved_sess no_saved_sess)
+restoreSession = readIORef saved_sess
+
+getDynFlags = do
+ s <- getSession
+ io (GHC.getSessionDynFlags s)
+setDynFlags dflags = do
+ s <- getSession
+ io (GHC.setSessionDynFlags s dflags)
+
+isOptionSet :: GHCiOption -> GHCi Bool
+isOptionSet opt
+ = do st <- getGHCiState
+ return (opt `elem` options st)
+
+setOption :: GHCiOption -> GHCi ()
+setOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+
+unsetOption :: GHCiOption -> GHCi ()
+unsetOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = filter (/= opt) (options st) })
+
+io :: IO a -> GHCi a
+io m = GHCi { unGHCi = \s -> m >>= return }
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered. Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle h (GHCi m) = GHCi $ \s ->
+ Exception.catch (m s)
+ (\e -> unGHCi (ghciUnblock (h e)) s)
+
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
+
+-----------------------------------------------------------------------------
+-- timing & statistics
+
+timeIt :: GHCi a -> GHCi a
+timeIt action
+ = do b <- isOptionSet ShowTiming
+ if not b
+ then action
+ else do allocs1 <- io $ getAllocations
+ time1 <- io $ getCPUTime
+ a <- action
+ allocs2 <- io $ getAllocations
+ time2 <- io $ getCPUTime
+ io $ printTimes (fromIntegral (allocs2 - allocs1))
+ (time2 - time1)
+ return a
+
+foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
+ -- defined in ghc/rts/Stats.c
+
+printTimes :: Integer -> Integer -> IO ()
+printTimes allocs psecs
+ = do let secs = (fromIntegral psecs / (10^12)) :: Float
+ secs_str = showFFloat (Just 2) secs
+ putStrLn (showSDoc (
+ parens (text (secs_str "") <+> text "secs" <> comma <+>
+ text (show allocs) <+> text "bytes")))
+
+-----------------------------------------------------------------------------
+-- reverting CAFs
+
+revertCAFs :: IO ()
+revertCAFs = do
+ rts_revertCAFs
+ turnOffBuffering
+ -- Have to turn off buffering again, because we just
+ -- reverted stdout, stderr & stdin to their defaults.
+
+foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
+ -- Make it "safe", just in case
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+expandPath :: String -> GHCi String
+expandPath path =
+ case dropWhile isSpace path of
+ ('~':d) -> do
+ tilde <- io (getEnv "HOME") -- will fail if HOME not defined
+ return (tilde ++ '/':d)
+ other ->
+ return other
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
new file mode 100644
index 0000000000..3a5ecf8a6d
--- /dev/null
+++ b/compiler/ghci/Linker.lhs
@@ -0,0 +1,927 @@
+%
+% (c) The University of Glasgow 2005
+%
+
+-- --------------------------------------
+-- The dynamic linker for GHCi
+-- --------------------------------------
+
+This module deals with the top-level issues of dynamic linking,
+calling the object-code linker and the byte-code linker where
+necessary.
+
+
+\begin{code}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
+
+module Linker ( HValue, showLinkerState,
+ linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
+ extendLoadedPkgs,
+ linkPackages,initDynLinker
+ ) where
+
+#include "HsVersions.h"
+
+import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker )
+import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO )
+import ByteCodeItbls ( ItblEnv )
+import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
+
+import Packages
+import DriverPhases ( isObjectFilename, isDynLibFilename )
+import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) )
+import HscTypes
+import Name ( Name, nameModule, isExternalName, isWiredInName )
+import NameEnv
+import NameSet ( nameSetToList )
+import Module
+import ListSetOps ( minusList )
+import DynFlags ( DynFlags(..), getOpts )
+import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import Outputable
+import Panic ( GhcException(..) )
+import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf )
+import StaticFlags ( v_Ld_inputs )
+import ErrUtils ( debugTraceMsg )
+
+-- Standard libraries
+import Control.Monad ( when, filterM, foldM )
+
+import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef )
+import Data.List ( partition, nub )
+
+import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
+import System.Directory ( doesFileExist )
+
+import Control.Exception ( block, throwDyn, bracket )
+import Maybe ( isJust, fromJust )
+
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.IOBase ( IO(..) )
+#else
+import PrelIOBase ( IO(..) )
+#endif
+\end{code}
+
+
+%************************************************************************
+%* *
+ The Linker's state
+%* *
+%************************************************************************
+
+The persistent linker state *must* match the actual state of the
+C dynamic linker at all times, so we keep it in a private global variable.
+
+
+The PersistentLinkerState maps Names to actual closures (for
+interpreted code only), for use during linking.
+
+\begin{code}
+GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
+GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
+
+data PersistentLinkerState
+ = PersistentLinkerState {
+
+ -- Current global mapping from Names to their true values
+ closure_env :: ClosureEnv,
+
+ -- The current global mapping from RdrNames of DataCons to
+ -- info table addresses.
+ -- When a new Unlinked is linked into the running image, or an existing
+ -- module in the image is replaced, the itbl_env must be updated
+ -- appropriately.
+ itbl_env :: ItblEnv,
+
+ -- The currently loaded interpreted modules (home package)
+ bcos_loaded :: [Linkable],
+
+ -- And the currently-loaded compiled modules (home package)
+ objs_loaded :: [Linkable],
+
+ -- The currently-loaded packages; always object code
+ -- Held, as usual, in dependency order; though I am not sure if
+ -- that is really important
+ pkgs_loaded :: [PackageId]
+ }
+
+emptyPLS :: DynFlags -> PersistentLinkerState
+emptyPLS dflags = PersistentLinkerState {
+ closure_env = emptyNameEnv,
+ itbl_env = emptyNameEnv,
+ pkgs_loaded = init_pkgs,
+ bcos_loaded = [],
+ objs_loaded = [] }
+ -- Packages that don't need loading, because the compiler
+ -- shares them with the interpreted program.
+ --
+ -- The linker's symbol table is populated with RTS symbols using an
+ -- explicit list. See rts/Linker.c for details.
+ where init_pkgs
+ | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
+ | otherwise = []
+\end{code}
+
+\begin{code}
+extendLoadedPkgs :: [PackageId] -> IO ()
+extendLoadedPkgs pkgs
+ = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
+
+extendLinkEnv :: [(Name,HValue)] -> IO ()
+-- Automatically discards shadowed bindings
+extendLinkEnv new_bindings
+ = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+
+withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+withExtendedLinkEnv new_env action
+ = bracket set_new_env
+ reset_old_env
+ (const action)
+ where set_new_env = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_env
+ new_pls = pls { closure_env = new_closure_env }
+ writeIORef v_PersistentLinkerState new_pls
+ return pls
+ reset_old_env pls = writeIORef v_PersistentLinkerState pls
+
+-- filterNameMap removes from the environment all entries except
+-- those for a given set of modules;
+-- Note that this removes all *local* (i.e. non-isExternal) names too
+-- (these are the temporary bindings from the command line).
+-- Used to filter both the ClosureEnv and ItblEnv
+
+filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
+filterNameMap mods env
+ = filterNameEnv keep_elt env
+ where
+ keep_elt (n,_) = isExternalName n
+ && (nameModule n `elem` mods)
+\end{code}
+
+
+\begin{code}
+showLinkerState :: IO ()
+-- Display the persistent linker state
+showLinkerState
+ = do pls <- readIORef v_PersistentLinkerState
+ printDump (vcat [text "----- Linker state -----",
+ text "Pkgs:" <+> ppr (pkgs_loaded pls),
+ text "Objs:" <+> ppr (objs_loaded pls),
+ text "BCOs:" <+> ppr (bcos_loaded pls)])
+\end{code}
+
+
+
+
+%************************************************************************
+%* *
+\subsection{Initialisation}
+%* *
+%************************************************************************
+
+We initialise the dynamic linker by
+
+a) calling the C initialisation procedure
+
+b) Loading any packages specified on the command line,
+ now held in v_ExplicitPackages
+
+c) Loading any packages specified on the command line,
+ now held in the -l options in v_Opt_l
+
+d) Loading any .o/.dll files specified on the command line,
+ now held in v_Ld_inputs
+
+e) Loading any MacOS frameworks
+
+\begin{code}
+initDynLinker :: DynFlags -> IO ()
+-- This function is idempotent; if called more than once, it does nothing
+-- This is useful in Template Haskell, where we call it before trying to link
+initDynLinker dflags
+ = do { done <- readIORef v_InitLinkerDone
+ ; if done then return ()
+ else do { writeIORef v_InitLinkerDone True
+ ; reallyInitDynLinker dflags }
+ }
+
+reallyInitDynLinker dflags
+ = do { -- Initialise the linker state
+ ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
+
+ -- (a) initialise the C dynamic linker
+ ; initObjLinker
+
+ -- (b) Load packages from the command-line
+ ; linkPackages dflags (explicitPackages (pkgState dflags))
+
+ -- (c) Link libraries from the command-line
+ ; let optl = getOpts dflags opt_l
+ ; let minus_ls = [ lib | '-':'l':lib <- optl ]
+
+ -- (d) Link .o files from the command-line
+ ; let lib_paths = libraryPaths dflags
+ ; cmdline_ld_inputs <- readIORef v_Ld_inputs
+
+ ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
+
+ -- (e) Link any MacOS frameworks
+#ifdef darwin_TARGET_OS
+ ; let framework_paths = frameworkPaths dflags
+ ; let frameworks = cmdlineFrameworks dflags
+#else
+ ; let frameworks = []
+ ; let framework_paths = []
+#endif
+ -- Finally do (c),(d),(e)
+ ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
+ ++ map DLL minus_ls
+ ++ map Framework frameworks
+ ; if null cmdline_lib_specs then return ()
+ else do
+
+ { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
+ ; maybePutStr dflags "final link ... "
+ ; ok <- resolveObjs
+
+ ; if succeeded ok then maybePutStrLn dflags "done"
+ else throwDyn (InstallationError "linking extra libraries/objects failed")
+ }}
+
+classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
+classifyLdInput f
+ | isObjectFilename f = return (Just (Object f))
+ | isDynLibFilename f = return (Just (DLLPath f))
+ | otherwise = do
+ hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
+ return Nothing
+
+preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
+preloadLib dflags lib_paths framework_paths lib_spec
+ = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+ case lib_spec of
+ Object static_ish
+ -> do b <- preload_static lib_paths static_ish
+ maybePutStrLn dflags (if b then "done"
+ else "not found")
+
+ DLL dll_unadorned
+ -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm -> preloadFailed mm lib_paths lib_spec
+
+ DLLPath dll_path
+ -> do maybe_errstr <- loadDLL dll_path
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm -> preloadFailed mm lib_paths lib_spec
+
+#ifdef darwin_TARGET_OS
+ Framework framework
+ -> do maybe_errstr <- loadFramework framework_paths framework
+ case maybe_errstr of
+ Nothing -> maybePutStrLn dflags "done"
+ Just mm -> preloadFailed mm framework_paths lib_spec
+#endif
+ where
+ preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
+ preloadFailed sys_errmsg paths spec
+ = do maybePutStr dflags
+ ("failed.\nDynamic linker error message was:\n "
+ ++ sys_errmsg ++ "\nWhilst trying to load: "
+ ++ showLS spec ++ "\nDirectories to search are:\n"
+ ++ unlines (map (" "++) paths) )
+ give_up
+
+ -- Not interested in the paths in the static case.
+ preload_static paths name
+ = do b <- doesFileExist name
+ if not b then return False
+ else loadObj name >> return True
+
+ give_up = throwDyn $
+ CmdLineError "user specified .o/.so/.DLL could not be loaded."
+\end{code}
+
+
+%************************************************************************
+%* *
+ Link a byte-code expression
+%* *
+%************************************************************************
+
+\begin{code}
+linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue
+
+-- Link a single expression, *including* first linking packages and
+-- modules that this expression depends on.
+--
+-- Raises an IO exception if it can't find a compiled version of the
+-- dependents to link.
+
+linkExpr hsc_env root_ul_bco
+ = do {
+ -- Initialise the linker (if it's not been done already)
+ let dflags = hsc_dflags hsc_env
+ ; initDynLinker dflags
+
+ -- Find what packages and linkables are required
+ ; eps <- readIORef (hsc_EPS hsc_env)
+ ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) needed_mods
+
+ -- Link the packages and modules required
+ ; linkPackages dflags pkgs
+ ; ok <- linkModules dflags lnks
+ ; if failed ok then
+ dieWith empty
+ else do {
+
+ -- Link the expression itself
+ pls <- readIORef v_PersistentLinkerState
+ ; let ie = itbl_env pls
+ ce = closure_env pls
+
+ -- Link the necessary packages and linkables
+ ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
+ ; return root_hval
+ }}
+ where
+ hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ free_names = nameSetToList (bcoFreeNames root_ul_bco)
+
+ needed_mods :: [Module]
+ needed_mods = [ nameModule n | n <- free_names,
+ isExternalName n, -- Names from other modules
+ not (isWiredInName n) -- Exclude wired-in names
+ ] -- (see note below)
+ -- Exclude wired-in names because we may not have read
+ -- their interface files, so getLinkDeps will fail
+ -- All wired-in names are in the base package, which we link
+ -- by default, so we can safely ignore them here.
+
+dieWith msg = throwDyn (ProgramError (showSDoc msg))
+
+getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
+ -> [Module] -- If you need these
+ -> IO ([Linkable], [PackageId]) -- ... then link these first
+-- Fails with an IO exception if it can't find enough files
+
+getLinkDeps hsc_env hpt pit mods
+-- Find all the packages and linkables that a set of modules depends on
+ = do { pls <- readIORef v_PersistentLinkerState ;
+ let {
+ -- 1. Find the dependent home-pkg-modules/packages from each iface
+ (mods_s, pkgs_s) = unzip (map get_deps mods) ;
+
+ -- 2. Exclude ones already linked
+ -- Main reason: avoid findModule calls in get_linkable
+ mods_needed = nub (concat mods_s) `minusList` linked_mods ;
+ pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ;
+
+ linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls)
+ } ;
+
+ -- 3. For each dependent module, find its linkable
+ -- This will either be in the HPT or (in the case of one-shot
+ -- compilation) we may need to use maybe_getFileLinkable
+ lnks_needed <- mapM get_linkable mods_needed ;
+
+ return (lnks_needed, pkgs_needed) }
+ where
+ get_deps :: Module -> ([Module],[PackageId])
+ -- Get the things needed for the specified module
+ -- This is rather similar to the code in RnNames.importsFromImportDecl
+ get_deps mod
+ | ExtPackage p <- mi_package iface
+ = ([], p : dep_pkgs deps)
+ | otherwise
+ = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
+ where
+ iface = get_iface mod
+ deps = mi_deps iface
+
+ get_iface mod = case lookupIface hpt pit mod of
+ Just iface -> iface
+ Nothing -> pprPanic "getLinkDeps" (no_iface mod)
+ no_iface mod = ptext SLIT("No iface for") <+> ppr mod
+ -- This one is a GHC bug
+
+ no_obj mod = dieWith (ptext SLIT("No compiled code for") <+> ppr mod)
+ -- This one is a build-system bug
+
+ get_linkable mod_name -- A home-package module
+ | Just mod_info <- lookupModuleEnv hpt mod_name
+ = ASSERT(isJust (hm_linkable mod_info))
+ return (fromJust (hm_linkable mod_info))
+ | otherwise
+ = -- It's not in the HPT because we are in one shot mode,
+ -- so use the Finder to get a ModLocation...
+ do { mb_stuff <- findModule hsc_env mod_name False ;
+ case mb_stuff of {
+ Found loc _ -> found loc mod_name ;
+ _ -> no_obj mod_name
+ }}
+
+ found loc mod_name = do {
+ -- ...and then find the linkable for it
+ mb_lnk <- findObjectLinkableMaybe mod_name loc ;
+ case mb_lnk of {
+ Nothing -> no_obj mod_name ;
+ Just lnk -> return lnk
+ }}
+\end{code}
+
+
+%************************************************************************
+%* *
+ Link some linkables
+ The linkables may consist of a mixture of
+ byte-code modules and object modules
+%* *
+%************************************************************************
+
+\begin{code}
+linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
+linkModules dflags linkables
+ = block $ do -- don't want to be interrupted by ^C in here
+
+ let (objs, bcos) = partition isObjectLinkable
+ (concatMap partitionLinkable linkables)
+
+ -- Load objects first; they can't depend on BCOs
+ ok_flag <- dynLinkObjs dflags objs
+
+ if failed ok_flag then
+ return Failed
+ else do
+ dynLinkBCOs bcos
+ return Succeeded
+
+
+-- HACK to support f-x-dynamic in the interpreter; no other purpose
+partitionLinkable :: Linkable -> [Linkable]
+partitionLinkable li
+ = let li_uls = linkableUnlinked li
+ li_uls_obj = filter isObject li_uls
+ li_uls_bco = filter isInterpretable li_uls
+ in
+ case (li_uls_obj, li_uls_bco) of
+ (objs@(_:_), bcos@(_:_))
+ -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
+ other
+ -> [li]
+
+findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
+findModuleLinkable_maybe lis mod
+ = case [LM time nm us | LM time nm us <- lis, nm == mod] of
+ [] -> Nothing
+ [li] -> Just li
+ many -> pprPanic "findModuleLinkable" (ppr mod)
+
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+ case findModuleLinkable_maybe objs_loaded (linkableModule l) of
+ Nothing -> False
+ Just m -> linkableTime l == linkableTime m
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The object-code linker}
+%* *
+%************************************************************************
+
+\begin{code}
+dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
+ -- Side-effects the PersistentLinkerState
+
+dynLinkObjs dflags objs
+ = do pls <- readIORef v_PersistentLinkerState
+
+ -- Load the object files and link them
+ let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
+ pls1 = pls { objs_loaded = objs_loaded' }
+ unlinkeds = concatMap linkableUnlinked new_objs
+
+ mapM loadObj (map nameOfObject unlinkeds)
+
+ -- Link the all together
+ ok <- resolveObjs
+
+ -- If resolving failed, unload all our
+ -- object modules and carry on
+ if succeeded ok then do
+ writeIORef v_PersistentLinkerState pls1
+ return Succeeded
+ else do
+ pls2 <- unload_wkr dflags [] pls1
+ writeIORef v_PersistentLinkerState pls2
+ return Failed
+
+
+rmDupLinkables :: [Linkable] -- Already loaded
+ -> [Linkable] -- New linkables
+ -> ([Linkable], -- New loaded set (including new ones)
+ [Linkable]) -- New linkables (excluding dups)
+rmDupLinkables already ls
+ = go already [] ls
+ where
+ go already extras [] = (already, extras)
+ go already extras (l:ls)
+ | linkableInSet l already = go already extras ls
+ | otherwise = go (l:already) (l:extras) ls
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The byte-code linker}
+%* *
+%************************************************************************
+
+\begin{code}
+dynLinkBCOs :: [Linkable] -> IO ()
+ -- Side-effects the persistent linker state
+dynLinkBCOs bcos
+ = do pls <- readIORef v_PersistentLinkerState
+
+ let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+ pls1 = pls { bcos_loaded = bcos_loaded' }
+ unlinkeds :: [Unlinked]
+ unlinkeds = concatMap linkableUnlinked new_bcos
+
+ cbcs :: [CompiledByteCode]
+ cbcs = map byteCodeOfObject unlinkeds
+
+
+ ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
+ ies = [ie | ByteCode _ ie <- cbcs]
+ gce = closure_env pls
+ final_ie = foldr plusNameEnv (itbl_env pls) ies
+
+ (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ -- What happens to these linked_bcos?
+
+ let pls2 = pls1 { closure_env = final_gce,
+ itbl_env = final_ie }
+
+ writeIORef v_PersistentLinkerState pls2
+ return ()
+
+-- Link a bunch of BCOs and return them + updated closure env.
+linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
+ -- True <=> add only toplevel BCOs to closure env
+ -> ItblEnv
+ -> ClosureEnv
+ -> [UnlinkedBCO]
+ -> IO (ClosureEnv, [HValue])
+ -- The returned HValues are associated 1-1 with
+ -- the incoming unlinked BCOs. Each gives the
+ -- value of the corresponding unlinked BCO
+
+
+linkSomeBCOs toplevs_only ie ce_in ul_bcos
+ = do let nms = map unlinkedBCOName ul_bcos
+ hvals <- fixIO
+ ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
+ in mapM (linkBCO ie ce_out) ul_bcos )
+
+ let ce_all_additions = zip nms hvals
+ ce_top_additions = filter (isExternalName.fst) ce_all_additions
+ ce_additions = if toplevs_only then ce_top_additions
+ else ce_all_additions
+ ce_out = -- make sure we're not inserting duplicate names into the
+ -- closure environment, which leads to trouble.
+ ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
+ extendClosureEnv ce_in ce_additions
+ return (ce_out, hvals)
+
+\end{code}
+
+
+%************************************************************************
+%* *
+ Unload some object modules
+%* *
+%************************************************************************
+
+\begin{code}
+-- ---------------------------------------------------------------------------
+-- Unloading old objects ready for a new compilation sweep.
+--
+-- The compilation manager provides us with a list of linkables that it
+-- considers "stable", i.e. won't be recompiled this time around. For
+-- each of the modules current linked in memory,
+--
+-- * if the linkable is stable (and it's the same one - the
+-- user may have recompiled the module on the side), we keep it,
+--
+-- * otherwise, we unload it.
+--
+-- * we also implicitly unload all temporary bindings at this point.
+
+unload :: DynFlags -> [Linkable] -> IO ()
+-- The 'linkables' are the ones to *keep*
+
+unload dflags linkables
+ = block $ do -- block, so we're safe from Ctrl-C in here
+
+ -- Initialise the linker (if it's not been done already)
+ initDynLinker dflags
+
+ pls <- readIORef v_PersistentLinkerState
+ new_pls <- unload_wkr dflags linkables pls
+ writeIORef v_PersistentLinkerState new_pls
+
+ debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
+ debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
+ return ()
+
+unload_wkr :: DynFlags
+ -> [Linkable] -- stable linkables
+ -> PersistentLinkerState
+ -> IO PersistentLinkerState
+-- Does the core unload business
+-- (the wrapper blocks exceptions and deals with the PLS get and put)
+
+unload_wkr dflags linkables pls
+ = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
+
+ objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
+ bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
+
+ let bcos_retained = map linkableModule bcos_loaded'
+ itbl_env' = filterNameMap bcos_retained (itbl_env pls)
+ closure_env' = filterNameMap bcos_retained (closure_env pls)
+ new_pls = pls { itbl_env = itbl_env',
+ closure_env = closure_env',
+ bcos_loaded = bcos_loaded',
+ objs_loaded = objs_loaded' }
+
+ return new_pls
+ where
+ maybeUnload :: [Linkable] -> Linkable -> IO Bool
+ maybeUnload keep_linkables lnk
+ | linkableInSet lnk linkables = return True
+ | otherwise
+ = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
+ -- The components of a BCO linkable may contain
+ -- dot-o files. Which is very confusing.
+ --
+ -- But the BCO parts can be unlinked just by
+ -- letting go of them (plus of course depopulating
+ -- the symbol table which is done in the main body)
+ return False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Loading packages
+%* *
+%************************************************************************
+
+
+\begin{code}
+data LibrarySpec
+ = Object FilePath -- Full path name of a .o file, including trailing .o
+ -- For dynamic objects only, try to find the object
+ -- file in all the directories specified in
+ -- v_Library_paths before giving up.
+
+ | DLL String -- "Unadorned" name of a .DLL/.so
+ -- e.g. On unix "qt" denotes "libqt.so"
+ -- On WinDoze "burble" denotes "burble.DLL"
+ -- loadDLL is platform-specific and adds the lib/.so/.DLL
+ -- suffixes platform-dependently
+
+ | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
+ -- (ends with .dll or .so).
+
+ | Framework String -- Only used for darwin, but does no harm
+
+-- If this package is already part of the GHCi binary, we'll already
+-- have the right DLLs for this package loaded, so don't try to
+-- load them again.
+--
+-- But on Win32 we must load them 'again'; doing so is a harmless no-op
+-- as far as the loader is concerned, but it does initialise the list
+-- of DLL handles that rts/Linker.c maintains, and that in turn is
+-- used by lookupSymbol. So we must call addDLL for each library
+-- just to get the DLL handle into the list.
+partOfGHCi
+# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
+ = [ ]
+# else
+ = [ "base", "haskell98", "template-haskell", "readline" ]
+# endif
+
+showLS (Object nm) = "(static) " ++ nm
+showLS (DLL nm) = "(dynamic) " ++ nm
+showLS (DLLPath nm) = "(dynamic) " ++ nm
+showLS (Framework nm) = "(framework) " ++ nm
+
+linkPackages :: DynFlags -> [PackageId] -> IO ()
+-- Link exactly the specified packages, and their dependents
+-- (unless of course they are already linked)
+-- The dependents are linked automatically, and it doesn't matter
+-- what order you specify the input packages.
+--
+-- NOTE: in fact, since each module tracks all the packages it depends on,
+-- we don't really need to use the package-config dependencies.
+-- However we do need the package-config stuff (to find aux libs etc),
+-- and following them lets us load libraries in the right order, which
+-- perhaps makes the error message a bit more localised if we get a link
+-- failure. So the dependency walking code is still here.
+
+linkPackages dflags new_pkgs
+ = do { pls <- readIORef v_PersistentLinkerState
+ ; let pkg_map = pkgIdMap (pkgState dflags)
+
+ ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
+
+ ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
+ }
+ where
+ link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
+ link pkg_map pkgs new_pkgs
+ = foldM (link_one pkg_map) pkgs new_pkgs
+
+ link_one pkg_map pkgs new_pkg
+ | new_pkg `elem` pkgs -- Already linked
+ = return pkgs
+
+ | Just pkg_cfg <- lookupPackage pkg_map new_pkg
+ = do { -- Link dependents first
+ pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
+ -- Now link the package itself
+ ; linkPackage dflags pkg_cfg
+ ; return (new_pkg : pkgs') }
+
+ | otherwise
+ = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+
+
+linkPackage :: DynFlags -> PackageConfig -> IO ()
+linkPackage dflags pkg
+ = do
+ let dirs = Packages.libraryDirs pkg
+
+ let libs = Packages.hsLibraries pkg
+ -- Because of slight differences between the GHC dynamic linker and
+ -- the native system linker some packages have to link with a
+ -- different list of libraries when using GHCi. Examples include: libs
+ -- that are actually gnu ld scripts, and the possability that the .a
+ -- libs do not exactly match the .so/.dll equivalents. So if the
+ -- package file provides an "extra-ghci-libraries" field then we use
+ -- that instead of the "extra-libraries" field.
+ ++ (if null (Packages.extraGHCiLibraries pkg)
+ then Packages.extraLibraries pkg
+ else Packages.extraGHCiLibraries pkg)
+ ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
+ classifieds <- mapM (locateOneObj dirs) libs
+
+ -- Complication: all the .so's must be loaded before any of the .o's.
+ let dlls = [ dll | DLL dll <- classifieds ]
+ objs = [ obj | Object obj <- classifieds ]
+
+ maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
+
+ -- See comments with partOfGHCi
+ when (pkgName (package pkg) `notElem` partOfGHCi) $ do
+ loadFrameworks pkg
+ -- When a library A needs symbols from a library B, the order in
+ -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
+ -- way ld expects it for static linking. Dynamic linking is a
+ -- different story: When A has no dependency information for B,
+ -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
+ -- when B has not been loaded before. In a nutshell: Reverse the
+ -- order of DLLs for dynamic linking.
+ -- This fixes a problem with the HOpenGL package (see "Compiling
+ -- HOpenGL under recent versions of GHC" on the HOpenGL list).
+ mapM_ (load_dyn dirs) (reverse dlls)
+
+ -- After loading all the DLLs, we can load the static objects.
+ -- Ordering isn't important here, because we do one final link
+ -- step to resolve everything.
+ mapM_ loadObj objs
+
+ maybePutStr dflags "linking ... "
+ ok <- resolveObjs
+ if succeeded ok then maybePutStrLn dflags "done."
+ else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
+
+load_dyn dirs dll = do r <- loadDynamic dirs dll
+ case r of
+ Nothing -> return ()
+ Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
+ ++ dll ++ " (" ++ err ++ ")" ))
+#ifndef darwin_TARGET_OS
+loadFrameworks pkg = return ()
+#else
+loadFrameworks pkg = mapM_ load frameworks
+ where
+ fw_dirs = Packages.frameworkDirs pkg
+ frameworks = Packages.frameworks pkg
+
+ load fw = do r <- loadFramework fw_dirs fw
+ case r of
+ Nothing -> return ()
+ Just err -> throwDyn (CmdLineError ("can't load framework: "
+ ++ fw ++ " (" ++ err ++ ")" ))
+#endif
+
+-- Try to find an object file for a given library in the given paths.
+-- If it isn't present, we assume it's a dynamic library.
+locateOneObj :: [FilePath] -> String -> IO LibrarySpec
+locateOneObj dirs lib
+ = do { mb_obj_path <- findFile mk_obj_path dirs
+ ; case mb_obj_path of
+ Just obj_path -> return (Object obj_path)
+ Nothing ->
+ do { mb_lib_path <- findFile mk_dyn_lib_path dirs
+ ; case mb_lib_path of
+ Just lib_path -> return (DLL (lib ++ "_dyn"))
+ Nothing -> return (DLL lib) }} -- We assume
+ where
+ mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
+ mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
+
+
+-- ----------------------------------------------------------------------------
+-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
+
+-- return Nothing == success, else Just error message from dlopen
+loadDynamic paths rootname
+ = do { mb_dll <- findFile mk_dll_path paths
+ ; case mb_dll of
+ Just dll -> loadDLL dll
+ Nothing -> loadDLL (mkSOName rootname) }
+ -- Tried all our known library paths, so let
+ -- dlopen() search its own builtin paths now.
+ where
+ mk_dll_path dir = dir `joinFileName` mkSOName rootname
+
+#if defined(darwin_TARGET_OS)
+mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
+#elif defined(mingw32_TARGET_OS)
+-- Win32 DLLs have no .dll extension here, because addDLL tries
+-- both foo.dll and foo.drv
+mkSOName root = root
+#else
+mkSOName root = ("lib" ++ root) `joinFileExt` "so"
+#endif
+
+-- Darwin / MacOS X only: load a framework
+-- a framework is a dynamic library packaged inside a directory of the same
+-- name. They are searched for in different paths than normal libraries.
+#ifdef darwin_TARGET_OS
+loadFramework extraPaths rootname
+ = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
+ ; case mb_fwk of
+ Just fwk_path -> loadDLL fwk_path
+ Nothing -> return (Just "not found") }
+ -- Tried all our known library paths, but dlopen()
+ -- has no built-in paths for frameworks: give up
+ where
+ mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
+ -- sorry for the hardcoded paths, I hope they won't change anytime soon:
+ defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
+#endif
+\end{code}
+
+%************************************************************************
+%* *
+ Helper functions
+%* *
+%************************************************************************
+
+\begin{code}
+findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
+ -> [FilePath] -- Directories to look in
+ -> IO (Maybe FilePath) -- The first file path to match
+findFile mk_file_path []
+ = return Nothing
+findFile mk_file_path (dir:dirs)
+ = do { let file_path = mk_file_path dir
+ ; b <- doesFileExist file_path
+ ; if b then
+ return (Just file_path)
+ else
+ findFile mk_file_path dirs }
+\end{code}
+
+\begin{code}
+maybePutStr dflags s | verbosity dflags > 0 = putStr s
+ | otherwise = return ()
+
+maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
+ | otherwise = return ()
+\end{code}
diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs
new file mode 100644
index 0000000000..057938a45e
--- /dev/null
+++ b/compiler/ghci/ObjLink.lhs
@@ -0,0 +1,97 @@
+%
+% (c) The University of Glasgow, 2000
+%
+
+-- ---------------------------------------------------------------------------
+-- The dynamic linker for object code (.o .so .dll files)
+-- ---------------------------------------------------------------------------
+
+Primarily, this module consists of an interface to the C-land dynamic linker.
+
+\begin{code}
+{-# OPTIONS -#include "Linker.h" #-}
+
+module ObjLink (
+ initObjLinker, -- :: IO ()
+ loadDLL, -- :: String -> IO (Maybe String)
+ loadObj, -- :: String -> IO ()
+ unloadObj, -- :: String -> IO ()
+ lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
+ resolveObjs -- :: IO SuccessFlag
+ ) where
+
+import Monad ( when )
+
+import Foreign.C
+import Foreign ( Ptr, nullPtr )
+import Panic ( panic )
+import BasicTypes ( SuccessFlag, successIf )
+import Config ( cLeadingUnderscore )
+import Outputable
+
+-- ---------------------------------------------------------------------------
+-- RTS Linker Interface
+-- ---------------------------------------------------------------------------
+
+lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol str_in = do
+ let str = prefixUnderscore str_in
+ withCString str $ \c_str -> do
+ addr <- c_lookupSymbol c_str
+ if addr == nullPtr
+ then return Nothing
+ else return (Just addr)
+
+prefixUnderscore :: String -> String
+prefixUnderscore
+ | cLeadingUnderscore == "YES" = ('_':)
+ | otherwise = id
+
+loadDLL :: String -> IO (Maybe String)
+-- Nothing => success
+-- Just err_msg => failure
+loadDLL str = do
+ maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+ if maybe_errmsg == nullPtr
+ then return Nothing
+ else do str <- peekCString maybe_errmsg
+ return (Just str)
+
+loadObj :: String -> IO ()
+loadObj str = do
+ withCString str $ \c_str -> do
+ r <- c_loadObj c_str
+ when (r == 0) (panic "loadObj: failed")
+
+unloadObj :: String -> IO ()
+unloadObj str =
+ withCString str $ \c_str -> do
+ r <- c_unloadObj c_str
+ when (r == 0) (panic "unloadObj: failed")
+
+resolveObjs :: IO SuccessFlag
+resolveObjs = do
+ r <- c_resolveObjs
+ return (successIf (r /= 0))
+
+-- ---------------------------------------------------------------------------
+-- Foreign declaractions to RTS entry points which does the real work;
+-- ---------------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ >= 504
+foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString
+foreign import ccall unsafe "initLinker" initObjLinker :: IO ()
+foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
+foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int
+foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int
+foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int
+#else
+foreign import "addDLL" unsafe c_addDLL :: CString -> IO CString
+foreign import "initLinker" unsafe initLinker :: IO ()
+foreign import "lookupSymbol" unsafe c_lookupSymbol :: CString -> IO (Ptr a)
+foreign import "loadObj" unsafe c_loadObj :: CString -> IO Int
+foreign import "unloadObj" unsafe c_unloadObj :: CString -> IO Int
+foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int
+#endif
+
+\end{code}
diff --git a/compiler/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c
new file mode 100644
index 0000000000..0aabbedea0
--- /dev/null
+++ b/compiler/ghci/keepCAFsForGHCi.c
@@ -0,0 +1,15 @@
+#include "Rts.h"
+#include "Storage.h"
+
+// This file is only included when GhcBuildDylibs is set in mk/build.mk.
+// It contains an __attribute__((constructor)) function (run prior to main())
+// which sets the keepCAFs flag in the RTS, before any Haskell code is run.
+// This is required so that GHCi can use dynamic libraries instead of HSxyz.o
+// files.
+
+static void keepCAFsForGHCi() __attribute__((constructor));
+
+static void keepCAFsForGHCi()
+{
+ keepCAFs = 1;
+}
View Lorry Controller Status