diff options
Diffstat (limited to 'compiler/ghci')
| -rw-r--r-- | compiler/ghci/ByteCodeAsm.lhs | 497 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeFFI.lhs | 832 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeGen.lhs | 1358 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeInstr.lhs | 256 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeItbls.lhs | 366 | ||||
| -rw-r--r-- | compiler/ghci/ByteCodeLink.lhs | 268 | ||||
| -rw-r--r-- | compiler/ghci/InteractiveUI.hs | 1534 | ||||
| -rw-r--r-- | compiler/ghci/Linker.lhs | 927 | ||||
| -rw-r--r-- | compiler/ghci/ObjLink.lhs | 97 | ||||
| -rw-r--r-- | compiler/ghci/keepCAFsForGHCi.c | 15 |
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; +} |