diff options
Diffstat (limited to 'compiler/GHC')
40 files changed, 9173 insertions, 26 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs new file mode 100644 index 0000000000..db5c14b806 --- /dev/null +++ b/compiler/GHC/ByteCode/Asm.hs @@ -0,0 +1,566 @@ +{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Asm ( + assembleBCOs, assembleOneBCO, + + bcoFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Instr +import GHC.ByteCode.InfoTable +import GHC.ByteCode.Types +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter + +import HscTypes +import Name +import NameSet +import Literal +import TyCon +import FastString +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import GHC.Runtime.Heap.Layout +import DynFlags +import Outputable +import GHC.Platform +import Util +import Unique +import UniqDSet + +-- From iserv +import SizedSeq + +import Control.Monad +import Control.Monad.ST ( runST ) +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict + +import Data.Array.MArray + +import qualified Data.Array.Unboxed as Array +import Data.Array.Base ( UArray(..) ) + +import Data.Array.Unsafe( castSTUArray ) + +import Foreign +import Data.Char ( ord ) +import Data.List ( genericLength ) +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map + +-- ----------------------------------------------------------------------------- +-- Unlinked BCOs + +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +-- | Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcoFreeNames :: UnlinkedBCO -> UniqDSet Name +bcoFreeNames bco + = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] + where + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + = unionManyUniqDSets ( + mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] + ) + +-- ----------------------------------------------------------------------------- +-- 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 + :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] + -> Maybe ModBreaks + -> IO CompiledByteCode +assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do + itblenv <- mkITbls hsc_env tycons + bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos + (bcos',ptrs) <- mallocStrings hsc_env bcos + return CompiledByteCode + { bc_bcos = bcos' + , bc_itbls = itblenv + , bc_ffis = concat (map protoBCOFFIs proto_bcos) + , bc_strs = top_strs ++ ptrs + , bc_breaks = modbreaks + } + +-- Find all the literal strings and malloc them together. We want to +-- do this because: +-- +-- a) It should be done when we compile the module, not each time we relink it +-- b) For -fexternal-interpreter It's more efficient to malloc the strings +-- as a single batch message, especially when compiling in parallel. +-- +mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()]) +mallocStrings hsc_env ulbcos = do + let bytestrings = reverse (execState (mapM_ collect ulbcos) []) + ptrs <- iservCmd hsc_env (MallocStrings bytestrings) + return (evalState (mapM splice ulbcos) ptrs, ptrs) + where + splice bco@UnlinkedBCO{..} = do + lits <- mapM spliceLit unlinkedBCOLits + ptrs <- mapM splicePtr unlinkedBCOPtrs + return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } + + spliceLit (BCONPtrStr _) = do + rptrs <- get + case rptrs of + (RemotePtr p : rest) -> do + put rest + return (BCONPtrWord (fromIntegral p)) + _ -> panic "mallocStrings:spliceLit" + spliceLit other = return other + + splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco + splicePtr other = return other + + collect UnlinkedBCO{..} = do + mapM_ collectLit unlinkedBCOLits + mapM_ collectPtr unlinkedBCOPtrs + + collectLit (BCONPtrStr bs) = do + strs <- get + put (bs:strs) + collectLit _ = return () + + collectPtr (BCOPtrBCO bco) = collect bco + collectPtr _ = return () + + +assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO +assembleOneBCO hsc_env pbco = do + ubco <- assembleBCO (hsc_dflags hsc_env) pbco + ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco] + return ubco' + +assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO dflags (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do + -- pass 1: collect up the offsets of the local labels. + let asm = mapM_ (assembleI dflags) instrs + + initial_offset = 0 + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm + ((n_insns, lbl_map), long_jumps) + | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True) + | otherwise = ((n_insns0, lbl_map0), False) + + env :: Word16 -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (Map.lookup lbl lbl_map) + + -- pass 2: run assembler and generate instructions, literals and pointers + let initial_state = (emptySS, emptySS, emptySS) + (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm + + -- precomputed size should be equal to final size + ASSERT(n_insns == sizeSS final_insns) return () + + let asm_insns = ssElts final_insns + insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns + bitmap_arr = mkBitmapArray bsize bitmap + ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + +mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64 +-- Here the return type must be an array of Words, not StgWords, +-- because the underlying ByteArray# will end up as a component +-- of a BCO object. +mkBitmapArray bsize bitmap + = Array.listArray (0, length bitmap) $ + fromIntegral bsize : map (fromInteger . fromStgWord) bitmap + +-- instrs nonptrs ptrs +type AsmState = (SizedSeq Word16, + SizedSeq BCONPtr, + SizedSeq BCOPtr) + +data Operand + = Op Word + | SmallOp Word16 + | LabelOp Word16 +-- (unused) | LargeOp Word + +data Assembler a + = AllocPtr (IO BCOPtr) (Word -> Assembler a) + | AllocLit [BCONPtr] (Word -> Assembler a) + | AllocLabel Word16 (Assembler a) + | Emit Word16 [Operand] (Assembler a) + | NullAsm a + deriving (Functor) + +instance Applicative Assembler where + pure = NullAsm + (<*>) = ap + +instance Monad Assembler where + NullAsm x >>= f = f x + AllocPtr p k >>= f = AllocPtr p (k >=> f) + AllocLit l k >>= f = AllocLit l (k >=> f) + AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) + Emit w ops k >>= f = Emit w ops (k >>= f) + +ioptr :: IO BCOPtr -> Assembler Word +ioptr p = AllocPtr p return + +ptr :: BCOPtr -> Assembler Word +ptr = ioptr . return + +lit :: [BCONPtr] -> Assembler Word +lit l = AllocLit l return + +label :: Word16 -> Assembler () +label w = AllocLabel w (return ()) + +emit :: Word16 -> [Operand] -> Assembler () +emit w ops = Emit w ops (return ()) + +type LabelEnv = Word16 -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + SmallOp _ -> False + Op w -> isLarge w + LabelOp _ -> long_jumps +-- LargeOp _ -> True + +runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a +runAsm dflags long_jumps e = go + where + go (NullAsm x) = return x + go (AllocPtr p_io k) = do + p <- lift p_io + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_p1 = addToSS st_p0 p + in (sizeSS st_p0, (st_i0,st_l0,st_p1)) + go $ k w + go (AllocLit lits k) = do + w <- state $ \(st_i0,st_l0,st_p0) -> + let st_l1 = addListToSS st_l0 lits + in (sizeSS st_l0, (st_i0,st_l1,st_p0)) + go $ k w + go (AllocLabel _ k) = go k + go (Emit w ops k) = do + let largeOps = any (largeOp long_jumps) ops + opcode + | largeOps = largeArgInstr w + | otherwise = w + words = concatMap expand ops + expand (SmallOp w) = [w] + expand (LabelOp w) = expand (Op (e w)) + expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w] +-- expand (LargeOp w) = largeArg dflags w + state $ \(st_i0,st_l0,st_p0) -> + let st_i1 = addListToSS st_i0 (opcode : words) + in ((), (st_i1,st_l0,st_p0)) + go k + +type LabelEnvMap = Map Word16 Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) +inspectAsm dflags long_jumps initial_offset + = go (InspectState initial_offset 0 0 Map.empty) + where + go s (NullAsm _) = (instrCount s, lblEnv s) + go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) + where n = ptrCount s + go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) + where n = litCount s + go s (AllocLabel lbl k) = go s' k + where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } + go s (Emit _ ops k) = go s' k + where + s' = s { instrCount = instrCount s + size } + size = sum (map count ops) + 1 + largeOps = any (largeOp long_jumps) ops + count (SmallOp _) = 1 + count (LabelOp _) = count (Op 0) + count (Op _) = if largeOps then largeArg16s dflags else 1 +-- count (LargeOp _) = largeArg16s dflags + +-- Bring in all the bci_ bytecode constants. +#include "rts/Bytecodes.h" + +largeArgInstr :: Word16 -> Word16 +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +largeArg :: DynFlags -> Word -> [Word16] +largeArg dflags w + | wORD_SIZE_IN_BITS dflags == 64 + = [fromIntegral (w `shiftR` 48), + fromIntegral (w `shiftR` 32), + fromIntegral (w `shiftR` 16), + fromIntegral w] + | wORD_SIZE_IN_BITS dflags == 32 + = [fromIntegral (w `shiftR` 16), + fromIntegral w] + | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" + +largeArg16s :: DynFlags -> Word +largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4 + | otherwise = 2 + +assembleI :: DynFlags + -> BCInstr + -> Assembler () +assembleI dflags i = case i of + STKCHECK n -> emit bci_STKCHECK [Op n] + PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] + PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] + PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] + PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1] + PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1] + PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1] + PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1] + PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1] + PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_G [Op p] + PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_ALTS [Op p] + PUSH_ALTS_UNLIFTED proto pk + -> do let ul_bco = assembleBCO dflags proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit (push_alts pk) [Op p] + PUSH_PAD8 -> emit bci_PUSH_PAD8 [] + PUSH_PAD16 -> emit bci_PUSH_PAD16 [] + PUSH_PAD32 -> emit bci_PUSH_PAD32 [] + PUSH_UBX8 lit -> do np <- literal lit + emit bci_PUSH_UBX8 [Op np] + PUSH_UBX16 lit -> do np <- literal lit + emit bci_PUSH_UBX16 [Op np] + PUSH_UBX32 lit -> do np <- literal lit + emit bci_PUSH_UBX32 [Op np] + PUSH_UBX lit nws -> do np <- literal lit + emit bci_PUSH_UBX [Op np, SmallOp nws] + + PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] + ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] + ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] + ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] + MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] + MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] + UNPACK n -> emit bci_UNPACK [SmallOp n] + PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] + emit bci_PACK [Op itbl_no, SmallOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit bci_CASEFAIL [] + SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] + JMP l -> emit bci_JMP [LabelOp l] + ENTER -> emit bci_ENTER [] + RETURN -> emit bci_RETURN [] + RETURN_UBX rep -> emit (return_ubx rep) [] + CCALL off m_addr i -> do np <- addr m_addr + emit bci_CCALL [SmallOp off, Op np, SmallOp i] + BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray + q <- int (getKey uniq) + np <- addr cc + emit bci_BRK_FUN [Op p1, SmallOp index, + Op q, Op np] + + where + literal (LitLabel fs (Just sz) _) + | platformOS (targetPlatform dflags) == OSMinGW32 + = litlabel (appendFS fs (mkFastString ('@':show sz))) + -- On Windows, stdcall labels have a suffix indicating the no. of + -- arg words, e.g. foo@8. testcase: ffi012(ghci) + literal (LitLabel fs _ _) = litlabel fs + literal LitNullAddr = int 0 + literal (LitFloat r) = float (fromRational r) + literal (LitDouble r) = double (fromRational r) + literal (LitChar c) = int (ord c) + literal (LitString bs) = lit [BCONPtrStr bs] + -- LitString requires a zero-terminator when emitted + literal (LitNumber nt i _) = case nt of + LitNumInt -> int (fromIntegral i) + LitNumWord -> int (fromIntegral i) + LitNumInt64 -> int64 (fromIntegral i) + LitNumWord64 -> int64 (fromIntegral i) + LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger" + LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural" + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most + -- likely to elicit a crash (rather than corrupt memory) in case absence + -- analysis messed up. + literal LitRubbish = int 0 + + litlabel fs = lit [BCONPtrLbl fs] + addr (RemotePtr a) = words [fromIntegral a] + float = words . mkLitF + double = words . mkLitD dflags + int = words . mkLitI + int64 = words . mkLitI64 dflags + words ws = lit (map BCONPtrWord ws) + word w = words [w] + +isLarge :: Word -> Bool +isLarge n = n > 65535 + +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D +push_alts V16 = error "push_alts: vector" +push_alts V32 = error "push_alts: vector" +push_alts V64 = error "push_alts: vector" + +return_ubx :: ArgRep -> Word16 +return_ubx V = bci_RETURN_V +return_ubx P = bci_RETURN_P +return_ubx N = bci_RETURN_N +return_ubx L = bci_RETURN_L +return_ubx F = bci_RETURN_F +return_ubx D = bci_RETURN_D +return_ubx V16 = error "return_ubx: vector" +return_ubx V32 = error "return_ubx: vector" +return_ubx V64 = error "return_ubx: vector" + +-- 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 :: DynFlags -> Double -> [Word] +mkLitI64 :: DynFlags -> 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 dflags d + | wORD_SIZE dflags == 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 dflags == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + | otherwise + = panic "mkLitD: Bad wORD_SIZE" + +mkLitI64 dflags ii + | wORD_SIZE dflags == 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 dflags == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + | otherwise + = panic "mkLitI64: Bad wORD_SIZE" + +mkLitI i = [fromIntegral i :: Word] + +iNTERP_STACK_CHECK_THRESH :: Int +iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs new file mode 100644 index 0000000000..40a107756d --- /dev/null +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Generate infotables for interpreter-made bytecodes +module GHC.ByteCode.InfoTable ( mkITbls ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Types +import GHC.Runtime.Interpreter +import DynFlags +import HscTypes +import Name ( Name, getName ) +import NameEnv +import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) +import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import GHC.Types.RepType +import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) +import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import Util +import Panic + +{- + Manufacturing of info tables for DataCons +-} + +-- Make info tables for the data decls in this module +mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv +mkITbls hsc_env tcs = + foldr plusNameEnv emptyNameEnv <$> + mapM (mkITbl hsc_env) (filter isDataTyCon tcs) + where + mkITbl :: HscEnv -> TyCon -> IO ItblEnv + mkITbl hsc_env tc + | dcs `lengthIs` n -- paranoia; this is an assertion. + = make_constr_itbls hsc_env dcs + where + dcs = tyConDataCons tc + n = tyConFamilySize tc + mkITbl _ _ = panic "mkITbl" + +mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv +mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] + +-- Assumes constructors are numbered from zero, not one +make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv +make_constr_itbls hsc_env cons = + mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) + where + dflags = hsc_dflags hsc_env + + mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) + mk_itbl dcon conNo = do + let rep_args = [ NonVoid prim_rep + | arg <- dataConRepArgTys dcon + , prim_rep <- typePrimRep arg ] + + (tot_wds, ptr_wds) = + mkVirtConstrSizes dflags rep_args + + ptrs' = ptr_wds + nptrs' = tot_wds - ptr_wds + nptrs_really + | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' + | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' + + descr = dataConIdentity dcon + + r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really + conNo (tagForCon dflags dcon) descr) + return (getName dcon, ItblPtr r) diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs new file mode 100644 index 0000000000..d6c9cd5391 --- /dev/null +++ b/compiler/GHC/ByteCode/Instr.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE CPP, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode instruction definitions +module GHC.ByteCode.Instr ( + BCInstr(..), ProtoBCO(..), bciStackUse, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Types +import GHCi.RemoteTypes +import GHCi.FFI (C_ffi_cif) +import GHC.StgToCmm.Layout ( ArgRep(..) ) +import PprCore +import Outputable +import FastString +import Name +import Unique +import Id +import CoreSyn +import Literal +import DataCon +import VarSet +import PrimOp +import GHC.Runtime.Heap.Layout + +import Data.Word +import GHC.Stack.CCS (CostCentre) + +-- ---------------------------------------------------------------------------- +-- Bytecode instructions + +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from, for debugging only + protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), + -- malloc'd pointers + protoBCOFFIs :: [FFIInfo] + } + +type LocalLabel = Word16 + +data BCInstr + -- Messing with the stack + = STKCHECK Word + + -- Push locals (existing bits of the stack) + | PUSH_L !Word16{-offset-} + | PUSH_LL !Word16 !Word16{-2 offsets-} + | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} + + -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., + -- the stack will grow by 8, 16 or 32 bits) + | PUSH8 !Word16 + | PUSH16 !Word16 + | PUSH32 !Word16 + + -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the + -- value will take the whole word on the stack (i.e., the stack will grow by + -- a word) + -- This is useful when extracting a packed constructor field for further use. + -- Currently we expect all values on the stack to take full words, except for + -- the ones used for PACK (i.e., actually constracting new data types, in + -- which case we use PUSH{8,16,32}) + | PUSH8_W !Word16 + | PUSH16_W !Word16 + | PUSH32_W !Word16 + + -- 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) ArgRep + + -- Pushing 8, 16 and 32 bits of padding (for constructors). + | PUSH_PAD8 + | PUSH_PAD16 + | PUSH_PAD32 + + -- Pushing literals + | PUSH_UBX8 Literal + | PUSH_UBX16 Literal + | PUSH_UBX32 Literal + | PUSH_UBX Literal Word16 + -- push this int/float/double/addr, on the stack. Word16 + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- 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 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 Word16{-this many-} Word16{-down by this much-} + + -- To do with the heap + | ALLOC_AP !Word16 -- make an AP with this many payload words + | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words + | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} + | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} + | UNPACK !Word16 -- unpack N words from t.o.s Constr + | PACK DataCon !Word16 + -- 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_W Word LocalLabel + | TESTEQ_W Word LocalLabel + | TESTLT_F Float LocalLabel + | TESTEQ_F Float LocalLabel + | TESTLT_D Double LocalLabel + | TESTEQ_D Double LocalLabel + + -- The Word16 value is a constructor number and therefore + -- stored in the insn stream rather than as an offset into + -- the literal pool. + | TESTLT_P Word16 LocalLabel + | TESTEQ_P Word16 LocalLabel + + | CASEFAIL + | JMP LocalLabel + + -- For doing calls to C (via glue code generated by libffi) + | CCALL Word16 -- stack frame size + (RemotePtr C_ffi_cif) -- addr of the glue code + Word16 -- flags. + -- + -- 0x1: call is interruptible + -- 0x2: call is unsafe + -- + -- (XXX: inefficient, but I don't know + -- what the alignment constraints are.) + + -- For doing magic ByteArray passing to foreign calls + | SWIZZLE Word16 -- to the ptr N words down the stack, + Word16 -- add M (interpreted as a signed 16-bit entity) + + -- To Infinity And Beyond + | ENTER + | RETURN -- return a lifted value + | RETURN_UBX ArgRep -- return an unlifted value, here's its rep + + -- Breakpoints + | BRK_FUN Word16 Unique (RemotePtr CostCentre) + +-- ----------------------------------------------------------------------------- +-- Printing bytecode instructions + +instance Outputable a => Outputable (ProtoBCO a) where + ppr (ProtoBCO { protoBCOName = name + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity + , protoBCOExpr = origin + , protoBCOFFIs = ffis }) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show ffis) <> colon) + $$ nest 3 (case origin of + Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) + (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' + Right rhs -> pprCoreExprShort (deAnnotate rhs)) + $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap) + $$ nest 3 (vcat (map ppr instrs)) + +-- Print enough of the Core expression to enable the reader to find +-- the expression in the -ddump-prep output. That is, we need to +-- include at least a binder. + +pprCoreExprShort :: CoreExpr -> SDoc +pprCoreExprShort expr@(Lam _ _) + = let + (bndrs, _) = collectBinders expr + in + char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..." + +pprCoreExprShort (Case _expr var _ty _alts) + = text "case of" <+> ppr var + +pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ...")) +pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ...")) + +pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e +pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T" + +pprCoreExprShort e = pprCoreExpr e + +pprCoreAltShort :: CoreAlt -> SDoc +pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr + +instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> ppr n + ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset + ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 + ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 + ppr (PUSH8 offset) = text "PUSH8 " <+> ppr offset + ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset + ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset + ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset + ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset + ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset + 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) = hang (text "PUSH_BCO") 2 (ppr bco) + ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) + ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) + + ppr PUSH_PAD8 = text "PUSH_PAD8" + ppr PUSH_PAD16 = text "PUSH_PAD16" + ppr PUSH_PAD32 = text "PUSH_PAD32" + + ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit + ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit + ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit + ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + + ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d + ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz + ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz + ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," + <+> ppr offset <+> text "stkoff" + ppr (UNPACK sz) = text "UNPACK " <+> ppr sz + ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz + ppr (LABEL lab) = text "__" <> ppr lab <> colon + ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab + ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab + ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab + ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab + ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab + ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab + ppr CASEFAIL = text "CASEFAIL" + ppr (JMP lab) = text "JMP" <+> ppr lab + ppr (CCALL off marshall_addr flags) = text "CCALL " <+> ppr off + <+> text "marshall code at" + <+> text (show marshall_addr) + <+> (case flags of + 0x1 -> text "(interruptible)" + 0x2 -> text "(unsafe)" + _ -> empty) + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff + <+> text "by" <+> ppr n + ppr ENTER = text "ENTER" + ppr RETURN = text "RETURN" + ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>" + +-- ----------------------------------------------------------------------------- +-- 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 -> Word +protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) + +bciStackUse :: BCInstr -> Word +bciStackUse STKCHECK{} = 0 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_LLL{} = 3 +bciStackUse PUSH8{} = 1 -- overapproximation +bciStackUse PUSH16{} = 1 -- overapproximation +bciStackUse PUSH32{} = 1 -- overapproximation on 64bit arch +bciStackUse PUSH8_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH16_W{} = 1 -- takes exactly 1 word +bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word +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_PAD8) = 1 -- overapproximation +bciStackUse (PUSH_PAD16) = 1 -- overapproximation +bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX8 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX16 _) = 1 -- overapproximation +bciStackUse (PUSH_UBX32 _) = 1 -- overapproximation on 64bit arch +bciStackUse (PUSH_UBX _ nw) = fromIntegral 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_AP_NOUPD{} = 1 +bciStackUse ALLOC_PAP{} = 1 +bciStackUse (UNPACK sz) = fromIntegral sz +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 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 +bciStackUse BRK_FUN{} = 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 diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs new file mode 100644 index 0000000000..69bdb63a91 --- /dev/null +++ b/compiler/GHC/ByteCode/Linker.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Linker ( + ClosureEnv, emptyClosureEnv, extendClosureEnv, + linkBCO, lookupStaticPtr, + lookupIE, + nameToCLabel, linkFail + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray +import SizedSeq + +import GHC.Runtime.Interpreter +import GHC.ByteCode.Types +import HscTypes +import Name +import NameEnv +import PrimOp +import Module +import FastString +import Panic +import Outputable +import Util + +-- Standard libraries +import Data.Array.Unboxed +import Foreign.Ptr +import GHC.Exts + +{- + Linking interpretables into something we can run +-} + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +emptyClosureEnv :: ClosureEnv +emptyClosureEnv = emptyNameEnv + +extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv +extendClosureEnv cl_env pairs + = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] + +{- + Linking interpretables into something we can run +-} + +linkBCO + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> UnlinkedBCO + -> IO ResolvedBCO +linkBCO hsc_env ie ce bco_ix breakarray + (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do + -- fromIntegral Word -> Word64 should be a no op if Word is Word64 + -- otherwise it will result in a cast to longlong on 32bit systems. + lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0) + ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0) + return (ResolvedBCO isLittleEndian arity insns bitmap + (listArray (0, fromIntegral (sizeSS lits0)-1) lits) + (addListToSS emptySS ptrs)) + +lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral hsc_env _ (BCONPtrLbl sym) = do + Ptr a# <- lookupStaticPtr hsc_env sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral hsc_env ie (BCONPtrItbl nm) = do + Ptr a# <- lookupIE hsc_env ie nm + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral _ _ (BCONPtrStr _) = + -- should be eliminated during assembleBCOs + panic "lookupLiteral: BCONPtrStr" + +lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ()) +lookupStaticPtr hsc_env addr_of_label_string = do + m <- lookupSymbol hsc_env addr_of_label_string + case m of + Just ptr -> return ptr + Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" + (unpackFS addr_of_label_string) + +lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ()) +lookupIE hsc_env ie con_nm = + case lookupNameEnv ie con_nm of + Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) + Nothing -> do -- try looking up in the object files. + let sym_to_find1 = nameToCLabel con_nm "con_info" + m <- lookupSymbol hsc_env sym_to_find1 + case m of + Just addr -> return addr + Nothing + -> do -- perhaps a nullary constructor? + let sym_to_find2 = nameToCLabel con_nm "static_info" + n <- lookupSymbol hsc_env sym_to_find2 + case n of + Just addr -> return addr + Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" + (unpackFS sym_to_find1 ++ " or " ++ + unpackFS sym_to_find2) + +lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp hsc_env primop = do + let sym_to_find = primopToCLabel primop "closure" + m <- lookupSymbol hsc_env (mkFastString sym_to_find) + case m of + Just p -> return (toRemotePtr p) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find + +resolvePtr + :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray + -> BCOPtr + -> IO ResolvedBCOPtr +resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm) + | Just ix <- lookupNameEnv bco_ix nm = + return (ResolvedBCORef ix) -- ref to another BCO in this group + | Just (_, rhv) <- lookupNameEnv ce nm = + return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) + | otherwise = + ASSERT2(isExternalName nm, ppr nm) + do let sym_to_find = nameToCLabel nm "closure" + m <- lookupSymbol hsc_env sym_to_find + case m of + Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) +resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) = + ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op +resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) = + ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco +resolvePtr _ _ _ _ breakarray BCOPtrBreakArray = + return (ResolvedBCOPtrBreakArray breakarray) + +linkFail :: String -> String -> IO a +linkFail who what + = throwGhcExceptionIO (ProgramError $ + unlines [ "",who + , "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 report this as a GHC bug:" + , " https://www.haskell.org/ghc/reportabug" + ]) + + +nameToCLabel :: Name -> String -> FastString +nameToCLabel n suffix = mkFastString label + where + encodeZ = zString . zEncodeFS + (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n + packagePart = encodeZ (unitIdFS pkgKey) + modulePart = encodeZ (moduleNameFS modName) + occPart = encodeZ (occNameFS (nameOccName n)) + + label = concat + [ if pkgKey == mainUnitId then "" else packagePart ++ "_" + , modulePart + , '_':occPart + , '_':suffix + ] + + +primopToCLabel :: PrimOp -> String -> String +primopToCLabel primop suffix = concat + [ "ghczmprim_GHCziPrimopWrappers_" + , zString (zEncodeFS (occNameFS (primOpOcc primop))) + , '_':suffix + ] diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs new file mode 100644 index 0000000000..ce80c53279 --- /dev/null +++ b/compiler/GHC/ByteCode/Types.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler types +module GHC.ByteCode.Types + ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) + , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) + , ItblEnv, ItblPtr(..) + , CgBreakInfo(..) + , ModBreaks (..), BreakIndex, emptyModBreaks + , CCostCentre + ) where + +import GhcPrelude + +import FastString +import Id +import Name +import NameEnv +import Outputable +import PrimOp +import SizedSeq +import Type +import SrcLoc +import GHCi.BreakArray +import GHCi.RemoteTypes +import GHCi.FFI +import Control.DeepSeq + +import Foreign +import Data.Array +import Data.Array.Base ( UArray(..) ) +import Data.ByteString (ByteString) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes) +import GHC.Exts.Heap +import GHC.Stack.CCS + +-- ----------------------------------------------------------------------------- +-- Compiled Byte Code + +data CompiledByteCode = CompiledByteCode + { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings + , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls + , bc_ffis :: [FFIInfo] -- ffi blocks we allocated + , bc_strs :: [RemotePtr ()] -- malloc'd strings + , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not + -- creating breakpoints, for some reason) + } + -- ToDo: we're not tracking strings that we malloc'd +newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) + deriving (Show, NFData) + +instance Outputable CompiledByteCode where + ppr CompiledByteCode{..} = ppr bc_bcos + +-- Not a real NFData instance, because ModBreaks contains some things +-- we can't rnf +seqCompiledByteCode :: CompiledByteCode -> () +seqCompiledByteCode CompiledByteCode{..} = + rnf bc_bcos `seq` + rnf (nameEnvElts bc_itbls) `seq` + rnf bc_ffis `seq` + rnf bc_strs `seq` + rnf (fmap seqModBreaks bc_breaks) + +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) + deriving (Show, NFData) + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: !Name, + unlinkedBCOArity :: {-# UNPACK #-} !Int, + unlinkedBCOInstrs :: !(UArray Int Word16), -- insns + unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap + unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + } + +instance NFData UnlinkedBCO where + rnf UnlinkedBCO{..} = + rnf unlinkedBCOLits `seq` + rnf unlinkedBCOPtrs + +data BCOPtr + = BCOPtrName !Name + | BCOPtrPrimOp !PrimOp + | BCOPtrBCO !UnlinkedBCO + | BCOPtrBreakArray -- a pointer to this module's BreakArray + +instance NFData BCOPtr where + rnf (BCOPtrBCO bco) = rnf bco + rnf x = x `seq` () + +data BCONPtr + = BCONPtrWord {-# UNPACK #-} !Word + | BCONPtrLbl !FastString + | BCONPtrItbl !Name + | BCONPtrStr !ByteString + +instance NFData BCONPtr where + rnf x = x `seq` () + +-- | Information about a breakpoint that we know at code-generation time +data CgBreakInfo + = CgBreakInfo + { cgb_vars :: [Maybe (Id,Word16)] + , cgb_resty :: Type + } +-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval + +-- Not a real NFData instance because we can't rnf Id or Type +seqCgBreakInfo :: CgBreakInfo -> () +seqCgBreakInfo CgBreakInfo{..} = + rnf (map snd (catMaybes (cgb_vars))) `seq` + seqType cgb_resty + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeSS lits), text "lits", + ppr (sizeSS ptrs), text "ptrs" ] + +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info)) + +-- ----------------------------------------------------------------------------- +-- Breakpoints + +-- | Breakpoint index +type BreakIndex = Int + +-- | C CostCentre type +data CCostCentre + +-- | All the information about the breakpoints for a module +data ModBreaks + = ModBreaks + { modBreaks_flags :: ForeignRef BreakArray + -- ^ The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) + -- ^ Array pointing to cost centre for each breakpoint + , modBreaks_breakInfo :: IntMap CgBreakInfo + -- ^ info about each breakpoint from the bytecode generator + } + +seqModBreaks :: ModBreaks -> () +seqModBreaks ModBreaks{..} = + rnf modBreaks_flags `seq` + rnf modBreaks_locs `seq` + rnf modBreaks_vars `seq` + rnf modBreaks_decls `seq` + rnf modBreaks_ccs `seq` + rnf (fmap seqCgBreakInfo modBreaks_breakInfo) + +-- | Construct an empty ModBreaks +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- ToDo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] + , modBreaks_ccs = array (0,-1) [] + , modBreaks_breakInfo = IntMap.empty + } diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 8850f2e19a..f8cf5789d7 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -31,7 +31,7 @@ import CostCentre import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Node -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm.Expr import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index 9200daec57..db9603c524 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -8,7 +8,7 @@ module GHC.Cmm.CallConv ( import GhcPrelude import GHC.Cmm.Expr -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index 8d19e7fdb9..1d8b44776d 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -35,7 +35,7 @@ import DynFlags import FastString import ForeignCall import OrdList -import GHC.Runtime.Layout (ByteOff) +import GHC.Runtime.Heap.Layout (ByteOff) import UniqSupply import Util import Panic diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 9e12fb170d..6948f78969 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -38,7 +38,7 @@ import GhcPrelude import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Data.Bitmap import Stream (Stream) import qualified Stream diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index d90c776c88..4b0532eef1 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -27,7 +27,7 @@ import GHC.Cmm.Utils import DynFlags import Maybes import Outputable -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import UniqSupply import CostCentre import GHC.StgToCmm.Heap diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index f6dda7728c..b34de95982 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -18,7 +18,7 @@ import GHC.Cmm.Graph import ForeignCall import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 0764d6d8a3..f7cee80145 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -35,7 +35,7 @@ import DynFlags import FastString import ForeignCall import Outputable -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import CoreSyn (Tickish) import qualified Unique as U diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 886f429611..ed2d95a283 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -231,7 +231,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel import GHC.Cmm.Monad -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import Lexer import CostCentre diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index eda440040d..c62f7eb3df 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -75,7 +75,7 @@ import GhcPrelude import TyCon ( PrimRep(..), PrimElemRep(..) ) import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs new file mode 100644 index 0000000000..f6ceadf1be --- /dev/null +++ b/compiler/GHC/CoreToByteCode.hs @@ -0,0 +1,2036 @@ +{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fprof-auto-top #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | GHC.CoreToByteCode: Generate bytecode from Core +module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Instr +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.Runtime.Interpreter +import GHCi.FFI +import GHCi.RemoteTypes +import BasicTypes +import DynFlags +import Outputable +import GHC.Platform +import Name +import MkId +import Id +import Var ( updateVarType ) +import ForeignCall +import HscTypes +import CoreUtils +import CoreSyn +import PprCore +import Literal +import PrimOp +import CoreFVs +import Type +import GHC.Types.RepType +import DataCon +import TyCon +import Util +import VarSet +import TysPrim +import TyCoPpr ( pprType ) +import ErrUtils +import Unique +import FastString +import Panic +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Layout +import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) +import GHC.Data.Bitmap +import OrdList +import Maybes +import VarEnv + +import Data.List +import Foreign +import Control.Monad +import Data.Char + +import UniqSupply +import Module + +import Control.Exception +import Data.Array +import Data.ByteString (ByteString) +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified FiniteMap as Map +import Data.Ord +import GHC.Stack.CCS +import Data.Either ( partitionEithers ) + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module + +byteCodeGen :: HscEnv + -> Module + -> CoreProgram + -> [TyCon] + -> Maybe ModBreaks + -> IO CompiledByteCode +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks + = withTiming dflags + (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- Split top-level binds into strings and others. + -- See Note [generating code for top-level string literal bindings]. + let (strings, flatBinds) = partitionEithers $ do -- list monad + (bndr, rhs) <- flattenBinds binds + return $ case exprIsTickedString_maybe rhs of + Just str -> Left (bndr, str) + _ -> Right (bndr, simpleFreeVars rhs) + stringPtrs <- allocateTopStrings hsc_env strings + + us <- mkSplitUniqSupply 'y' + (BcM_State{..}, proto_bcos) <- + runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ + mapM schemeTopBind flatBinds + + when (notNull ffis) + (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs + "Proto-BCOs" FormatByteCode + (vcat (intersperse (char ' ') (map ppr proto_bcos))) + + cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) + (case modBreaks of + Nothing -> Nothing + Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) + + -- Squash space leaks in the CompiledByteCode. This is really + -- important, because when loading a set of modules into GHCi + -- we don't touch the CompiledByteCode until the end when we + -- do linking. Forcing out the thunks here reduces space + -- usage by more than 50% when loading a large number of + -- modules. + evaluate (seqCompiledByteCode cbc) + + return cbc + + where dflags = hsc_dflags hsc_env + +allocateTopStrings + :: HscEnv + -> [(Id, ByteString)] + -> IO [(Var, RemotePtr ())] +allocateTopStrings hsc_env topStrings = do + let !(bndrs, strings) = unzip topStrings + ptrs <- iservCmd hsc_env $ MallocStrings strings + return $ zip bndrs ptrs + +{- +Note [generating code for top-level string literal bindings] + +Here is a summary on how the byte code generator deals with top-level string +literals: + +1. Top-level string literal bindings are separated from the rest of the module. + +2. The strings are allocated via iservCmd, in allocateTopStrings + +3. The mapping from binders to allocated strings (topStrings) are maintained in + BcM and used when generating code for variable references. +-} + +-- ----------------------------------------------------------------------------- +-- Generating byte code for an expression + +-- Returns: the root BCO for this expression +coreExprToBCOs :: HscEnv + -> Module + -> CoreExpr + -> IO UnlinkedBCO +coreExprToBCOs hsc_env this_mod expr + = withTiming dflags + (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- 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") + + -- the uniques are needed to generate fresh variables when we introduce new + -- let bindings for ticked expressions + us <- mkSplitUniqSupply 'y' + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) + <- runBc hsc_env us this_mod Nothing emptyVarEnv $ + schemeR [] (invented_name, simpleFreeVars expr) + + when (notNull mallocd) + (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?") + + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + (ppr proto_bco) + + assembleOneBCO hsc_env proto_bco + where dflags = hsc_dflags hsc_env + +-- The regular freeVars function gives more information than is useful to +-- us here. We need only the free variables, not everything in an FVAnn. +-- Historical note: At one point FVAnn was more sophisticated than just +-- a set. Now it isn't. So this function is much simpler. Keeping it around +-- so that if someone changes FVAnn, they will get a nice type error right +-- here. +simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet +simpleFreeVars = freeVars + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr + +newtype ByteOff = ByteOff Int + deriving (Enum, Eq, Integral, Num, Ord, Real) + +newtype WordOff = WordOff Int + deriving (Enum, Eq, Integral, Num, Ord, Real) + +wordsToBytes :: DynFlags -> WordOff -> ByteOff +wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral + +-- Used when we know we have a whole number of words +bytesToWords :: DynFlags -> ByteOff -> WordOff +bytesToWords dflags (ByteOff bytes) = + let (q, r) = bytes `quotRem` (wORD_SIZE dflags) + in if r == 0 + then fromIntegral q + else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes + +wordSize :: DynFlags -> ByteOff +wordSize dflags = ByteOff (wORD_SIZE dflags) + +type Sequel = ByteOff -- back off to this depth before ENTER + +type StackDepth = ByteOff + +-- | Maps Ids to their stack depth. This allows us to avoid having to mess with +-- it after each push/pop. +type BCEnv = Map Id StackDepth -- To find vars on the stack + +{- +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) + $$ text "end-env" + where + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep 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 + :: DynFlags + -> name + -> BCInstrList + -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) + -- ^ original expression; for debugging only + -> Int + -> Word16 + -> [StgWord] + -> Bool -- True <=> is a return point, rather than a function + -> [FFIInfo] + -> ProtoBCO name +mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOFFIs = ffis + } + 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 one in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : peep_d + | otherwise + = peep_d -- the supposedly common case + + -- We assume that this sum doesn't wrap + stack_usage = 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 :: DynFlags -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits dflags (rep : args) + | isFollowableArg rep = False : argBits dflags args + | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding + +schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do + dflags <- getDynFlags + -- 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. + -- ioToBc (putStrLn $ "top level BCO") + emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (getName 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 +-- name of 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. + -> (Name, AnnExpr Id DVarSet) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined + | otherwise +-} + = schemeR_wrk fvs nm rhs (collect rhs) + +-- If an expression is a lambda (after apply bcView), return the +-- list of arguments to the lambda (in R-to-L order) and the +-- underlying expression +collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) +collect (_, e) = go [] e + where + go xs e | Just e' <- bcView e = go xs e' + go xs (AnnLam x (_,e)) + | typePrimRep (idType x) `lengthExceeds` 1 + = multiValException + | otherwise + = go (x:xs) e + go xs not_lambda = (reverse xs, not_lambda) + +schemeR_wrk + :: [Id] + -> Name + -> AnnExpr Id DVarSet -- expression e, for debugging only + -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e + -> BcM (ProtoBCO Name) +schemeR_wrk fvs nm original_body (args, body) + = do + dflags <- getDynFlags + 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 + + -- Stack arguments always take a whole number of words, we never pack + -- them unlike constructor fields. + szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args + sum_szsb_args = sum szsb_args + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) + + -- make the arg bitmap + bits = argBits dflags (reverse (map bcIdArgRep all_args)) + bitmap_size = genericLength bits + bitmap = mkBitmap dflags bits + body_code <- schemeER_wrk sum_szsb_args p_init body + + emitBc (mkProtoBCO dflags nm body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) + +-- introduce break instructions for ticked expressions +schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +schemeER_wrk d p rhs + | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs + = do code <- schemeE d 0 p newRhs + cc_arr <- getCCArray + this_mod <- moduleName <$> getCurrentModule + dflags <- getDynFlags + let idOffSets = getVarOffSets dflags d p fvs + let breakInfo = CgBreakInfo + { cgb_vars = idOffSets + , cgb_resty = exprType (deAnnotate' newRhs) + } + newBreakInfo tick_no breakInfo + dflags <- getDynFlags + let cc | interpreterProfiled dflags = cc_arr ! tick_no + | otherwise = toRemotePtr nullPtr + let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc + return $ breakInstr `consOL` code + | otherwise = schemeE d 0 p rhs + +getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)] +getVarOffSets dflags depth env = map getOffSet + where + getOffSet id = case lookupBCEnv_maybe id env of + Nothing -> Nothing + Just offset -> + -- michalt: I'm not entirely sure why we need the stack + -- adjustment by 2 here. I initially thought that there's + -- something off with getIdValFromApStack (the only user of this + -- value), but it looks ok to me. My current hypothesis is that + -- this "adjustment" is needed due to stack manipulation for + -- BRK_FUN in Interpreter.c In any case, this is used only when + -- we trigger a breakpoint. + let !var_depth_ws = + trunc16W $ bytesToWords dflags (depth - offset) + 2 + in Just (id, var_depth_ws) + +truncIntegral16 :: Integral a => a -> Word16 +truncIntegral16 w + | w > fromIntegral (maxBound :: Word16) + = panic "stack depth overflow" + | otherwise + = fromIntegral w + +trunc16B :: ByteOff -> Word16 +trunc16B = truncIntegral16 + +trunc16W :: WordOff -> Word16 +trunc16W = truncIntegral16 + +fvsToEnv :: BCEnv -> DVarSet -> [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 <- dVarSetElems fvs, + isId v, -- Could be a type variable + v `Map.member` p] + +-- ----------------------------------------------------------------------------- +-- schemeE + +returnUnboxedAtom + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr' Id DVarSet + -> ArgRep + -> BcM BCInstrList +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnboxedAtom d s p e e_rep = do + dflags <- getDynFlags + (push, szb) <- pushAtom d p e + return (push -- value onto stack + `appOL` mkSlideB dflags szb (d - s) -- clear to sequel + `snocOL` RETURN_UBX e_rep) -- go + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE + :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +schemeE d s p e + | Just e' <- bcView e + = schemeE d s p e' + +-- Delegate tail-calls to schemeT. +schemeE d s p e@(AnnApp _ _) = schemeT d s p e + +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V + +schemeE d s p e@(AnnVar v) + -- See Note [Not-necessarily-lifted join points], step 3. + | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] + | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) + | otherwise = schemeT d s p e + +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 + = do -- Special case for a non-recursive let whose RHS is a + -- saturated constructor application. + -- Just allocate the constructor and carry on + alloc_code <- mkConAppCode d s p data_con args_r_to_l + dflags <- getDynFlags + let !d2 = d + wordSize dflags + body_code <- schemeE d2 s (Map.insert x d2 p) body + return (alloc_code `appOL` body_code) + +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (AnnLet binds (_,body)) = do + dflags <- getDynFlags + let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) + AnnRec xs_n_rhss -> unzip xs_n_rhss + n_binds = genericLength xs + + fvss = map (fvsToEnv p' . fst) rhss + + -- See Note [Not-necessarily-lifted join points], step 2. + (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss + + -- Sizes of free vars + size_w = trunc16W . idSizeW dflags + sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (genericLength . fst . collect) rhss' + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1 word. 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. + offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags)) + p' = Map.insertList (zipE xs' offsets) p + d' = d + wordsToBytes dflags n_binds + zipE = zipEqual "schemeE" + + -- ToDo: don't build thunks for things with no free variables + build_thunk + :: StackDepth + -> [Id] + -> Word16 + -> ProtoBCO Name + -> Word16 + -> Word16 + -> BcM BCInstrList + build_thunk _ [] size bco off arity + = return (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_szb) <- pushAtom dd p' (AnnVar fv) + more_push_code <- + build_thunk (dd + pushed_szb) fvs size bco off arity + return (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD sz + | otherwise = ALLOC_AP sz + mkAlloc sz arity = ALLOC_PAP arity sz + + is_tick = case binds of + AnnNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x rhs size arity off = do + bco <- schemeR fvs (getName x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity (trunc16W n) + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +-- Introduce a let binding for a ticked case expression. This rule +-- *should* only fire when the expression was not already let-bound +-- (the code gen for let bindings should take care of that). Todo: we +-- call exprFreeVars on a deAnnotated expression, this may not be the +-- best way to calculate the free vars but it seemed like the least +-- intrusive thing to do +schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) + | isLiftedTypeKind (typeKind ty) + = do id <- newId ty + -- Todo: is emptyVarSet correct on the next line? + let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id) + schemeE d s p letExp + + | otherwise + = do -- If the result type is not definitely lifted, then we must generate + -- let f = \s . tick<n> e + -- in f realWorld# + -- When we stop at the breakpoint, _result will have an unlifted + -- type and hence won't be bound in the environment, but the + -- breakpoint will otherwise work fine. + -- + -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where + -- r :: RuntimeRep is a variable. This can happen in the + -- continuations for a pattern-synonym matcher + -- match = /\(r::RuntimeRep) /\(a::TYPE r). + -- \(k :: Int -> a) \(v::T). + -- case v of MkV n -> k n + -- Here (k n) :: a :: Type r, so we don't know if it's lifted + -- or not; but that should be fine provided we add that void arg. + + id <- newId (mkVisFunTy realWorldStatePrimTy ty) + st <- newId realWorldStatePrimTy + let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp))) + (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id) + (emptyDVarSet, AnnVar realWorldPrimId))) + schemeE d s p letExp + + where + exp' = deAnnotate' exp + fvs = exprFreeVarsDSet exp' + ty = exprType exp' + +-- ignore other kinds of tick +schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs + +schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut + -- no alts: scrut is guaranteed to diverge + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) + -- Convert + -- case .... of x { (# V'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- because 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. + , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of + ([], [_]) + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + ([_], []) + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + _ -> Nothing + = res + +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) + | isUnboxedTupleCon dc + , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples + = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + +schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) + | isUnboxedTupleType (idType bndr) + , Just ty <- case typePrimRep (idType bndr) of + [_] -> Just (unwrapType (idType bndr)) + [] -> Just voidPrimTy + _ -> Nothing + -- handles any pattern with a single non-void binder; in particular I/O + -- monad returns (# RealWorld#, a #) + = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) + +schemeE d s p (AnnCase scrut bndr _ alts) + = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} + +schemeE _ _ _ expr + = pprPanic "GHC.CoreToByteCode.schemeE: unhandled case" + (pprCoreExpr (deAnnotate' expr)) + +-- Is this Id a not-necessarily-lifted join point? +-- See Note [Not-necessarily-lifted join points], step 1 +isNNLJoinPoint :: Id -> Bool +isNNLJoinPoint x = isJoinId x && + Just True /= isLiftedType_maybe (idType x) + +-- If necessary, modify this Id and body to protect not-necessarily-lifted join points. +-- See Note [Not-necessarily-lifted join points], step 2. +protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet) +protectNNLJoinPointBind x rhs@(fvs, _) + | isNNLJoinPoint x + = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs)) + + | otherwise + = (x, rhs) + +-- Update an Id's type to take a Void# argument. +-- Precondition: the Id is a not-necessarily-lifted join point. +-- See Note [Not-necessarily-lifted join points] +protectNNLJoinPointId :: Id -> Id +protectNNLJoinPointId x + = ASSERT( isNNLJoinPoint x ) + updateVarType (voidPrimTy `mkVisFunTy`) x + +{- + Ticked Expressions + ------------------ + + The idea is that the "breakpoint<n,fvs> E" is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression E. + +Note [Not-necessarily-lifted join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point variable is essentially a goto-label: it is, for example, +never used as an argument to another function, and it is called only +in tail position. See Note [Join points] and Note [Invariants on join points], +both in CoreSyn. Because join points do not compile to true, red-blooded +variables (with, e.g., registers allocated to them), they are allowed +to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points] +in CoreSyn.) + +However, in this byte-code generator, join points *are* treated just as +ordinary variables. There is no check whether a binding is for a join point +or not; they are all treated uniformly. (Perhaps there is a missed optimization +opportunity here, but that is beyond the scope of my (Richard E's) Thursday.) + +We thus must have *some* strategy for dealing with levity-polymorphic and +unlifted join points. Levity-polymorphic variables are generally not allowed +(though levity-polymorphic join points *are*; see Note [Invariants on join points] +in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly. +The questionable join points are *not-necessarily-lifted join points* +(NNLJPs). (Not having such a strategy led to #16509, which panicked in the +isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy: + +1. Detect NNLJPs. This is done in isNNLJoinPoint. + +2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the + type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.) + Note that functions are never levity-polymorphic, so this transformation + changes an NNLJP to a non-levity-polymorphic join point. This is done + in protectNNLJoinPointBind, called from the AnnLet case of schemeE. + +3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId), + being careful to note the new type of the NNLJP. This is done in the AnnVar + case of schemeE, with help from protectNNLJoinPointId. + +Here is an example. Suppose we have + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + join j :: a + j = error @r @a "bloop" + in case x of + A -> j + B -> j + C -> error @r @a "blurp" + +Our plan is to behave is if the code was + + f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). + let j :: (Void# -> a) + j = \ _ -> error @r @a "bloop" + in case x of + A -> j void# + B -> j void# + C -> error @r @a "blurp" + +It's a bit hacky, but it works well in practice and is local. I suspect the +Right Fix is to take advantage of join points as goto-labels. + +-} + +-- 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::V, b #) and treat +-- it simply as b -- since the representations are identical +-- (the V 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 :: StackDepth -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> AnnExpr' Id DVarSet + -> BcM BCInstrList + +schemeT d s p app + + -- Case 0 + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 + | Just (CCall ccall_spec) <- isFCallId_maybe fn + = if isSupportedCConv ccall_spec + then generateCCall d s p ccall_spec fn args_r_to_l + else unsupportedCConvException + + + -- Case 2: Constructor application + | Just con <- maybe_saturated_dcon + , isUnboxedTupleCon con + = case args_r_to_l of + [arg1,arg2] | isVAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> multiValException + + -- Case 3: Ordinary data constructor + | Just con <- maybe_saturated_dcon + = do alloc_con <- mkConAppCode d s p con args_r_to_l + dflags <- getDynFlags + return (alloc_con `appOL` + mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL` + ENTER) + + -- Case 4: Tail call of function + | otherwise + = doTailCall d s p fn args_r_to_l + + where + -- 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 + :: StackDepth + -> Sequel + -> BCEnv + -> DataCon -- The data constructor + -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order + -> BcM BCInstrList +mkConAppCode _ _ _ con [] -- Nullary constructor + = ASSERT( isNullaryRepDataCon con ) + return (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 _ p con args_r_to_l = + ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code + where + app_code = do + dflags <- getDynFlags + + -- The args are initially in reverse order, but mkVirtHeapOffsets + -- expects them to be left-to-right. + let non_voids = + [ NonVoid (prim_rep, arg) + | arg <- reverse args_r_to_l + , let prim_rep = atomPrimRep arg + , not (isVoidRep prim_rep) + ] + (_, _, args_offsets) = + mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids + + do_pushery !d (arg : args) = do + (push, arg_bytes) <- case arg of + (Padding l _) -> return $! pushPadding l + (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !d [] = do + let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d) + return (unitOL (PACK con n_arg_words)) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args_offsets) + + +-- ----------------------------------------------------------------------------- +-- 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 + :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList +unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: StackDepth + -> Sequel + -> BCEnv + -> Id + -> [AnnExpr' Id DVarSet] + -> 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) + dflags <- getDynFlags + ASSERT( sz == wordSize dflags ) return () + let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s) + return (push_fn `appOL` (slide `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 + dflags <- getDynFlags + instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + return (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 :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (P: P: P: P: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (P: P: P: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (P: P: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (P: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (V: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (N: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (F: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (D: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (L: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq _ + = panic "GHC.CoreToByteCode.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +doCase + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr Id DVarSet + -> Id + -> [AnnAlt Id DVarSet] + -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, + -- don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) bndr alts is_unboxed_tuple + | typePrimRep (idType bndr) `lengthExceeds` 1 + = multiValException + | otherwise + = do + dflags <- getDynFlags + let + profiling + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + + -- 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_size_b :: StackDepth + ret_frame_size_b = 2 * wordSize dflags + + -- The extra frame we push to save/restore the CCCS when profiling + save_ccs_size_b | profiling = 2 * wordSize dflags + | otherwise = 0 + + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_size_b :: StackDepth + unlifted_itbl_size_b | isAlgCase = 0 + | otherwise = wordSize dflags + + -- depth of stack after the return value has been pushed + d_bndr = + d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags 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_size_b + + -- Env in which to compile the alts, not including + -- any vars bound by the alts themselves + p_alts0 = Map.insert bndr d_bndr p + + p_alts = case is_unboxed_tuple of + Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0 + Nothing -> p_alts0 + + bndr_ty = idType bndr + isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple + + -- given an alt, return a discr and code for it. + codeAlt (DEFAULT, _, (_,rhs)) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) + + codeAlt alt@(_, bndrs, (_,rhs)) + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs + return (my_discr alt, rhs_code) + -- If an alt attempts to match on an unboxed tuple or sum, we must + -- bail out, as the bytecode compiler can't handle them. + -- (See #14608.) + | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs + = multiValException + -- algebraic alt with some binders + | otherwise = + let (tot_wds, _ptrs_wds, args_offsets) = + mkVirtHeapOffsets dflags NoHeader + [ NonVoid (bcIdPrimRep id, id) + | NonVoid id <- nonVoidIds real_bndrs + ] + size = WordOff tot_wds + + stack_bot = d_alts + wordsToBytes dflags size + + -- convert offsets from Sp into offsets into the virtual stack + p' = Map.insertList + [ (arg, stack_bot - ByteOff offset) + | (NonVoid arg, offset) <- args_offsets ] + p_alts + in do + MASSERT(isAlgCase) + rhs_code <- schemeE stack_bot s p' rhs + return (my_discr alt, + unitOL (UNPACK (trunc16W size)) `appOL` rhs_code) + where + real_bndrs = filterOut isTyVar bndrs + + my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} + my_discr (DataAlt dc, _, _) + | isUnboxedTupleCon dc || isUnboxedSumCon dc + = multiValException + | otherwise + = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) + my_discr (LitAlt l, _, _) + = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) + LitNumber LitNumWord w _ -> DiscrW (fromInteger w) + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar 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?) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + bitmap_size = trunc16W $ bytesToWords dflags (d - s) + bitmap_size' :: Int + bitmap_size' = fromIntegral bitmap_size + bitmap = intsToReverseBitmap dflags bitmap_size'{-size-} + (sort (filter (< bitmap_size') rel_slots)) + where + binds = Map.toList p + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + rel_slots = nub $ map fromIntegral $ concat (map spread binds) + spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = trunc16W $ bytesToWords dflags (d - offset) + + alt_stuff <- mapM codeAlt alts + alt_final <- mkMultiBranch maybe_ncons alt_stuff + + let + alt_bco_name = getName bndr + alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) + 0{-no arity-} bitmap_size bitmap True{-is alts-} +-- 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_size_b + save_ccs_size_b) + (d + ret_frame_size_b + save_ccs_size_b) + p scrut + alt_bco' <- emitBc alt_bco + let push_alts + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) + return (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 + :: StackDepth + -> Sequel + -> BCEnv + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr' Id DVarSet] -- args (atoms) + -> BcM BCInstrList +generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + = do + dflags <- getDynFlags + + let + -- useful constants + addr_size_b :: ByteOff + addr_size_b = wordSize dflags + + -- 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 + -- ArgRep of what was actually pushed. + + pargs + :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)] + pargs _ [] = return [] + pargs d (a:az) + = let arg_ty = unwrapType (exprType (deAnnotate' a)) + + in case tyConAppTyCon_maybe arg_ty of + -- Don't push the FO; instead push the Addr# it + -- contains. + Just t + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + -> do rest <- pargs (d + addr_size_b) az + code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a + return ((code,AddrRep):rest) + + -- Default case: push taggedly, but otherwise intact. + _ + -> do (code_a, sz_a) <- pushAtom d p a + rest <- pargs (d + sz_a) az + return ((code_a, atomPrimRep 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 + :: Word16 + -> StackDepth + -> BCEnv + -> AnnExpr' Id DVarSet + -> BcM BCInstrList + parg_ArrayishRep hdrSize d p a + = do (push_fo, _) <- pushAtom d p a + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + return (push_fo `snocOL` SWIZZLE 0 hdrSize) + + code_n_reps <- pargs d0 args_r_to_l + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l) + + push_args = concatOL pushs_arg + !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW + a_reps_pushed_RAW + | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l)) + = panic "GHC.CoreToByteCode.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, VoidRep) + 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 + maybe_static_target :: Maybe Literal + maybe_static_target = + case target of + DynamicTarget -> Nothing + StaticTarget _ _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget _ target _ True -> + Just (LitLabel target mb_size IsFunction) + where + mb_size + | OSMinGW32 <- platformOS (targetPlatform dflags) + , StdCallConv <- cconv + = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags) + | otherwise + = Nothing + + let + is_static = isJust maybe_static_target + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW + then panic "GHC.CoreToByteCode.generateCCall: dyn with no args" + else tail a_reps_pushed_RAW + + -- push the Addr# + (push_Addr, d_after_Addr) + | Just machlabel <- maybe_static_target + = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a V (tag). + r_sizeW = repSizeWords dflags r_rep + d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW + push_r = + if returns_void + then nilOL + else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW)) + + -- generate the marshalling code we're going to call + + -- 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 = trunc16W $ bytesToWords dflags (d_after_r - s) + + conv = case cconv of + CCallConv -> FFICCall + StdCallConv -> FFIStdCall + _ -> panic "GHC.CoreToByteCode: unexpected calling convention" + + -- the only difference in libffi mode is that we prepare a cif + -- describing the call type by calling libffi, and we attach the + -- address of this to the CCALL instruction. + + + let ffires = primRepToFFIType dflags r_rep + ffiargs = map (primRepToFFIType dflags) a_reps + hsc_env <- getHscEnv + token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires) + recordFFIBc token + + let + -- do the call + do_call = unitOL (CCALL stk_offset token flags) + where flags = case safety of + PlaySafe -> 0x0 + PlayInterruptible -> 0x1 + PlayRisky -> 0x2 + + -- slide and return + d_after_r_min_s = bytesToWords dflags (d_after_r - s) + wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW) + `snocOL` RETURN_UBX (toArgRep r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ + return ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + +primRepToFFIType :: DynFlags -> PrimRep -> FFIType +primRepToFFIType dflags r + = case r of + VoidRep -> FFIVoid + IntRep -> signed_word + WordRep -> unsigned_word + Int64Rep -> FFISInt64 + Word64Rep -> FFIUInt64 + AddrRep -> FFIPointer + FloatRep -> FFIFloat + DoubleRep -> FFIDouble + _ -> panic "primRepToFFIType" + where + (signed_word, unsigned_word) + | wORD_SIZE dflags == 4 = (FFISInt32, FFIUInt32) + | wORD_SIZE dflags == 8 = (FFISInt64, FFIUInt64) + | otherwise = panic "primTyDescChar" + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: DynFlags -> PrimRep -> Literal +mkDummyLiteral dflags pr + = case pr of + IntRep -> mkLitInt dflags 0 + WordRep -> mkLitWord dflags 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 + _ -> pprPanic "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 V'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 PrimRep +maybe_getCCallReturnRep fn_ty + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + r_reps = typePrimRepArgs r_ty + + blargh :: a -- Used at more than one type + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + in + case r_reps of + [] -> panic "empty typePrimRepArgs" + [VoidRep] -> Nothing + [rep] + | isGcPtrRep rep -> blargh + | otherwise -> Just rep + + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> blargh + +maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) +-- Detect and extract relevant info for the tagToEnum kludge. +maybe_is_tagToEnum_call app + | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app + , Just TagToEnumOp <- isPrimOpId_maybe v + = Just (snd arg, extract_constr_Names t) + | otherwise + = Nothing + where + extract_constr_Names ty + | rep_ty <- unwrapType ty + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.hs for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) + +{- ----------------------------------------------------------------------------- +Note [Implementing tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(implement_tagToId arg names) compiles code which takes an argument +'arg', (call it i), and enters the i'th closure in the supplied list +as a consequence. The [Name] is a list of the constructors of this +(enumeration) type. + +The code we generate is this: + push arg + push bogus-word + + TESTEQ_I 0 L1 + PUSH_G <lbl for first data con> + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G <lbl for second data con> + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G <lbl for last data con> + JMP L_Exit + + L_fail: CASEFAIL + + L_exit: SLIDE 1 n + ENTER + +The 'bogus-word' push is because TESTEQ_I expects the top of the stack +to have an info-table, and the next word to have the value to be +tested. This is very weird, but it's the way it is right now. See +Interpreter.c. We don't actually need an info-table here; we just +need to have the argument to be one-from-top on the stack, hence pushing +a 1-word null. See #8383. +-} + + +implement_tagToId + :: StackDepth + -> Sequel + -> BCEnv + -> AnnExpr' Id DVarSet + -> [Name] + -> BcM BCInstrList +-- See Note [Implementing tagToEnum#] +implement_tagToId d s p arg names + = ASSERT( notNull names ) + do (push_arg, arg_bytes) <- pushAtom d p arg + labels <- getLabelsBc (genericLength names) + label_fail <- getLabelBc + label_exit <- getLabelBc + dflags <- getDynFlags + let infos = zip4 labels (tail labels ++ [label_fail]) + [0 ..] names + steps = map (mkStep label_exit) infos + slide_ws = bytesToWords dflags (d - s + arg_bytes) + + return (push_arg + `appOL` unitOL (PUSH_UBX LitNullAddr 1) + -- Push bogus word (see Note [Implementing tagToEnum#]) + `appOL` concatOL steps + `appOL` toOL [ LABEL label_fail, CASEFAIL, + LABEL label_exit ] + `appOL` mkSlideW 1 (slide_ws + 1) + -- "+1" to account for bogus word + -- (see Note [Implementing tagToEnum#]) + `appOL` unitOL ENTER) + 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 + :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) +pushAtom d p e + | Just e' <- bcView e + = pushAtom d p e' + +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable V + +-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs +-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs: +-- The scrutinee of an empty case evaluates to bottom +pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 + = pushAtom d p a + +pushAtom d p (AnnVar var) + | [] <- typePrimRep (idType var) + = return (nilOL, 0) + + | isFCallId var + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) + + | Just primop <- isPrimOpId_maybe var + = do + dflags <-getDynFlags + return (unitOL (PUSH_PRIMOP primop), wordSize dflags) + + | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable + = do dflags <- getDynFlags + + let !szb = idSizeCon dflags var + with_instr instr = do + let !off_b = trunc16B $ d - d_v + return (unitOL (instr off_b), wordSize dflags) + + case szb of + 1 -> with_instr PUSH8_W + 2 -> with_instr PUSH16_W + 4 -> with_instr PUSH32_W + _ -> do + let !szw = bytesToWords dflags szb + !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1 + return (toOL (genericReplicate szw (PUSH_L off_w)), szb) + -- d - d_v offset from TOS to the first slot of the object + -- + -- d - d_v + sz - 1 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 -- var must be a global variable + = do topStrings <- getTopStrings + dflags <- getDynFlags + case lookupVarEnv topStrings var of + Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $ + fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr + Nothing -> do + let sz = idSizeCon dflags var + MASSERT( sz == wordSize dflags ) + return (unitOL (PUSH_G (getName var)), sz) + + +pushAtom _ _ (AnnLit lit) = do + dflags <- getDynFlags + let code rep + = let size_words = WordOff (argRepSizeW dflags rep) + in return (unitOL (PUSH_UBX lit (trunc16W size_words)), + wordsToBytes dflags size_words) + + case lit of + LitLabel _ _ _ -> code N + LitFloat _ -> code F + LitDouble _ -> code D + LitChar _ -> code N + LitNullAddr -> code N + LitString _ -> code N + LitRubbish -> code N + LitNumber nt _ _ -> case nt of + LitNumInt -> code N + LitNumWord -> code N + LitNumInt64 -> code L + LitNumWord64 -> code L + -- No LitInteger's or LitNatural's should be left by the time this is + -- called. CorePrep should have converted them all to a real core + -- representation. + LitNumInteger -> panic "pushAtom: LitInteger" + LitNumNatural -> panic "pushAtom: LitNatural" + +pushAtom _ _ expr + = pprPanic "GHC.CoreToByteCode.pushAtom" + (pprCoreExpr (deAnnotate' expr)) + + +-- | Push an atom for constructor (i.e., PACK instruction) onto the stack. +-- This is slightly different to @pushAtom@ due to the fact that we allow +-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. +pushConstrAtom + :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) + +pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = + return (unitOL (PUSH_UBX32 lit), 4) + +pushConstrAtom d p (AnnVar v) + | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable + dflags <- getDynFlags + let !szb = idSizeCon dflags v + done instr = do + let !off = trunc16B $ d - d_v + return (unitOL (instr off), szb) + case szb of + 1 -> done PUSH8 + 2 -> done PUSH16 + 4 -> done PUSH32 + _ -> pushAtom d p (AnnVar v) + +pushConstrAtom d p expr = pushAtom d p expr + +pushPadding :: Int -> (BCInstrList, ByteOff) +pushPadding !n = go n (nilOL, 0) + where + go n acc@(!instrs, !off) = case n of + 0 -> acc + 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) + 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) + 3 -> go 1 (go 2 acc) + 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) + _ -> go (n - 4) (go 4 acc) + +-- ----------------------------------------------------------------------------- +-- 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 = do + lbl_default <- getLabelBc + + let + mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList + mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) + -- shouldn't happen? + + mkTree [val] range_lo range_hi + | range_lo == range_hi + = return (snd val) + | null defaults -- Note [CASEFAIL] + = do lbl <- getLabelBc + return (testEQ (fst val) lbl + `consOL` (snd val + `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) + | otherwise + = return (testEQ (fst val) lbl_default `consOL` snd val) + + -- Note [CASEFAIL] It may be that this case has no default + -- branch, but the alternatives are not exhaustive - this + -- happens for GADT cases for example, where the types + -- prove that certain branches are impossible. We could + -- just assume that the other cases won't occur, but if + -- this assumption was wrong (because of a bug in GHC) + -- then the result would be a segfault. So instead we + -- emit an explicit test and a CASEFAIL instruction that + -- causes the interpreter to barf() if it is ever + -- executed. + + 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 do + label_geq <- getLabelBc + code_lo <- mkTree vals_lo range_lo (dec v_mid) + code_hi <- mkTree vals_hi v_mid range_hi + return (testLT v_mid label_geq + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default + = case defaults of + [] -> nilOL + [(_, def)] -> LABEL lbl_default `consOL` def + _ -> panic "mkMultiBranch/the_default" + instrs <- mkTree notd_ways init_lo init_hi + return (instrs `appOL` the_default) + where + (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways + notd_ways = sortBy (comparing fst) not_defaults + + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + + -- None of these will be needed if there are no non-default alts + (init_lo, init_hi) + | null notd_ways + = panic "mkMultiBranch: awesome foursome" + | otherwise + = case fst (head notd_ways) of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" + + (algMinBound, algMaxBound) + = case maybe_ncons of + -- XXX What happens when n == 0? + Just n -> (0, fromIntegral n - 1) + Nothing -> (minBound, maxBound) + + isNoDiscr NoDiscr = True + isNoDiscr _ = False + + dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-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 + + +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrW Word + | DiscrF Float + | DiscrD Double + | DiscrP Word16 + | NoDiscr + deriving (Eq, Ord) + +instance Outputable Discr where + ppr (DiscrI i) = int i + ppr (DiscrW w) = text (show w) + ppr (DiscrF f) = text (show f) + ppr (DiscrD d) = text (show d) + ppr (DiscrP i) = ppr i + ppr NoDiscr = text "DEF" + + +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff +lookupBCEnv_maybe = Map.lookup + +idSizeW :: DynFlags -> Id -> WordOff +idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep + +idSizeCon :: DynFlags -> Id -> ByteOff +idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep + +bcIdArgRep :: Id -> ArgRep +bcIdArgRep = toArgRep . bcIdPrimRep + +bcIdPrimRep :: Id -> PrimRep +bcIdPrimRep id + | [rep] <- typePrimRepArgs (idType id) + = rep + | otherwise + = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) + +repSizeWords :: DynFlags -> PrimRep -> WordOff +repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep) + +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +isVoidArg :: ArgRep -> Bool +isVoidArg V = True +isVoidArg _ = False + +-- See bug #1257 +multiValException :: a +multiValException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ + " Possibly due to foreign import/export decls in source.\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + +-- | Indicate if the calling convention is supported +isSupportedCConv :: CCallSpec -> Bool +isSupportedCConv (CCallSpec _ cconv _) = case cconv of + CCallConv -> True -- we explicitly pattern match on every + StdCallConv -> True -- convention to ensure that a warning + PrimCallConv -> False -- is triggered when a new one is added + JavaScriptCallConv -> False + CApiConv -> False + +-- See bug #10462 +unsupportedCConvException :: a +unsupportedCConvException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle some foreign calling conventions\n"++ + " Workaround: use -fobject-code, or compile this module to .o separately.")) + +mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr +mkSlideB dflags !nb !db = mkSlideW n d + where + !n = trunc16W $ bytesToWords dflags nb + !d = bytesToWords dflags db + +mkSlideW :: Word16 -> WordOff -> OrdList BCInstr +mkSlideW !n !ws + | ws > fromIntegral limit + -- If the amount to slide doesn't fit in a Word16, generate multiple slide + -- instructions + = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit) + | ws == 0 + = nilOL + | otherwise + = unitOL (SLIDE n $ fromIntegral ws) + where + limit :: Word16 + limit = maxBound + +splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) + -- The arguments are returned in *right-to-left* order +splitApp e | Just e' <- bcView e = splitApp e' +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) + + +bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) +-- The "bytecode view" of a term discards +-- a) type abstractions +-- b) type applications +-- c) casts +-- d) ticks (but not breakpoints) +-- Type lambdas *can* occur in random expressions, +-- whereas value lambdas cannot; that is why they are nuked here +bcView (AnnCast (_,e) _) = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e +bcView (AnnApp (_,e) (_, AnnType _)) = Just e +bcView (AnnTick Breakpoint{} _) = Nothing +bcView (AnnTick _other_tick (_,e)) = Just e +bcView _ = Nothing + +isVAtom :: AnnExpr' Var ann -> Bool +isVAtom e | Just e' <- bcView e = isVAtom e' +isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) +isVAtom (AnnCoercion {}) = True +isVAtom _ = False + +atomPrimRep :: AnnExpr' Id ann -> PrimRep +atomPrimRep e | Just e' <- bcView e = atomPrimRep e' +atomPrimRep (AnnVar v) = bcIdPrimRep v +atomPrimRep (AnnLit l) = typePrimRep1 (literalType l) + +-- #12128: +-- A case expression can be an atom because empty cases evaluate to bottom. +-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs +atomPrimRep (AnnCase _ _ ty _) = + ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep +atomPrimRep (AnnCoercion {}) = VoidRep +atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other)) + +atomRep :: AnnExpr' Id ann -> ArgRep +atomRep e = toArgRep (atomPrimRep e) + +-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which +-- has initial depth @original_depth@. Return the values which the stack +-- environment should map these items to. +mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] +mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) + +typeArgRep :: Type -> ArgRep +typeArgRep = toArgRep . typePrimRep1 + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad + +data BcM_State + = BcM_State + { bcm_hsc_env :: HscEnv + , uniqSupply :: UniqSupply -- for generating fresh variable names + , thisModule :: Module -- current module (for breakpoints) + , nextlabel :: Word16 -- for generating local labels + , ffis :: [FFIInfo] -- ffi info blocks, to free later + -- Should be free()d when it is GCd + , modBreaks :: Maybe ModBreaks -- info about breakpoints + , breakInfo :: IntMap CgBreakInfo + , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals + -- See Note [generating code for top-level string literal bindings]. + } + +newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) + +ioToBc :: IO a -> BcM a +ioToBc io = BcM $ \st -> do + x <- io + return (st, x) + +runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks + -> IdEnv (RemotePtr ()) + -> BcM r + -> IO (BcM_State, r) +runBc hsc_env us this_mod modBreaks topStrings (BcM m) + = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings) + +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, _) <- expr st0 + (st2, r) <- cont st1 + return (st2, r) + +returnBc :: a -> BcM a +returnBc result = BcM $ \st -> (return (st, result)) + +instance Applicative BcM where + pure = returnBc + (<*>) = ap + (*>) = thenBc_ + +instance Monad BcM where + (>>=) = thenBc + (>>) = (*>) + +instance HasDynFlags BcM where + getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) + +getHscEnv :: BcM HscEnv +getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) + +emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) +emitBc bco + = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) + +recordFFIBc :: RemotePtr C_ffi_cif -> BcM () +recordFFIBc a + = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) + +getLabelBc :: BcM Word16 +getLabelBc + = BcM $ \st -> do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (st{nextlabel = nl + 1}, nl) + +getLabelsBc :: Word16 -> BcM [Word16] +getLabelsBc n + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + +getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) +getCCArray = BcM $ \st -> + let breaks = expectJust "GHC.CoreToByteCode.getCCArray" $ modBreaks st in + return (st, modBreaks_ccs breaks) + + +newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () +newBreakInfo ix info = BcM $ \st -> + return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) + +newUnique :: BcM Unique +newUnique = BcM $ + \st -> case takeUniqFromSupply (uniqSupply st) of + (uniq, us) -> let newState = st { uniqSupply = us } + in return (newState, uniq) + +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \st -> return (st, thisModule st) + +getTopStrings :: BcM (IdEnv (RemotePtr ())) +getTopStrings = BcM $ \st -> return (st, topStrings st) + +newId :: Type -> BcM Id +newId ty = do + uniq <- newUnique + return $ mkSysLocal tickFS uniq ty + +tickFS :: FastString +tickFS = fsLit "ticked" diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 59de501fa8..fdd182b48b 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -946,7 +946,7 @@ pragma. It is levity-polymorphic. -> (# State# RealWorld, o #) It needs no special treatment in GHC except this special inlining here -in CorePrep (and in ByteCodeGen). +in CorePrep (and in GHC.CoreToByteCode). -- --------------------------------------------------------------------------- -- CpeArg: produces a result satisfying CpeArg diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs index a8eba5e2e8..c778a575f8 100644 --- a/compiler/GHC/Data/Bitmap.hs +++ b/compiler/GHC/Data/Bitmap.hs @@ -17,7 +17,7 @@ module GHC.Data.Bitmap ( import GhcPrelude -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import DynFlags import Util diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs new file mode 100644 index 0000000000..9443ff9421 --- /dev/null +++ b/compiler/GHC/Runtime/Debugger.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- GHCi Interactive debugging commands +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +-- ToDo: lots of violation of layering here. This module should +-- decide whether it is above the GHC API (import GHC and nothing +-- else) or below it. +-- +----------------------------------------------------------------------------- + +module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where + +import GhcPrelude + +import GHC.Runtime.Linker +import GHC.Runtime.Heap.Inspect + +import GHC.Runtime.Interpreter +import GHCi.RemoteTypes +import GhcMonad +import HscTypes +import Id +import GHC.Iface.Syntax ( showToHeader ) +import GHC.Iface.Env ( newInteractiveBinder ) +import Name +import Var hiding ( varName ) +import VarSet +import UniqSet +import Type +import GHC +import Outputable +import PprTyThing +import ErrUtils +import MonadUtils +import DynFlags +import Exception + +import Control.Monad +import Data.List ( (\\) ) +import Data.Maybe +import Data.IORef + +------------------------------------- +-- | The :print & friends commands +------------------------------------- +pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () +pprintClosureCommand bindThings force str = do + tythings <- (catMaybes . concat) `liftM` + mapM (\w -> GHC.parseName w >>= + mapM GHC.lookupName) + (words str) + let ids = [id | AnId id <- tythings] + + -- Obtain the terms and the recovered type information + (subst, terms) <- mapAccumLM go emptyTCvSubst ids + + -- Apply the substitutions obtained after recovering the types + modifySession $ \hsc_env -> + hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} + + -- Finally, print the Terms + unqual <- GHC.getPrintUnqual + docterms <- mapM showTerm terms + dflags <- getDynFlags + liftIO $ (printOutputForUser dflags unqual . vcat) + (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) + ids + docterms) + where + -- Do the obtainTerm--bindSuspensions-computeSubstitution dance + go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) + go subst id = do + let id_ty' = substTy subst (idType id) + id' = id `setIdType` id_ty' + term_ <- GHC.obtainTermFromId maxBound force id' + term <- tidyTermTyVars term_ + term' <- if bindThings + then bindSuspensions term + else return term + -- Before leaving, we compare the type obtained to see if it's more specific + -- Then, we extract a substitution, + -- mapping the old tyvars to the reconstructed types. + let reconstructed_type = termType term + hsc_env <- getSession + case (improveRTTIType hsc_env id_ty' reconstructed_type) of + Nothing -> return (subst, term') + Just subst' -> do { dflags <- GHC.getSessionDynFlags + ; liftIO $ + dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText + (fsep $ [text "RTTI Improvement for", ppr id, + text "old substitution:" , ppr subst, + text "new substitution:" , ppr subst']) + ; return (subst `unionTCvSubst` subst', term')} + + tidyTermTyVars :: GhcMonad m => Term -> m Term + tidyTermTyVars t = + withSession $ \hsc_env -> do + let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env + my_tvs = termTyCoVars t + tvs = env_tvs `minusVarSet` my_tvs + tyvarOccName = nameOccName . tyVarName + tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) + -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv + -- forgets the ordering immediately by creating an env + , getUniqSet $ env_tvs `intersectVarSet` my_tvs) + return $ mapTermType (snd . tidyOpenType tidyEnv) t + +-- | Give names, and bind in the interactive environment, to all the suspensions +-- included (inductively) in a term +bindSuspensions :: GhcMonad m => Term -> m Term +bindSuspensions t = do + hsc_env <- getSession + inScope <- GHC.getBindings + let ictxt = hsc_IC hsc_env + prefix = "_t" + alreadyUsedNames = map (occNameString . nameOccName . getName) inScope + availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames + availNames_var <- liftIO $ newIORef availNames + (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t + let (names, tys, fhvs) = unzip3 stuff + let ids = [ mkVanillaGlobal name ty + | (name,ty) <- zip names tys] + new_ic = extendInteractiveContextWithIds ictxt ids + dl = hsc_dynLinker hsc_env + liftIO $ extendLinkEnv dl (zip names fhvs) + setSession hsc_env {hsc_IC = new_ic } + return t' + where + +-- Processing suspensions. Give names and recopilate info + nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] + -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) + nameSuspensionsAndGetInfos hsc_env freeNames = TermFold + { + fSuspension = doSuspension hsc_env freeNames + , fTerm = \ty dc v tt -> do + tt' <- sequence tt + let (terms,names) = unzip tt' + return (Term ty dc v terms, concat names) + , fPrim = \ty n ->return (Prim ty n,[]) + , fNewtypeWrap = + \ty dc t -> do + (term, names) <- t + return (NewtypeWrap ty dc term, names) + , fRefWrap = \ty t -> do + (term, names) <- t + return (RefWrap ty term, names) + } + doSuspension hsc_env freeNames ct ty hval _name = do + name <- atomicModifyIORef' freeNames (\x->(tail x, head x)) + n <- newGrimName hsc_env name + return (Suspension ct ty hval (Just n), [(n,ty,hval)]) + + +-- A custom Term printer to enable the use of Show instances +showTerm :: GhcMonad m => Term -> m SDoc +showTerm term = do + dflags <- GHC.getSessionDynFlags + if gopt Opt_PrintEvldWithShow dflags + then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term + else cPprTerm cPprTermBase term + where + cPprShowable prec t@Term{ty=ty, val=fhv} = + if not (isFullyEvaluatedTerm t) + then return Nothing + else do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + do + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + -- XXX: this tries to disable logging of errors + -- does this still do what it is intended to do + -- with the changed error handling and logging? + let noop_log _ _ _ _ _ _ = return () + expr = "Prelude.return (Prelude.show " ++ + showPpr dflags bname ++ + ") :: Prelude.IO Prelude.String" + dl = hsc_dynLinker hsc_env + _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} + txt_ <- withExtendedLinkEnv dl + [(bname, fhv)] + (GHC.compileExprRemote expr) + let myprec = 10 -- application precedence. TODO Infix constructors + txt <- liftIO $ evalString hsc_env txt_ + if not (null txt) then + return $ Just $ cparen (prec >= myprec && needsParens txt) + (text txt) + else return Nothing + `gfinally` do + setSession hsc_env + GHC.setSessionDynFlags dflags + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = + cPprShowable prec t{ty=new_ty} + cPprShowable _ _ = return Nothing + + needsParens ('"':_) = False -- some simple heuristics to see whether parens + -- are redundant in an arbitrary Show output + needsParens ('(':_) = False + needsParens txt = ' ' `elem` txt + + + bindToFreshName hsc_env ty userName = do + name <- newGrimName hsc_env userName + let id = mkVanillaGlobal name ty + new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] + return (hsc_env {hsc_IC = new_ic }, name) + +-- Create new uniques and give them sequentially numbered names +newGrimName :: MonadIO m => HscEnv -> String -> m Name +newGrimName hsc_env userName + = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) + where + occ = mkOccName varName userName + +pprTypeAndContents :: GhcMonad m => Id -> m SDoc +pprTypeAndContents id = do + dflags <- GHC.getSessionDynFlags + let pcontents = gopt Opt_PrintBindContents dflags + pprdId = (pprTyThing showToHeader . AnId) id + if pcontents + then do + let depthBound = 100 + -- If the value is an exception, make sure we catch it and + -- show the exception, rather than propagating the exception out. + e_term <- gtry $ GHC.obtainTermFromId depthBound False id + docs_term <- case e_term of + Right term -> showTerm term + Left exn -> return (text "*** Exception:" <+> + text (show (exn :: SomeException))) + return $ pprdId <+> equals <+> docs_term + else return pprdId diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs new file mode 100644 index 0000000000..d43c5be7b8 --- /dev/null +++ b/compiler/GHC/Runtime/Eval.hs @@ -0,0 +1,1271 @@ +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, + RecordWildCards, BangPatterns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval ( + Resume(..), History(..), + execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec, + runDecls, runDeclsWithLocation, runParsedDecls, + isStmt, hasImport, isImport, isDecl, + parseImportDecl, SingleStep(..), + abandon, abandonAll, + getResumeContext, + getHistorySpan, + getModBreaks, + getHistoryModule, + back, forward, + setContext, getContext, + availsToGlobalRdrEnv, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + parseInstanceHead, + getInstancesForType, + getDocs, + GetDocsFailure(..), + showModule, + moduleIsBootOrNotObjectLinkable, + parseExpr, compileParsedExpr, + compileExpr, dynCompileExpr, + compileExprRemote, compileParsedExprRemote, + Term(..), obtainTermFromId, obtainTermFromVal, reconstructType + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Runtime.Eval.Types + +import GHC.Runtime.Interpreter as GHCi +import GHCi.Message +import GHCi.RemoteTypes +import GhcMonad +import HscMain +import GHC.Hs +import HscTypes +import InstEnv +import GHC.Iface.Env ( newInteractiveBinder ) +import FamInstEnv ( FamInst ) +import CoreFVs ( orphNamesOfFamInst ) +import TyCon +import Type hiding( typeKind ) +import GHC.Types.RepType +import TcType +import Constraint +import TcOrigin +import Predicate +import Var +import Id +import Name hiding ( varName ) +import NameSet +import Avail +import RdrName +import VarEnv +import GHC.ByteCode.Types +import GHC.Runtime.Linker as Linker +import DynFlags +import Unique +import UniqSupply +import MonadUtils +import Module +import PrelNames ( toDynName, pretendNameIsInScope ) +import TysWiredIn ( isCTupleTyConName ) +import Panic +import Maybes +import ErrUtils +import SrcLoc +import GHC.Runtime.Heap.Inspect +import Outputable +import FastString +import Bag +import Util +import qualified Lexer (P (..), ParseResult(..), unP, mkPState) +import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport) + +import System.Directory +import Data.Dynamic +import Data.Either +import qualified Data.IntMap as IntMap +import Data.List (find,intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import StringBuffer (stringToStringBuffer) +import Control.Monad +import GHC.Exts +import Data.Array +import Exception + +import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces ) +import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) ) + +import TcEnv (tcGetInstEnvs) + +import Inst (instDFunType) +import TcSimplify (solveWanteds) +import TcRnMonad +import TcEvidence +import Data.Bifunctor (second) + +import TcSMonad (runTcS) + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +getResumeContext :: GhcMonad m => m [Resume] +getResumeContext = withSession (return . ic_resume . hsc_IC) + +mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History +mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) + +getHistoryModule :: History -> Module +getHistoryModule = breakInfo_module . historyBreakInfo + +getHistorySpan :: HscEnv -> History -> SrcSpan +getHistorySpan hsc_env History{..} = + let BreakInfo{..} = historyBreakInfo in + case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of + Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number + _ -> panic "getHistorySpan" + +getModBreaks :: HomeModInfo -> ModBreaks +getModBreaks hmi + | Just linkable <- hm_linkable hmi, + [BCOs cbc _] <- linkableUnlinked linkable + = fromMaybe emptyModBreaks (bc_breaks cbc) + | otherwise + = emptyModBreaks -- probably object code + +{- | Finds the enclosing top level function name -} +-- ToDo: a better way to do this would be to keep hold of the decl_path computed +-- by the coverage pass, which gives the list of lexically-enclosing bindings +-- for each tick. +findEnclosingDecls :: HscEnv -> BreakInfo -> [String] +findEnclosingDecls hsc_env (BreakInfo modl ix) = + let hmi = expectJust "findEnclosingDecls" $ + lookupHpt (hsc_HPT hsc_env) (moduleName modl) + mb = getModBreaks hmi + in modBreaks_decls mb ! ix + +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } + +-- ----------------------------------------------------------------------------- +-- execStmt + +-- | default ExecOptions +execOptions :: ExecOptions +execOptions = ExecOptions + { execSingleStep = RunToCompletion + , execSourceFile = "<interactive>" + , execLineNumber = 1 + , execWrap = EvalThis -- just run the statement, don't wrap it in anything + } + +-- | Run a statement in the current interactive context. +execStmt + :: GhcMonad m + => String -- ^ a statement (bind or expression) + -> ExecOptions + -> m ExecResult +execStmt input exec_opts@ExecOptions{..} = do + hsc_env <- getSession + + mb_stmt <- + liftIO $ + runInteractiveHsc hsc_env $ + hscParseStmtWithLocation execSourceFile execLineNumber input + + case mb_stmt of + -- empty statement / comment + Nothing -> return (ExecComplete (Right []) 0) + Just stmt -> execStmt' stmt input exec_opts + +-- | Like `execStmt`, but takes a parsed statement as argument. Useful when +-- doing preprocessing on the AST before execution, e.g. in GHCi (see +-- GHCi.UI.runStmt). +execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult +execStmt' stmt stmt_text ExecOptions{..} = do + hsc_env <- getSession + + -- Turn off -fwarn-unused-local-binds when running a statement, to hide + -- warnings about the implicit bindings we introduce. + -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset + -- -wwarn-unused-local-binds) + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds + hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } }) + + r <- liftIO $ hscParsedStmt hsc_env' stmt + + case r of + Nothing -> + -- empty statement / comment + return (ExecComplete (Right []) 0) + Just (ids, hval, fix_env) -> do + updateFixityEnv fix_env + + status <- + withVirtualCWD $ + liftIO $ + evalStmt hsc_env' (isStep execSingleStep) (execWrap hval) + + let ic = hsc_IC hsc_env + bindings = (ic_tythings ic, ic_rn_gbl_env ic) + + size = ghciHistSize idflags' + + handleRunStatus execSingleStep stmt_text bindings ids + status (emptyHistory size) + +runDecls :: GhcMonad m => String -> m [Name] +runDecls = runDeclsWithLocation "<interactive>" 1 + +-- | Run some declarations and return any user-visible names that were brought +-- into scope. +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation source line_num input = do + hsc_env <- getSession + decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input) + runParsedDecls decls + +-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument. +-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi +-- (see GHCi.UI.runStmt). +runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name] +runParsedDecls decls = do + hsc_env <- getSession + (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls) + + setSession $ hsc_env { hsc_IC = ic } + hsc_env <- getSession + hsc_env' <- liftIO $ rttiEnvironment hsc_env + setSession hsc_env' + return $ filter (not . isDerivedOccName . nameOccName) + -- For this filter, see Note [What to show to users] + $ map getName tyThings + +{- Note [What to show to users] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to display internally-generated bindings to users. +Things like the coercion axiom for newtypes. These bindings all get +OccNames that users can't write, to avoid the possibility of name +clashes (in linker symbols). That gives a convenient way to suppress +them. The relevant predicate is OccName.isDerivedOccName. +See #11051 for more background and examples. +-} + +withVirtualCWD :: GhcMonad m => m a -> m a +withVirtualCWD m = do + hsc_env <- getSession + + -- a virtual CWD is only necessary when we're running interpreted code in + -- the same process as the compiler. + if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do + + let ic = hsc_IC hsc_env + let set_cwd = do + dir <- liftIO $ getCurrentDirectory + case ic_cwd ic of + Just dir -> liftIO $ setCurrentDirectory dir + Nothing -> return () + return dir + + reset_cwd orig_dir = do + virt_dir <- liftIO $ getCurrentDirectory + hsc_env <- getSession + let old_IC = hsc_IC hsc_env + setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } + liftIO $ setCurrentDirectory orig_dir + + gbracket set_cwd reset_cwd $ \_ -> m + +parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr + +emptyHistory :: Int -> BoundedList History +emptyHistory size = nilBL size + +handleRunStatus :: GhcMonad m + => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id] + -> EvalStatus_ [ForeignHValue] [HValueRef] + -> BoundedList History + -> m ExecResult + +handleRunStatus step expr bindings final_ids status history + | RunAndLogSteps <- step = tracing + | otherwise = not_tracing + where + tracing + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status + , not is_exception + = do + hsc_env <- getSession + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + breaks = getModBreaks hmi + + b <- liftIO $ + breakpointStatus hsc_env (modBreaks_flags breaks) ix + if b + then not_tracing + -- This breakpoint is explicitly enabled; we want to stop + -- instead of just logging it. + else do + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref + let bi = BreakInfo modl ix + !history' = mkHistory hsc_env apStack_fhv bi `consBL` history + -- history is strict, otherwise our BoundedList is pointless. + fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + status <- liftIO $ GHCi.resumeStmt hsc_env True fhv + handleRunStatus RunAndLogSteps expr bindings final_ids + status history' + | otherwise + = not_tracing + + not_tracing + -- Hit a breakpoint + | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status + = do + hsc_env <- getSession + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref + let hmi = expectJust "handleRunStatus" $ + lookupHptDirectly (hsc_HPT hsc_env) + (mkUniqueGrimily mod_uniq) + modl = mi_module (hm_iface hmi) + bp | is_exception = Nothing + | otherwise = Just (BreakInfo modl ix) + (hsc_env1, names, span, decl) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv bp + let + resume = Resume + { resumeStmt = expr, resumeContext = resume_ctxt_fhv + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakInfo = bp + , resumeSpan = span, resumeHistory = toListBL history + , resumeDecl = decl + , resumeCCS = ccs + , resumeHistoryIx = 0 } + hsc_env2 = pushResume hsc_env1 resume + + setSession hsc_env2 + return (ExecBreak names bp) + + -- Completed successfully + | EvalComplete allocs (EvalSuccess hvals) <- status + = do hsc_env <- getSession + let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids + final_names = map getName final_ids + dl = hsc_dynLinker hsc_env + liftIO $ Linker.extendLinkEnv dl (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + setSession hsc_env' + return (ExecComplete (Right final_names) allocs) + + -- Completed with an exception + | EvalComplete alloc (EvalException e) <- status + = return (ExecComplete (Left (fromSerializableException e)) alloc) + +#if __GLASGOW_HASKELL__ <= 810 + | otherwise + = panic "not_tracing" -- actually exhaustive, but GHC can't tell +#endif + + +resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult +resumeExec canLogSpan step + = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + + case resume of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + -- unbind the temporary locals by restoring the TypeEnv from + -- before the breakpoint, and drop this Resume from the + -- InteractiveContext. + let (resume_tmp_te,resume_rdr_env) = resumeBindings r + ic' = ic { ic_tythings = resume_tmp_te, + ic_rn_gbl_env = resume_rdr_env, + ic_resume = rs } + setSession hsc_env{ hsc_IC = ic' } + + -- remove any bindings created since the breakpoint from the + -- linker's environment + let old_names = map getName resume_tmp_te + new_names = [ n | thing <- ic_tythings ic + , let n = getName thing + , not (n `elem` old_names) ] + dl = hsc_dynLinker hsc_env + liftIO $ Linker.deleteFromLinkEnv dl new_names + + case r of + Resume { resumeStmt = expr, resumeContext = fhv + , resumeBindings = bindings, resumeFinalIds = final_ids + , resumeApStack = apStack, resumeBreakInfo = mb_brkpt + , resumeSpan = span + , resumeHistory = hist } -> do + withVirtualCWD $ do + status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv + let prevHistoryLst = fromListBL 50 hist + hist' = case mb_brkpt of + Nothing -> prevHistoryLst + Just bi + | not $canLogSpan span -> prevHistoryLst + | otherwise -> mkHistory hsc_env apStack bi `consBL` + fromListBL 50 hist + handleRunStatus step expr bindings final_ids status hist' + +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +back n = moveHist (+n) + +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +forward n = moveHist (subtract n) + +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) +moveHist fn = do + hsc_env <- getSession + case ic_resume (hsc_IC hsc_env) of + [] -> liftIO $ + throwGhcExceptionIO (ProgramError "not stopped at a breakpoint") + (r:rs) -> do + let ix = resumeHistoryIx r + history = resumeHistory r + new_ix = fn ix + -- + when (history `lengthLessThan` new_ix) $ liftIO $ + throwGhcExceptionIO (ProgramError "no more logged breakpoints") + when (new_ix < 0) $ liftIO $ + throwGhcExceptionIO (ProgramError "already at the beginning of the history") + + let + update_ic apStack mb_info = do + (hsc_env1, names, span, decl) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info + let ic = hsc_IC hsc_env1 + r' = r { resumeHistoryIx = new_ix } + ic' = ic { ic_resume = r':rs } + + setSession hsc_env1{ hsc_IC = ic' } + + return (names, new_ix, span, decl) + + -- careful: we want apStack to be the AP_STACK itself, not a thunk + -- around it, hence the cases are carefully constructed below to + -- make this the case. ToDo: this is v. fragile, do something better. + if new_ix == 0 + then case r of + Resume { resumeApStack = apStack, + resumeBreakInfo = mb_brkpt } -> + update_ic apStack mb_brkpt + else case history !! (new_ix - 1) of + History{..} -> + update_ic historyApStack (Just historyBreakInfo) + + +-- ----------------------------------------------------------------------------- +-- After stopping at a breakpoint, add free variables to the environment + +result_fs :: FastString +result_fs = fsLit "_result" + +bindLocalsAtBreakpoint + :: HscEnv + -> ForeignHValue + -> Maybe BreakInfo + -> IO (HscEnv, [Name], SrcSpan, String) + +-- Nothing case: we stopped when an exception was raised, not at a +-- breakpoint. We have no location information or local variables to +-- bind, all we can do is bind a local variable to the exception +-- value. +bindLocalsAtBreakpoint hsc_env apStack Nothing = do + let exn_occ = mkVarOccFS (fsLit "_exception") + span = mkGeneralSrcSpan (fsLit "<unknown>") + exn_name <- newInteractiveBinder hsc_env exn_occ span + + let e_fs = fsLit "e" + e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span + e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) + + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] + dl = hsc_dynLinker hsc_env + -- + Linker.extendLinkEnv dl [(exn_name, apStack)] + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>") + +-- Just case: we stopped at a breakpoint, we have information about the location +-- of the breakpoint and the free variables of the expression. +bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do + let + hmi = expectJust "bindLocalsAtBreakpoint" $ + lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) + breaks = getModBreaks hmi + info = expectJust "bindLocalsAtBreakpoint2" $ + IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) + mbVars = cgb_vars info + result_ty = cgb_resty info + occs = modBreaks_vars breaks ! breakInfo_number + span = modBreaks_locs breaks ! breakInfo_number + decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number + + -- Filter out any unboxed ids by changing them to Nothings; + -- we can't bind these at the prompt + mbPointers = nullUnboxed <$> mbVars + + (ids, offsets, occs') = syncOccs mbPointers occs + + free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) + + -- It might be that getIdValFromApStack fails, because the AP_STACK + -- has been accidentally evaluated, or something else has gone wrong. + -- So that we don't fall over in a heap when this happens, just don't + -- bind any free variables instead, and we emit a warning. + mb_hValues <- + mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets + when (any isNothing mb_hValues) $ + debugTraceMsg (hsc_dflags hsc_env) 1 $ + text "Warning: _result has been evaluated, some bindings have been lost" + + us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time + let tv_subst = newTyVars us free_tvs + (filtered_ids, occs'') = unzip -- again, sync the occ-names + [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ] + (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $ + map (substTy tv_subst . idType) filtered_ids + + new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids + result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span + + let result_id = Id.mkVanillaGlobal result_name + (substTy tv_subst result_ty) + result_ok = isPointer result_id + + final_ids | result_ok = result_id : new_ids + | otherwise = new_ids + ictxt0 = hsc_IC hsc_env + ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids + names = map idName new_ids + dl = hsc_dynLinker hsc_env + + let fhvs = catMaybes mb_hValues + Linker.extendLinkEnv dl (zip names fhvs) + when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)] + hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } + return (hsc_env1, if result_ok then result_name:names else names, span, decl) + where + -- We need a fresh Unique for each Id we bind, because the linker + -- state is single-threaded and otherwise we'd spam old bindings + -- whenever we stop at a breakpoint. The InteractveContext is properly + -- saved/restored, but not the linker state. See #1743, test break026. + mkNewId :: OccName -> Type -> Id -> IO Id + mkNewId occ ty old_id + = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) + ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } + + newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst + -- Similarly, clone the type variables mentioned in the types + -- we have here, *and* make them all RuntimeUnk tyvars + newTyVars us tvs + = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) + | (tv, uniq) <- tvs `zip` uniqsFromSupply us + , let name = setNameUnique (tyVarName tv) uniq ] + + isPointer id | [rep] <- typePrimRep (idType id) + , isGcPtrRep rep = True + | otherwise = False + + -- Convert unboxed Id's to Nothings + nullUnboxed (Just (fv@(id, _))) + | isPointer id = Just fv + | otherwise = Nothing + nullUnboxed Nothing = Nothing + + -- See Note [Syncing breakpoint info] + syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c]) + syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs + where + joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] + joinOccs = zipWith joinOcc + joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc + +rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + incompletelyTypedIds = + [id | id <- tmp_ids + , not $ noSkolems id + , (occNameFS.nameOccName.idName) id /= result_fs] + hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds) + return hsc_env' + where + noSkolems = noFreeVarsOfType . idType + improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do + let tmp_ids = [id | AnId id <- ic_tythings ic] + Just id = find (\i -> idName i == name) tmp_ids + if noSkolems id + then return hsc_env + else do + mb_new_ty <- reconstructType hsc_env 10 id + let old_ty = idType id + case mb_new_ty of + Nothing -> return hsc_env + Just new_ty -> do + case improveRTTIType hsc_env old_ty new_ty of + Nothing -> return $ + WARN(True, text (":print failed to calculate the " + ++ "improvement for a type")) hsc_env + Just subst -> do + let dflags = hsc_dflags hsc_env + dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText + (fsep [text "RTTI Improvement for", ppr id, equals, + ppr subst]) + + let ic' = substInteractiveContext ic subst + return hsc_env{hsc_IC=ic'} + +pushResume :: HscEnv -> Resume -> HscEnv +pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 } + where + ictxt0 = hsc_IC hsc_env + ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 } + + + {- + Note [Syncing breakpoint info] + + To display the values of the free variables for a single breakpoint, the + function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls + out the information from the fields `modBreaks_breakInfo` and + `modBreaks_vars` of the `ModBreaks` data structure. + For a specific breakpoint this gives 2 lists of type `Id` (or `Var`) + and `OccName`. + They are used to create the Id's for the free variables and must be kept + in sync! + + There are 3 situations where items are removed from the Id list + (or replaced with `Nothing`): + 1.) If function `GHC.CoreToByteCode.schemeER_wrk` (which creates + the Id list) doesn't find an Id in the ByteCode environement. + 2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` + filters out unboxed elements from the Id list, because GHCi cannot + yet handle them. + 3.) If the GHCi interpreter doesn't find the reference to a free variable + of our breakpoint. This also happens in the function + bindLocalsAtBreakpoint. + + If an element is removed from the Id list, then the corresponding element + must also be removed from the Occ list. Otherwise GHCi will confuse + variable names as in #8487. + -} + +-- ----------------------------------------------------------------------------- +-- Abandoning a resume context + +abandon :: GhcMonad m => m Bool +abandon = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + r:rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = rs } } + liftIO $ abandonStmt hsc_env (resumeContext r) + return True + +abandonAll :: GhcMonad m => m Bool +abandonAll = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + resume = ic_resume ic + case resume of + [] -> return False + rs -> do + setSession hsc_env{ hsc_IC = ic { ic_resume = [] } } + liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs + return True + +-- ----------------------------------------------------------------------------- +-- Bounded list, optimised for repeated cons + +data BoundedList a = BL + {-# UNPACK #-} !Int -- length + {-# UNPACK #-} !Int -- bound + [a] -- left + [a] -- right, list is (left ++ reverse right) + +nilBL :: Int -> BoundedList a +nilBL bound = BL 0 bound [] [] + +consBL :: a -> BoundedList a -> BoundedList a +consBL a (BL len bound left right) + | len < bound = BL (len+1) bound (a:left) right + | null right = BL len bound [a] $! tail (reverse left) + | otherwise = BL len bound (a:left) $! tail right + +toListBL :: BoundedList a -> [a] +toListBL (BL _ _ left right) = left ++ reverse right + +fromListBL :: Int -> [a] -> BoundedList a +fromListBL bound l = BL (length l) bound l [] + +-- lenBL (BL len _ _ _) = len + +-- ----------------------------------------------------------------------------- +-- | Set the interactive evaluation context. +-- +-- (setContext imports) sets the ic_imports field (which in turn +-- determines what is in scope at the prompt) to 'imports', and +-- constructs the ic_rn_glb_env environment to reflect it. +-- +-- We retain in scope all the things defined at the prompt, and kept +-- in ic_tythings. (Indeed, they shadow stuff from ic_imports.) + +setContext :: GhcMonad m => [InteractiveImport] -> m () +setContext imports + = do { hsc_env <- getSession + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> + liftIO $ throwGhcExceptionIO (formatError dflags mod err) + Right all_env -> do { + ; let old_ic = hsc_IC hsc_env + !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic + ; setSession + hsc_env{ hsc_IC = old_ic { ic_imports = imports + , ic_rn_gbl_env = final_rdr_env }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err + +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (ModuleName, String) GlobalRdrEnv) +-- Compute the GlobalRdrEnv for the interactive context +findGlobalRdrEnv hsc_env imports + = do { idecls_env <- hscRnImportDecls hsc_env idecls + -- This call also loads any orphan modules + ; return $ case partitionEithers (map mkEnv imods) of + ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) + (err : _, _) -> Left err } + where + idecls :: [LImportDecl GhcPs] + idecls = [noLoc d | IIDecl d <- imports] + + imods :: [ModuleName] + imods = [m | IIModule m <- imports] + + mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of + Left err -> Left (mod, err) + Right env -> Right env + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) + where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } + +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv +mkTopLevEnv hpt modl + = case lookupHpt hpt modl of + Nothing -> Left "not a home module" + Just details -> + case mi_globals (hm_iface details) of + Nothing -> Left "not interpreted" + Just env -> Right env + +-- | Get the interactive evaluation context, consisting of a pair of the +-- set of modules from which we take the full top-level scope, and the set +-- of modules from which we take just the exports respectively. +getContext :: GhcMonad m => m [InteractiveImport] +getContext = withSession $ \HscEnv{ hsc_IC=ic } -> + return (ic_imports ic) + +-- | Returns @True@ if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: GhcMonad m => Module -> m Bool +moduleIsInterpreted modl = withSession $ \h -> + if moduleUnitId modl /= thisPackage (hsc_dflags h) + then return False + else case lookupHpt (hsc_HPT h) (moduleName modl) of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False + +-- | Looks up an identifier in the current interactive context (for :info) +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! +-- The exact choice of which ones to show, and which to hide, is a judgement call. +-- (see #1581) +getInfo :: GhcMonad m => Bool -> Name + -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc)) +getInfo allInfo name + = withSession $ \hsc_env -> + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name + case mb_stuff of + Nothing -> return Nothing + Just (thing, fixity, cls_insts, fam_insts, docs) -> do + let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) + + -- Filter the instances based on whether the constituent names of their + -- instance heads are all in scope. + let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts + fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts + return (Just (thing, fixity, cls_insts', fam_insts', docs)) + where + plausible rdr_env names + -- Dfun involving only names that are in ic_rn_glb_env + = allInfo + || nameSetAll ok names + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True + -- The one we looked for in the first place! + | pretendNameIsInScope n = True + | isBuiltInSyntax n = True + | isCTupleTyConName n = True + | isExternalName n = isJust (lookupGRE_Name rdr_env n) + | otherwise = True + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: GhcMonad m => m [Name] +getNamesInScope = withSession $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + +-- | Returns all 'RdrName's in scope in the current interactive +-- context, excluding any that are internally-generated. +getRdrNamesInScope :: GhcMonad m => m [RdrName] +getRdrNamesInScope = withSession $ \hsc_env -> do + let + ic = hsc_IC hsc_env + gbl_rdrenv = ic_rn_gbl_env ic + gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv + -- Exclude internally generated names; see e.g. #11328 + return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names) + + +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: GhcMonad m => String -> m [Name] +parseName str = withSession $ \hsc_env -> liftIO $ + do { lrdr_name <- hscParseIdentifier hsc_env str + ; hscTcRnLookupRdrName hsc_env lrdr_name } + +-- | Returns @True@ if passed string is a statement. +isStmt :: DynFlags -> String -> Bool +isStmt dflags stmt = + case parseThing Parser.parseStmt dflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string has an import declaration. +hasImport :: DynFlags -> String -> Bool +hasImport dflags stmt = + case parseThing Parser.parseModule dflags stmt of + Lexer.POk _ thing -> hasImports thing + Lexer.PFailed _ -> False + where + hasImports = not . null . hsmodImports . unLoc + +-- | Returns @True@ if passed string is an import declaration. +isImport :: DynFlags -> String -> Bool +isImport dflags stmt = + case parseThing Parser.parseImport dflags stmt of + Lexer.POk _ _ -> True + Lexer.PFailed _ -> False + +-- | Returns @True@ if passed string is a declaration but __/not a splice/__. +isDecl :: DynFlags -> String -> Bool +isDecl dflags stmt = do + case parseThing Parser.parseDeclaration dflags stmt of + Lexer.POk _ thing -> + case unLoc thing of + SpliceD _ _ -> False + _ -> True + Lexer.PFailed _ -> False + +parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing +parseThing parser dflags stmt = do + let buf = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 + + Lexer.unP parser (Lexer.mkPState dflags buf loc) + +getDocs :: GhcMonad m + => Name + -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) + -- TODO: What about docs for constructors etc.? +getDocs name = + withSession $ \hsc_env -> do + case nameModule_maybe name of + Nothing -> pure (Left (NameHasNoModule name)) + Just mod -> do + if isInteractiveModule mod + then pure (Left InteractiveName) + else do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- liftIO $ hscGetModuleInterface hsc_env mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod compiled)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + where + compiled = + -- TODO: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Failure modes for 'getDocs'. + +-- TODO: Find a way to differentiate between modules loaded without '-haddock' +-- and modules that contain no docs. +data GetDocsFailure + + -- | 'nameModule_maybe' returned 'Nothing'. + = NameHasNoModule Name + + -- | This is probably because the module was loaded without @-haddock@, + -- but it's also possible that the entire module contains no documentation. + | NoDocsInIface + Module + Bool -- ^ 'True': The module was compiled. + -- 'False': The module was :loaded. + + -- | The 'Name' was defined interactively. + | InteractiveName + +instance Outputable GetDocsFailure where + ppr (NameHasNoModule name) = + quotes (ppr name) <+> text "has no module where we could look for docs." + ppr (NoDocsInIface mod compiled) = vcat + [ text "Can't find any documentation for" <+> ppr mod <> char '.' + , text "This is probably because the module was" + <+> text (if compiled then "compiled" else "loaded") + <+> text "without '-haddock'," + , text "but it's also possible that the module contains no documentation." + , text "" + , if compiled + then text "Try re-compiling with '-haddock'." + else text "Try running ':set -haddock' and :load the file again." + -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. + ] + ppr InteractiveName = + text "Docs are unavailable for interactive declarations." + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +-- Returns the type as described by 'TcRnExprMode' +exprType :: GhcMonad m => TcRnExprMode -> String -> m Type +exprType mode expr = withSession $ \hsc_env -> do + ty <- liftIO $ hscTcExpr hsc_env mode expr + return $ tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: GhcMonad m => Bool -> String -> m (Type, Kind) +typeKind normalise str = withSession $ \hsc_env -> do + liftIO $ hscKcType hsc_env normalise str + +-- ---------------------------------------------------------------------------- +-- Getting the class instances for a type + +{- + Note [Querying instances for a type] + + Here is the implementation of GHC proposal 41. + (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) + + The objective is to take a query string representing a (partial) type, and + report all the class single-parameter class instances available to that type. + Extending this feature to multi-parameter typeclasses is left as future work. + + The general outline of how we solve this is: + + 1. Parse the type, leaving skolems in the place of type-holes. + 2. For every class, get a list of all instances that match with the query type. + 3. For every matching instance, ask GHC for the context the instance dictionary needs. + 4. Format and present the results, substituting our query into the instance + and simplifying the context. + + For example, given the query "Maybe Int", we want to return: + + instance Show (Maybe Int) + instance Read (Maybe Int) + instance Eq (Maybe Int) + .... + + [Holes in queries] + + Often times we want to know what instances are available for a polymorphic type, + like `Maybe a`, and we'd like to return instances such as: + + instance Show a => Show (Maybe a) + .... + + These queries are expressed using type holes, so instead of `Maybe a` the user writes + `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes + with (un-named) type variables. + + When zonking the type holes we have two real choices: replace them with Any or replace + them with skolem typevars. Using skolem type variables ensures that the output is more + intuitive to end users, and there is no difference in the results between Any and skolems. + +-} + +-- Find all instances that match a provided type +getInstancesForType :: GhcMonad m => Type -> m [ClsInst] +getInstancesForType ty = withSession $ \hsc_env -> do + liftIO $ runInteractiveHsc hsc_env $ do + ioMsgMaybe $ runTcInteractive hsc_env $ do + -- Bring class and instances from unqualified modules into scope, this fixes #16793. + loadUnqualIfaces hsc_env (hsc_IC hsc_env) + matches <- findMatchingInstances ty + fmap catMaybes . forM matches $ uncurry checkForExistence + +-- Parse a type string and turn any holes into skolems +parseInstanceHead :: GhcMonad m => String -> m Type +parseInstanceHead str = withSession $ \hsc_env0 -> do + (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty + + return ty + +-- Get all the constraints required of a dictionary binding +getDictionaryBindings :: PredType -> TcM WantedConstraints +getDictionaryBindings theta = do + dictName <- newName (mkDictOcc (mkVarOcc "magic")) + let dict_var = mkVanillaGlobal dictName theta + loc <- getCtLocM (GivenOrigin UnkSkol) Nothing + let wCs = mkSimpleWC [CtDerived + { ctev_pred = varType dict_var + , ctev_loc = loc + }] + + return wCs + +{- + When we've found an instance that a query matches against, we still need to + check that all the instance's constraints are satisfiable. checkForExistence + creates an instance dictionary and verifies that any unsolved constraints + mention a type-hole, meaning it is blocked on an unknown. + + If the instance satisfies this condition, then we return it with the query + substituted into the instance and all constraints simplified, for example given: + + instance D a => C (MyType a b) where + + and the query `MyType _ String` + + the unsolved constraints will be [D _] so we apply the substitution: + + { a -> _; b -> String} + + and return the instance: + + instance D _ => C (MyType _ String) + +-} + +checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst) +checkForExistence res mb_inst_tys = do + (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys + + wanteds <- forM thetas getDictionaryBindings + (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds)) + + let all_residual_constraints = bagToList $ wc_simple residuals + let preds = map ctPred all_residual_constraints + if all isSatisfiablePred preds && (null $ wc_impl residuals) + then return . Just $ substInstArgs tys preds res + else return Nothing + + where + + -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least + -- one argument or for the head to be a TyVar. The reason is that we want to ensure + -- that all residual constraints mention a type-hole somewhere in the constraint, + -- meaning that with the correct choice of a concrete type it could be possible for + -- the constraint to be discharged. + isSatisfiablePred :: PredType -> Bool + isSatisfiablePred ty = case getClassPredTys_maybe ty of + Just (_, tys@(_:_)) -> all isTyVarTy tys + _ -> isTyVarTy ty + + empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res))) + + {- Create a ClsInst with instantiated arguments and constraints. + + The thetas are the list of constraints that couldn't be solved because + they mention a type-hole. + -} + substInstArgs :: [Type] -> [PredType] -> ClsInst -> ClsInst + substInstArgs tys thetas inst = let + subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys) + -- Build instance head with arguments substituted in + tau = mkClassPred cls (substTheta subst args) + -- Constrain the instance with any residual constraints + phi = mkPhiTy thetas tau + sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi + + in inst { is_dfun = (is_dfun inst) { varType = sigma }} + where + (dfun_tvs, _, cls, args) = instanceSig inst + +-- Find instances where the head unifies with the provided type +findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])] +findMatchingInstances ty = do + ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs + let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local + + concat <$> mapM (\cls -> do + let (matches, _, _) = lookupInstEnv True ies cls [ty] + return matches) allClasses + +----------------------------------------------------------------------------- +-- Compile an expression, run it, and deliver the result + +-- | Parse an expression, the parsed expression can be further processed and +-- passed to compileParsedExpr. +parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) +parseExpr expr = withSession $ \hsc_env -> do + liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExpr :: GhcMonad m => String -> m HValue +compileExpr expr = do + parsed_expr <- parseExpr expr + compileParsedExpr parsed_expr + +-- | Compile an expression, run it, and deliver the resulting HValue. +compileExprRemote :: GhcMonad m => String -> m ForeignHValue +compileExprRemote expr = do + parsed_expr <- parseExpr expr + compileParsedExprRemote parsed_expr + +-- | Compile a parsed expression (before renaming), run it, and deliver +-- the resulting HValue. +compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue +compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do + -- > let _compileParsedExpr = expr + -- Create let stmt from expr to make hscParsedStmt happy. + -- We will ignore the returned [Id], namely [expr_id], and not really + -- create a new binding. + let expr_fs = fsLit "_compileParsedExpr" + expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc + let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $ + ValBinds noExtField + (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + + pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt + let (hvals_io, fix_env) = case pstmt of + Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') + _ -> panic "compileParsedExprRemote" + + updateFixityEnv fix_env + status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) + case status of + EvalComplete _ (EvalSuccess [hval]) -> return hval + EvalComplete _ (EvalException e) -> + liftIO $ throwIO (fromSerializableException e) + _ -> panic "compileParsedExpr" + +compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue +compileParsedExpr expr = do + fhv <- compileParsedExprRemote expr + dflags <- getDynFlags + liftIO $ wormhole dflags fhv + +-- | Compile an expression, run it and return the result as a Dynamic. +dynCompileExpr :: GhcMonad m => String -> m Dynamic +dynCompileExpr expr = do + parsed_expr <- parseExpr expr + -- > Data.Dynamic.toDyn expr + let loc = getLoc parsed_expr + to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) + parsed_expr + hval <- compileParsedExpr to_dyn_expr + return (unsafeCoerce# hval :: Dynamic) + +----------------------------------------------------------------------------- +-- show a module and it's source/object filenames + +showModule :: GhcMonad m => ModSummary -> m String +showModule mod_summary = + withSession $ \hsc_env -> do + interpreted <- moduleIsBootOrNotObjectLinkable mod_summary + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) + +moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool +moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> + case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> return $ case hm_linkable mod_info of + Nothing -> True + Just linkable -> not (isObjectLinkable linkable) + +---------------------------------------------------------------------------- +-- RTTI primitives + +obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term +obtainTermFromVal hsc_env bound force ty x + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") + | otherwise + = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) + +obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term +obtainTermFromId hsc_env bound force id = do + hv <- Linker.getHValue hsc_env (varName id) + cvObtainTerm hsc_env bound force (idType id) hv + +-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic +reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) +reconstructType hsc_env bound id = do + hv <- Linker.getHValue hsc_env (varName id) + cvReconstructType hsc_env bound (idType id) hv + +mkRuntimeUnkTyVar :: Name -> Kind -> TyVar +mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs new file mode 100644 index 0000000000..93072075c0 --- /dev/null +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -0,0 +1,89 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module GHC.Runtime.Eval.Types ( + Resume(..), History(..), ExecResult(..), + SingleStep(..), isStep, ExecOptions(..), + BreakInfo(..) + ) where + +import GhcPrelude + +import GHCi.RemoteTypes +import GHCi.Message (EvalExpr, ResumeContext) +import Id +import Name +import Module +import RdrName +import Type +import SrcLoc +import Exception + +import Data.Word +import GHC.Stack.CCS + +data ExecOptions + = ExecOptions + { execSingleStep :: SingleStep -- ^ stepping mode + , execSourceFile :: String -- ^ filename (for errors) + , execLineNumber :: Int -- ^ line number (for errors) + , execWrap :: ForeignHValue -> EvalExpr ForeignHValue + } + +data SingleStep + = RunToCompletion + | SingleStep + | RunAndLogSteps + +isStep :: SingleStep -> Bool +isStep RunToCompletion = False +isStep _ = True + +data ExecResult + = ExecComplete + { execResult :: Either SomeException [Name] + , execAllocation :: Word64 + } + | ExecBreak + { breakNames :: [Name] + , breakInfo :: Maybe BreakInfo + } + +data BreakInfo = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: Int + } + +data Resume = Resume + { resumeStmt :: String -- the original statement + , resumeContext :: ForeignRef (ResumeContext [HValueRef]) + , resumeBindings :: ([TyThing], GlobalRdrEnv) + , resumeFinalIds :: [Id] -- [Id] to bind on completion + , resumeApStack :: ForeignHValue -- The object from which we can get + -- value of the free variables. + , resumeBreakInfo :: Maybe BreakInfo + -- the breakpoint we stopped at + -- (module, index) + -- (Nothing <=> exception) + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + -- from the ModBreaks, + -- otherwise it's a pain to + -- fetch the ModDetails & + -- ModBreaks to get this. + , resumeDecl :: String -- ditto + , resumeCCS :: RemotePtr CostCentreStack + , resumeHistory :: [History] + , resumeHistoryIx :: Int -- 0 <==> at the top of the history + } + +data History + = History { + historyApStack :: ForeignHValue, + historyBreakInfo :: BreakInfo, + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint + } diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs new file mode 100644 index 0000000000..de6f9a7af3 --- /dev/null +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -0,0 +1,1355 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-} + +----------------------------------------------------------------------------- +-- +-- GHC Interactive support for inspecting arbitrary closures at runtime +-- +-- Pepe Iborra (supported by Google SoC) 2006 +-- +----------------------------------------------------------------------------- +module GHC.Runtime.Heap.Inspect( + -- * Entry points and types + cvObtainTerm, + cvReconstructType, + improveRTTIType, + Term(..), + + -- * Utils + isFullyEvaluatedTerm, + termType, mapTermType, termTyCoVars, + foldTerm, TermFold(..), + cPprTerm, cPprTermBase, + + constrClosToName -- exported to use in test T4891 + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Runtime.Interpreter as GHCi +import GHCi.RemoteTypes +import HscTypes + +import DataCon +import Type +import GHC.Types.RepType +import qualified Unify as U +import Var +import TcRnMonad +import TcType +import TcMType +import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) +import TcUnify +import TcEnv + +import TyCon +import Name +import OccName +import Module +import GHC.Iface.Env +import Util +import VarSet +import BasicTypes ( Boxity(..) ) +import TysPrim +import PrelNames +import TysWiredIn +import DynFlags +import Outputable as Ppr +import GHC.Char +import GHC.Exts.Heap +import GHC.Runtime.Heap.Layout ( roundUpTo ) + +import Control.Monad +import Data.Maybe +import Data.List ((\\)) +#if defined(INTEGER_GMP) +import GHC.Exts +import Data.Array.Base +import GHC.Integer.GMP.Internals +#elif defined(INTEGER_SIMPLE) +import GHC.Exts +import GHC.Integer.Simple.Internals +#endif +import qualified Data.Sequence as Seq +import Data.Sequence (viewl, ViewL(..)) +import Foreign +import System.IO.Unsafe + + +--------------------------------------------- +-- * A representation of semi evaluated Terms +--------------------------------------------- + +data Term = Term { ty :: RttiType + , dc :: Either String DataCon + -- Carries a text representation if the datacon is + -- not exported by the .hi file, which is the case + -- for private constructors in -O0 compiled libraries + , val :: ForeignHValue + , subTerms :: [Term] } + + | Prim { ty :: RttiType + , valRaw :: [Word] } + + | Suspension { ctype :: ClosureType + , ty :: RttiType + , val :: ForeignHValue + , bound_to :: Maybe Name -- Useful for printing + } + | NewtypeWrap{ -- At runtime there are no newtypes, and hence no + -- newtype constructors. A NewtypeWrap is just a + -- made-up tag saying "heads up, there used to be + -- a newtype constructor here". + ty :: RttiType + , dc :: Either String DataCon + , wrapped_term :: Term } + | RefWrap { -- The contents of a reference + ty :: RttiType + , wrapped_term :: Term } + +termType :: Term -> RttiType +termType t = ty t + +isFullyEvaluatedTerm :: Term -> Bool +isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt +isFullyEvaluatedTerm Prim {} = True +isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm _ = False + +instance Outputable (Term) where + ppr t | Just doc <- cPprTerm cPprTermBase t = doc + | otherwise = panic "Outputable Term instance" + +---------------------------------------- +-- Runtime Closure information functions +---------------------------------------- + +isThunk :: GenClosure a -> Bool +isThunk ThunkClosure{} = True +isThunk APClosure{} = True +isThunk APStackClosure{} = True +isThunk _ = False + +-- Lookup the name in a constructor closure +constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name) +constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do + let occName = mkOccName OccName.dataName occ + modName = mkModule (stringToUnitId pkg) (mkModuleName mod) + Right `fmap` lookupOrigIO hsc_env modName occName +constrClosToName _hsc_env clos = + return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos))) + +----------------------------------- +-- * Traversals for Terms +----------------------------------- +type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b + +data TermFold a = TermFold { fTerm :: TermProcessor a a + , fPrim :: RttiType -> [Word] -> a + , fSuspension :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> a + , fNewtypeWrap :: RttiType -> Either String DataCon + -> a -> a + , fRefWrap :: RttiType -> a -> a + } + + +data TermFoldM m a = + TermFoldM {fTermM :: TermProcessor a (m a) + , fPrimM :: RttiType -> [Word] -> m a + , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue + -> Maybe Name -> m a + , fNewtypeWrapM :: RttiType -> Either String DataCon + -> a -> m a + , fRefWrapM :: RttiType -> a -> m a + } + +foldTerm :: TermFold a -> Term -> a +foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) +foldTerm tf (Prim ty v ) = fPrim tf ty v +foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b +foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) +foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) + + +foldTermM :: Monad m => TermFoldM m a -> Term -> m a +foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v +foldTermM tf (Prim ty v ) = fPrimM tf ty v +foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b +foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc +foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty + +idTermFold :: TermFold Term +idTermFold = TermFold { + fTerm = Term, + fPrim = Prim, + fSuspension = Suspension, + fNewtypeWrap = NewtypeWrap, + fRefWrap = RefWrap + } + +mapTermType :: (RttiType -> Type) -> Term -> Term +mapTermType f = foldTerm idTermFold { + fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, + fSuspension = \ct ty hval n -> + Suspension ct (f ty) hval n, + fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, + fRefWrap = \ty t -> RefWrap (f ty) t} + +mapTermTypeM :: Monad m => (RttiType -> m Type) -> Term -> m Term +mapTermTypeM f = foldTermM TermFoldM { + fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, + fPrimM = (return.) . Prim, + fSuspensionM = \ct ty hval n -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n, + fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, + fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} + +termTyCoVars :: Term -> TyCoVarSet +termTyCoVars = foldTerm TermFold { + fTerm = \ty _ _ tt -> + tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, + fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, + fPrim = \ _ _ -> emptyVarSet, + fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, + fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} + where concatVarEnv = foldr unionVarSet emptyVarSet + +---------------------------------- +-- Pretty printing of terms +---------------------------------- + +type Precedence = Int +type TermPrinterM m = Precedence -> Term -> m SDoc + +app_prec,cons_prec, max_prec ::Int +max_prec = 10 +app_prec = max_prec +cons_prec = 5 -- TODO Extract this info from GHC itself + +pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m +pprTermM y p t = pprDeeper `liftM` ppr_termM y p t + +ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do + tt_docs <- mapM (y app_prec) tt + return $ cparen (not (null tt) && p >= app_prec) + (text dc_tag <+> pprDeeperList fsep tt_docs) + +ppr_termM y p Term{dc=Right dc, subTerms=tt} +{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) +-} -- TODO Printing infix constructors properly + = do { tt_docs' <- mapM (y app_prec) tt + ; return $ ifPprDebug (show_tm tt_docs') + (show_tm (dropList (dataConTheta dc) tt_docs')) + -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + } + where + show_tm tt_docs + | null tt_docs = ppr dc + | otherwise = cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] + +ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t +ppr_termM y p RefWrap{wrapped_term=t} = do + contents <- y app_prec t + return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) + -- The constructor name is wired in here ^^^ for the sake of simplicity. + -- I don't think mutvars are going to change in a near future. + -- In any case this is solely a presentation matter: MutVar# is + -- a datatype with no constructors, implemented by the RTS + -- (hence there is no way to obtain a datacon and print it). +ppr_termM _ _ t = ppr_termM1 t + + +ppr_termM1 :: Monad m => Term -> m SDoc +ppr_termM1 Prim{valRaw=words, ty=ty} = + return $ repPrim (tyConAppTyCon ty) words +ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = + return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) +ppr_termM1 Suspension{ty=ty, bound_to=Just n} +-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>") + | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty +ppr_termM1 Term{} = panic "ppr_termM1 - Term" +ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" +ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" + +pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} + | Just (tc,_) <- tcSplitTyConApp_maybe ty + , ASSERT(isNewTyCon tc) True + , Just new_dc <- tyConSingleDataCon_maybe tc = do + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) +pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" + +------------------------------------------------------- +-- Custom Term Pretty Printers +------------------------------------------------------- + +-- We can want to customize the representation of a +-- term depending on its type. +-- However, note that custom printers have to work with +-- type representations, instead of directly with types. +-- We cannot use type classes here, unless we employ some +-- typerep trickery (e.g. Weirich's RepLib tricks), +-- which I didn't. Therefore, this code replicates a lot +-- of what type classes provide for free. + +type CustomTermPrinter m = TermPrinterM m + -> [Precedence -> Term -> (m (Maybe SDoc))] + +-- | Takes a list of custom printers with a explicit recursion knot and a term, +-- and returns the output of the first successful printer, or the default printer +cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc +cPprTerm printers_ = go 0 where + printers = printers_ go + go prec t = do + let default_ = Just `liftM` pprTermM go prec t + mb_customDocs = [pp prec t | pp <- printers] ++ [default_] + mdoc <- firstJustM mb_customDocs + case mdoc of + Nothing -> panic "cPprTerm" + Just doc -> return $ cparen (prec>app_prec+1) doc + + firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) + firstJustM [] = return Nothing + +-- Default set of custom printers. Note that the recursion knot is explicit +cPprTermBase :: forall m. Monad m => CustomTermPrinter m +cPprTermBase y = + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + . mapM (y (-1)) + . subTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) + ppr_list + , ifTerm' (isTyCon intTyCon . ty) ppr_int + , ifTerm' (isTyCon charTyCon . ty) ppr_char + , ifTerm' (isTyCon floatTyCon . ty) ppr_float + , ifTerm' (isTyCon doubleTyCon . ty) ppr_double + , ifTerm' (isIntegerTy . ty) ppr_integer + ] + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t) + + ifTerm' :: (Term -> Bool) + -> (Precedence -> Term -> m (Maybe SDoc)) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm' pred f prec t@Term{} + | pred t = f prec t + ifTerm' _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + isIntegerTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (tyConName tc == integerTyConName) + + ppr_int, ppr_char, ppr_float, ppr_double + :: Precedence -> Term -> m (Maybe SDoc) + ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.int (fromIntegral w))) + ppr_int _ _ = return Nothing + + ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} = + return (Just (Ppr.pprHsChar (chr (fromIntegral w)))) + ppr_char _ _ = return Nothing + + ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.float f)) + ppr_float _ _ = return Nothing + + ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> poke p w >> peek (castPtr p) + return (Just (Ppr.double f)) + -- let's assume that if we get two words, we're on a 32-bit + -- machine. There's no good way to get a DynFlags to check the word + -- size here. + ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do + let f = unsafeDupablePerformIO $ + alloca $ \p -> do + poke p (fromIntegral w1 :: Word32) + poke (p `plusPtr` 4) (fromIntegral w2 :: Word32) + peek (castPtr p) + return (Just (Ppr.double f)) + ppr_double _ _ = return Nothing + + ppr_integer :: Precedence -> Term -> m (Maybe SDoc) +#if defined(INTEGER_GMP) + -- Reconstructing Integers is a bit of a pain. This depends deeply + -- on the integer-gmp representation, so it'll break if that + -- changes (but there are several tests in + -- tests/ghci.debugger/scripts that will tell us if this is wrong). + -- + -- data Integer + -- = S# Int# + -- | Jp# {-# UNPACK #-} !BigNat + -- | Jn# {-# UNPACK #-} !BigNat + -- + -- data BigNat = BN# ByteArray# + -- + ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} = + return (Just (Ppr.integer (S# (word2Int# w)))) + ppr_integer _ Term{dc=Right con, + subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do + -- We don't need to worry about sizes that are not an integral + -- number of words, because luckily GMP uses arrays of words + -- (see GMP_LIMB_SHIFT). + let + !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws + constr + | "Jp#" <- getOccString (dataConName con) = Jp# + | otherwise = Jn# + return (Just (Ppr.integer (constr (BN# arr#)))) +#elif defined(INTEGER_SIMPLE) + -- As with the GMP case, this depends deeply on the integer-simple + -- representation. + -- + -- @ + -- data Integer = Positive !Digits | Negative !Digits | Naught + -- + -- data Digits = Some !Word# !Digits + -- | None + -- @ + -- + -- NB: the above has some type synonyms expanded out for the sake of brevity + ppr_integer _ Term{subTerms=[]} = + return (Just (Ppr.integer Naught)) + ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]} + | Just digits <- get_digits digitTerm + = return (Just (Ppr.integer (constr digits))) + where + get_digits :: Term -> Maybe Digits + get_digits Term{subTerms=[]} = Just None + get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]} + = Some w <$> get_digits t + get_digits _ = Nothing + + constr + | "Positive" <- getOccString (dataConName con) = Positive + | otherwise = Negative +#endif + ppr_integer _ _ = return Nothing + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h : getListTerms t + isConsLast = not (termType (last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + chars = [ chr (fromIntegral w) + | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ] + + print_elems <- mapM (y cons_prec) elems + if is_string + then return (Ppr.doubleQuotes (Ppr.text chars)) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" + + +repPrim :: TyCon -> [Word] -> SDoc +repPrim t = rep where + rep x + -- Char# uses native machine words, whereas Char's Storable instance uses + -- Int32, so we have to read it as an Int. + | t == charPrimTyCon = text $ show (chr (build x :: Int)) + | t == intPrimTyCon = text $ show (build x :: Int) + | t == wordPrimTyCon = text $ show (build x :: Word) + | t == floatPrimTyCon = text $ show (build x :: Float) + | t == doublePrimTyCon = text $ show (build x :: Double) + | t == int32PrimTyCon = text $ show (build x :: Int32) + | t == word32PrimTyCon = text $ show (build x :: Word32) + | t == int64PrimTyCon = text $ show (build x :: Int64) + | t == word64PrimTyCon = text $ show (build x :: Word64) + | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) + | t == stablePtrPrimTyCon = text "<stablePtr>" + | t == stableNamePrimTyCon = text "<stableName>" + | t == statePrimTyCon = text "<statethread>" + | t == proxyPrimTyCon = text "<proxy>" + | t == realWorldTyCon = text "<realworld>" + | t == threadIdPrimTyCon = text "<ThreadId>" + | t == weakPrimTyCon = text "<Weak>" + | t == arrayPrimTyCon = text "<array>" + | t == smallArrayPrimTyCon = text "<smallArray>" + | t == byteArrayPrimTyCon = text "<bytearray>" + | t == mutableArrayPrimTyCon = text "<mutableArray>" + | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>" + | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>" + | t == mutVarPrimTyCon = text "<mutVar>" + | t == mVarPrimTyCon = text "<mVar>" + | t == tVarPrimTyCon = text "<tVar>" + | otherwise = char '<' <> ppr t <> char '>' + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. + +----------------------------------- +-- Type Reconstruction +----------------------------------- +{- +Type Reconstruction is type inference done on heap closures. +The algorithm walks the heap generating a set of equations, which +are solved with syntactic unification. +A type reconstruction equation looks like: + + <datacon reptype> = <actual heap contents> + +The full equation set is generated by traversing all the subterms, starting +from a given term. + +The only difficult part is that newtypes are only found in the lhs of equations. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. + +The function congruenceNewtypes takes a shot at (b) +-} + + +-- A (non-mutable) tau type containing +-- existentially quantified tyvars. +-- (since GHC type language currently does not support +-- existentials, we leave these variables unquantified) +type RttiType = Type + +-- An incomplete type as stored in GHCi: +-- no polymorphism: no quantifiers & all tyvars are skolem. +type GhciType = Type + + +-- The Type Reconstruction monad +-------------------------------- +type TR a = TcM a + +runTR :: HscEnv -> TR a -> IO a +runTR hsc_env thing = do + mb_val <- runTR_maybe hsc_env thing + case mb_val of + Nothing -> error "unable to :print the term" + Just x -> return x + +runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) +runTR_maybe hsc_env thing_inside + = do { (_errs, res) <- initTcInteractive hsc_env thing_inside + ; return res } + +-- | Term Reconstruction trace +traceTR :: SDoc -> TR () +traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti + + +-- Semantically different to recoverM in TcRnMonad +-- recoverM retains the errors in the first action, +-- whereas recoverTc here does not +recoverTR :: TR a -> TR a -> TR a +recoverTR = tryTcDiscardingErrs + +trIO :: IO a -> TR a +trIO = liftTcM . liftIO + +liftTcM :: TcM a -> TR a +liftTcM = id + +newVar :: Kind -> TR TcType +newVar = liftTcM . newFlexiTyVarTy + +newOpenVar :: TR TcType +newOpenVar = liftTcM newOpenFlexiTyVarTy + +instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars tvs + = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs) + +type RttiInstantiation = [(TcTyVar, TyVar)] + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their + -- debugger-world RuntimeUnk counterparts. + -- If the TcTyVar has not been refined by the runtime type + -- elaboration, then we want to turn it back into the + -- original RuntimeUnk + +-- | Returns the instantiated type scheme ty', and the +-- mapping from new (instantiated) -to- old (skolem) type variables +instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) +instScheme (tvs, ty) + = do { (subst, tvs') <- instTyVars tvs + ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] + ; return (substTy subst ty, rtti_inst) } + +applyRevSubst :: RttiInstantiation -> TR () +-- Apply the *reverse* substitution in-place to any un-filled-in +-- meta tyvars. This recovers the original debugger-world variable +-- unless it has been refined by new information from the heap +applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) + where + do_pair (tc_tv, rtti_tv) + = do { tc_ty <- zonkTcTyVar tc_tv + ; case tcGetTyVar_maybe tc_ty of + Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) + _ -> return () } + +-- Adds a constraint of the form t1 == t2 +-- t1 is expected to come from walking the heap +-- t2 is expected to come from a datacon signature +-- Before unification, congruenceNewtypes needs to +-- do its magic. +addConstraint :: TcType -> TcType -> TR () +addConstraint actual expected = do + traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected]) + recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, + text "with", ppr expected]) $ + discardResult $ + captureConstraints $ + do { (ty1, ty2) <- congruenceNewtypes actual expected + ; unifyType Nothing ty1 ty2 } + -- TOMDO: what about the coercion? + -- we should consider family instances + + +-- | Term reconstruction +-- +-- Given a pointer to a heap object (`HValue`) and its type, build a `Term` +-- representation of the object. Subterms (objects in the payload) are also +-- built up to the given `max_depth`. After `max_depth` any subterms will appear +-- as `Suspension`s. Any thunks found while traversing the object will be forced +-- based on `force` parameter. +-- +-- Types of terms will be refined based on constructors we find during term +-- reconstruction. See `cvReconstructType` for an overview of how type +-- reconstruction works. +-- +cvObtainTerm + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> Bool -- ^ Force thunks + -> RttiType -- ^ Type of the object to reconstruct + -> ForeignHValue -- ^ Object to reconstruct + -> IO Term +cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do + -- we quantify existential tyvars as universal, + -- as this is needed to be able to manipulate + -- them properly + let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty + sigma_old_ty = mkInvForAllTys old_tvs old_tau + traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) + term <- + if null old_tvs + then do + term <- go max_depth sigma_old_ty sigma_old_ty hval + term' <- zonkTerm term + return $ fixFunDictionaries $ expandNewtypes term' + else do + (old_ty', rev_subst) <- instScheme quant_old_ty + my_ty <- newOpenVar + when (check1 quant_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + term <- go max_depth my_ty sigma_old_ty hval + new_ty <- zonkTcType (termType term) + if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty + then do + traceTR (text "check2 passed") + addConstraint new_ty old_ty' + applyRevSubst rev_subst + zterm' <- zonkTerm term + return ((fixFunDictionaries . expandNewtypes) zterm') + else do + traceTR (text "check2 failed" <+> parens + (ppr term <+> text "::" <+> ppr new_ty)) + -- we have unsound types. Replace constructor types in + -- subterms with tyvars + zterm' <- mapTermTypeM + (\ty -> case tcSplitTyConApp_maybe ty of + Just (tc, _:_) | tc /= funTyCon + -> newOpenVar + _ -> return ty) + term + zonkTerm zterm' + traceTR (text "Term reconstruction completed." $$ + text "Term obtained: " <> ppr term $$ + text "Type obtained: " <> ppr (termType term)) + return term + where + go :: Int -> Type -> Type -> ForeignHValue -> TcM Term + -- I believe that my_ty should not have any enclosing + -- foralls, nor any free RuntimeUnk skolems; + -- that is partly what the quantifyType stuff achieved + -- + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + + go 0 my_ty _old_ty a = do + traceTR (text "Gave up reconstructing a term after" <> + int max_depth <> text " steps") + clos <- trIO $ GHCi.getClosure hsc_env a + return (Suspension (tipe (info clos)) my_ty a Nothing) + go !max_depth my_ty old_ty a = do + let monomorphic = not(isTyVarTy my_ty) + -- This ^^^ is a convention. The ancestor tests for + -- monomorphism and passes a type instead of a tv + clos <- trIO $ GHCi.getClosure hsc_env a + case clos of +-- Thunks we may want to force + t | isThunk t && force -> do + traceTR (text "Forcing a " <> text (show (fmap (const ()) t))) + liftIO $ GHCi.seqHValue hsc_env a + go (pred max_depth) my_ty old_ty a +-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If +-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as +-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead +-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic). + BlackholeClosure{indirectee=ind} -> do + traceTR (text "Following a BLACKHOLE") + ind_clos <- trIO (GHCi.getClosure hsc_env ind) + let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing) + case ind_clos of + -- TSO and BLOCKING_QUEUE cases + BlockingQueueClosure{} -> return_bh_value + OtherClosure info _ _ + | tipe info == TSO -> return_bh_value + UnsupportedClosure info + | tipe info == TSO -> return_bh_value + -- Otherwise follow the indirectee + -- (NOTE: This code will break if we support TSO in ghc-heap one day) + _ -> go max_depth my_ty old_ty ind +-- We always follow indirections + IndClosure{indirectee=ind} -> do + traceTR (text "Following an indirection" ) + go max_depth my_ty old_ty ind +-- We also follow references + MutVarClosure{var=contents} + | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + -> do + -- Deal with the MutVar# primitive + -- It does not have a constructor at all, + -- so we simulate the following one + -- MutVar# :: contents_ty -> MutVar# s contents_ty + traceTR (text "Following a MutVar") + contents_tv <- newVar liftedTypeKind + MASSERT(isUnliftedType my_ty) + (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTy + contents_ty (mkTyConApp tycon [world,contents_ty]) + addConstraint (mkVisFunTy contents_tv my_ty) mutvar_ty + x <- go (pred max_depth) contents_tv contents_ty contents + return (RefWrap my_ty x) + + -- The interesting case + ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do + traceTR (text "entering a constructor " <> ppr dArgs <+> + if monomorphic + then parens (text "already monomorphic: " <> ppr my_ty) + else Ppr.empty) + Right dcname <- liftIO $ constrClosToName hsc_env clos + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing -> do -- This can happen for private constructors compiled -O0 + -- where the .hi descriptor does not export them + -- In such case, we return a best approximation: + -- ignore the unpointed args, and recover the pointeds + -- This preserves laziness, and should be safe. + traceTR (text "Not constructor" <+> ppr dcname) + let dflags = hsc_dflags hsc_env + tag = showPpr dflags dcname + vars <- replicateM (length pArgs) + (newVar liftedTypeKind) + subTerms <- sequence $ zipWith (\x tv -> + go (pred max_depth) tv tv x) pArgs vars + return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) + Just dc -> do + traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) + subTtypes <- getDataConArgTys dc my_ty + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes + return (Term my_ty (Right dc) a subTerms) + + -- This is to support printing of Integers. It's not a general + -- mechanism by any means; in particular we lose the size in + -- bytes of the array. + ArrWordsClosure{bytes=b, arrWords=ws} -> do + traceTR (text "ByteArray# closure, size " <> ppr b) + return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws]) + +-- The otherwise case: can be a Thunk,AP,PAP,etc. + _ -> do + traceTR (text "Unknown closure:" <+> + text (show (fmap (const ()) clos))) + return (Suspension (tipe (info clos)) my_ty a Nothing) + + -- insert NewtypeWraps around newtypes + expandNewtypes = foldTerm idTermFold { fTerm = worker } where + worker ty dc hval tt + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , isNewTyCon tc + , wrapped_type <- newTyConInstRhs tc args + , Just dc' <- tyConSingleDataCon_maybe tc + , t' <- worker wrapped_type dc hval tt + = NewtypeWrap ty (Right dc') t' + | otherwise = Term ty dc hval tt + + + -- Avoid returning types where predicates have been expanded to dictionaries. + fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where + worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n + | otherwise = Suspension ct ty hval n + +extractSubTerms :: (Type -> ForeignHValue -> TcM Term) + -> GenClosure ForeignHValue -> [Type] -> TcM [Term] +extractSubTerms recurse clos = liftM thdOf3 . go 0 0 + where + array = dataArgs clos + + go ptr_i arr_i [] = return (ptr_i, arr_i, []) + go ptr_i arr_i (ty:tys) + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + = do (ptr_i, arr_i, terms0) <- + go ptr_i arr_i (dropRuntimeRepArgs elem_tys) + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + | otherwise + = case typePrimRepArgs ty of + [rep_ty] -> do + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, term0 : terms1) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys + (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys + return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) + + go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, []) + go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do + tv <- newVar liftedTypeKind + (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i tv rep_ty + (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys + return (ptr_i, arr_i, term0 : terms1) + + go_rep ptr_i arr_i ty rep + | isGcPtrRep rep = do + t <- recurse ty $ (ptrArgs clos)!!ptr_i + return (ptr_i + 1, arr_i, t) + | otherwise = do + -- This is a bit involved since we allow packing multiple fields + -- within a single word. See also + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding + dflags <- getDynFlags + let word_size = wORD_SIZE dflags + big_endian = wORDS_BIGENDIAN dflags + size_b = primRepSizeB dflags rep + -- Align the start offset (eg, 2-byte value should be 2-byte + -- aligned). But not more than to a word. The offset calculation + -- should be the same with the offset calculation in + -- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding. + !aligned_idx = roundUpTo arr_i (min word_size size_b) + !new_arr_i = aligned_idx + size_b + ws | size_b < word_size = + [index size_b aligned_idx word_size big_endian] + | otherwise = + let (q, r) = size_b `quotRem` word_size + in ASSERT( r == 0 ) + [ array!!i + | o <- [0.. q - 1] + , let i = (aligned_idx `quot` word_size) + o + ] + return (ptr_i, new_arr_i, Prim ty ws) + + unboxedTupleTerm ty terms + = Term ty (Right (tupleDataCon Unboxed (length terms))) + (error "unboxedTupleTerm: no HValue for unboxed tuple") terms + + -- Extract a sub-word sized field from a word + index item_size_b index_b word_size big_endian = + (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes + where + mask :: Word + mask = case item_size_b of + 1 -> 0xFF + 2 -> 0xFFFF + 4 -> 0xFFFFFFFF + _ -> panic ("Weird byte-index: " ++ show index_b) + (q,r) = index_b `quotRem` word_size + word = array!!q + moveBytes = if big_endian + then word_size - (r + item_size_b) * 8 + else r * 8 + + +-- | Fast, breadth-first Type reconstruction +-- +-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually +-- obtained in GHCi), try to reconstruct a more monomorphic type of the object. +-- This is used for improving type information in debugger. For example, if we +-- have a polymorphic function: +-- +-- sumNumList :: Num a => [a] -> a +-- sumNumList [] = 0 +-- sumNumList (x : xs) = x + sumList xs +-- +-- and add a breakpoint to it: +-- +-- ghci> break sumNumList +-- ghci> sumNumList ([0 .. 9] :: [Int]) +-- +-- ghci shows us more precise types than just `a`s: +-- +-- Stopped in Main.sumNumList, debugger.hs:3:23-39 +-- _result :: Int = _ +-- x :: Int = 0 +-- xs :: [Int] = _ +-- +cvReconstructType + :: HscEnv + -> Int -- ^ How many times to recurse for subterms + -> GhciType -- ^ Type to refine + -> ForeignHValue -- ^ Refine the type using this value + -> IO (Maybe Type) +cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do + traceTR (text "RTTI started with initial type " <> ppr old_ty) + let sigma_old_ty@(old_tvs, _) = quantifyType old_ty + new_ty <- + if null old_tvs + then return old_ty + else do + (old_ty', rev_subst) <- instScheme sigma_old_ty + my_ty <- newOpenVar + when (check1 sigma_old_ty) (traceTR (text "check1 passed") >> + addConstraint my_ty old_ty') + search (isMonomorphic `fmap` zonkTcType my_ty) + (\(ty,a) -> go ty a) + (Seq.singleton (my_ty, hval)) + max_depth + new_ty <- zonkTcType my_ty + if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty + then do + traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) + addConstraint my_ty old_ty' + applyRevSubst rev_subst + zonkRttiType new_ty + else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >> + return old_ty + traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) + return new_ty + where +-- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () + search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> + int max_depth <> text " steps") + search stop expand l d = + case viewl l of + EmptyL -> return () + x :< xx -> unlessM stop $ do + new <- expand x + search stop expand (xx `mappend` Seq.fromList new) $! (pred d) + + -- returns unification tasks,since we are going to want a breadth-first search + go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)] + go my_ty a = do + traceTR (text "go" <+> ppr my_ty) + clos <- trIO $ GHCi.getClosure hsc_env a + case clos of + BlackholeClosure{indirectee=ind} -> go my_ty ind + IndClosure{indirectee=ind} -> go my_ty ind + MutVarClosure{var=contents} -> do + tv' <- newVar liftedTypeKind + world <- newVar liftedTypeKind + addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) + return [(tv', contents)] + ConstrClosure{ptrArgs=pArgs} -> do + Right dcname <- liftIO $ constrClosToName hsc_env clos + traceTR (text "Constr1" <+> ppr dcname) + (mb_dc, _) <- tryTc (tcLookupDataCon dcname) + case mb_dc of + Nothing-> do + forM pArgs $ \x -> do + tv <- newVar liftedTypeKind + return (tv, x) + + Just dc -> do + arg_tys <- getDataConArgTys dc my_ty + (_, itys) <- findPtrTyss 0 arg_tys + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs + _ -> return [] + +findPtrTys :: Int -- Current pointer index + -> Type -- Type + -> TR (Int, [(Int, Type)]) +findPtrTys i ty + | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty + , isUnboxedTupleTyCon tc + = findPtrTyss i elem_tys + + | otherwise + = case typePrimRep ty of + [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)]) + | otherwise -> return (i, []) + prim_reps -> + foldM (\(i, extras) prim_rep -> + if isGcPtrRep prim_rep + then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)]) + else return (i, extras)) + (i, []) prim_reps + +findPtrTyss :: Int + -> [Type] + -> TR (Int, [(Int, Type)]) +findPtrTyss i tys = foldM step (i, []) tys + where step (i, discovered) elem_ty = do + (i, extras) <- findPtrTys i elem_ty + return (i, discovered ++ extras) + + +-- Compute the difference between a base type and the type found by RTTI +-- improveType <base_type> <rtti_type> +-- The types can contain skolem type variables, which need to be treated as normal vars. +-- In particular, we want them to unify with things. +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst +improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty + +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +-- +-- I believe that con_app_ty should not have any enclosing foralls +getDataConArgTys dc con_app_ty + = do { let rep_con_app_ty = unwrapType con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) + ; ASSERT( all isTyVar ex_tvs ) return () + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018) + ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) + ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) + -- See Note [Constructor arg types] + ; let con_arg_tys = substTys subst (dataConRepArgTys dc) + ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst)) + ; return con_arg_tys } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + +{- Note [Constructor arg types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a GADT (cf #7386) + data family D a b + data instance D [a] a where + MkT :: a -> D [a] (Maybe a) + ... + +In getDataConArgTys +* con_app_ty is the known type (from outside) of the constructor application, + say D [Int] Int + +* The data constructor MkT has a (representation) dataConTyCon = DList, + say where + data DList a where + MkT :: a -> DList a (Maybe a) + ... + +So the dataConTyCon of the data constructor, DList, differs from +the "outside" type, D. So we can't straightforwardly decompose the +"outside" type, and we end up in the "_" branch of the case. + +Then we match the dataConOrigResTy of the data constructor against the +outside type, hoping to get a substitution that tells how to instantiate +the *representation* type constructor. This looks a bit delicate to +me, but it seems to work. +-} + +-- Soundness checks +-------------------- +{- +This is not formalized anywhere, so hold to your seats! +RTTI in the presence of newtypes can be a tricky and unsound business. + +Example: +~~~~~~~~~ +Suppose we are doing RTTI for a partially evaluated +closure t, the real type of which is t :: MkT Int, for + + newtype MkT a = MkT [Maybe a] + +The table below shows the results of RTTI and the improvement +calculated for different combinations of evaluatedness and :type t. +Regard the two first columns as input and the next two as output. + + # | t | :type t | rtti(t) | improv. | result + ------------------------------------------------------------ + 1 | _ | t b | a | none | OK + 2 | _ | MkT b | a | none | OK + 3 | _ | t Int | a | none | OK + + If t is not evaluated at *all*, we are safe. + + 4 | (_ : _) | t b | [a] | t = [] | UNSOUND + 5 | (_ : _) | MkT b | MkT a | none | OK (compensating for the missing newtype) + 6 | (_ : _) | t Int | [Int] | t = [] | UNSOUND + + If a is a minimal whnf, we run into trouble. Note that + row 5 above does newtype enrichment on the ty_rtty parameter. + + 7 | (Just _:_)| t b |[Maybe a] | t = [], | UNSOUND + | | | b = Maybe a| + + 8 | (Just _:_)| MkT b | MkT a | none | OK + 9 | (Just _:_)| t Int | FAIL | none | OK + + And if t is any more evaluated than whnf, we are still in trouble. + Because constraints are solved in top-down order, when we reach the + Maybe subterm what we got is already unsound. This explains why the + row 9 fails to complete. + + 10 | (Just _:_)| t Int | [Maybe a] | FAIL | OK + 11 | (Just 1:_)| t Int | [Maybe Int] | FAIL | OK + + We can undo the failure in row 9 by leaving out the constraint + coming from the type signature of t (i.e., the 2nd column). + Note that this type information is still used + to calculate the improvement. But we fail + when trying to calculate the improvement, as there is no unifier for + t Int = [Maybe a] or t Int = [Maybe Int]. + + + Another set of examples with t :: [MkT (Maybe Int)] \equiv [[Maybe (Maybe Int)]] + + # | t | :type t | rtti(t) | improvement | result + --------------------------------------------------------------------- + 1 |(Just _:_) | [t (Maybe a)] | [[Maybe b]] | t = [] | + | | | | b = Maybe a | + +The checks: +~~~~~~~~~~~ +Consider a function obtainType that takes a value and a type and produces +the Term representation and a substitution (the improvement). +Assume an auxiliar rtti' function which does the actual job if recovering +the type, but which may produce a false type. + +In pseudocode: + + rtti' :: a -> IO Type -- Does not use the static type information + + obtainType :: a -> Type -> IO (Maybe (Term, Improvement)) + obtainType v old_ty = do + rtti_ty <- rtti' v + if monomorphic rtti_ty || (check rtti_ty old_ty) + then ... + else return Nothing + where check rtti_ty old_ty = check1 rtti_ty && + check2 rtti_ty old_ty + + check1 :: Type -> Bool + check2 :: Type -> Type -> Bool + +Now, if rtti' returns a monomorphic type, we are safe. +If that is not the case, then we consider two conditions. + + +1. To prevent the class of unsoundness displayed by + rows 4 and 7 in the example: no higher kind tyvars + accepted. + + check1 (t a) = NO + check1 (t Int) = NO + check1 ([] a) = YES + +2. To prevent the class of unsoundness shown by row 6, + the rtti type should be structurally more + defined than the old type we are comparing it to. + check2 :: NewType -> OldType -> Bool + check2 a _ = True + check2 [a] a = True + check2 [a] (t Int) = False + check2 [a] (t a) = False -- By check1 we never reach this equation + check2 [Int] a = True + check2 [Int] (t Int) = True + check2 [Maybe a] (t Int) = False + check2 [Maybe Int] (t Int) = True + check2 (Maybe [a]) (m [Int]) = False + check2 (Maybe [Int]) (m [Int]) = True + +-} + +check1 :: QuantifiedType -> Bool +check1 (tvs, _) = not $ any isHigherKind (map tyVarKind tvs) + where + isHigherKind = not . null . fst . splitPiTys + +check2 :: QuantifiedType -> QuantifiedType -> Bool +check2 (_, rtti_ty) (_, old_ty) + | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty + = case () of + _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty + -> and$ zipWith check2 (map quantifyType rttis) (map quantifyType olds) + _ | Just _ <- splitAppTy_maybe old_ty + -> isMonomorphicOnNonPhantomArgs rtti_ty + _ -> True + | otherwise = True + +-- Dealing with newtypes +-------------------------- +{- + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present + in runtime, but sometimes there is evidence available. + Evidence can come from DataCon signatures or + from compile-time type inference. + What we are doing here is an approximation + of unification modulo a set of equations derived + from newtype definitions. These equations should be the + same as the equality coercions generated for newtypes + in System Fc. The idea is to perform a sort of rewriting, + taking those equations as rules, before launching unification. + + The caller must ensure the following. + The 1st type (lhs) comes from the heap structure of ptrs,nptrs. + The 2nd type (rhs) comes from a DataCon type signature. + Rewriting (i.e. adding/removing a newtype wrapper) can happen + in both types, but in the rhs it is restricted to the result type. + + Note that it is very tricky to make this 'rewriting' + work with the unification implemented by TcM, where + substitutions are operationally inlined. The order in which + constraints are unified is vital as we cannot modify + anything that has been touched by a previous unification step. +Therefore, congruenceNewtypes is sound only if the types +recovered by the RTTI mechanism are unified Top-Down. +-} +congruenceNewtypes :: TcType -> TcType -> TR (TcType,TcType) +congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') + where + go l r + -- TyVar lhs inductive case + | Just tv <- getTyVar_maybe l + , isTcTyVar tv + , isMetaTyVar tv + = recoverTR (return r) $ do + Indirect ty_v <- readMetaTyVar tv + traceTR $ fsep [text "(congruence) Following indirect tyvar:", + ppr tv, equals, ppr ty_v] + go ty_v r +-- FunTy inductive case + | Just (l1,l2) <- splitFunTy_maybe l + , Just (r1,r2) <- splitFunTy_maybe r + = do r2' <- go l2 r2 + r1' <- go l1 r1 + return (mkVisFunTy r1' r2') +-- TyconApp Inductive case; this is the interesting bit. + | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r + = upgrade tycon_l r + + | otherwise = return r + + where upgrade :: TyCon -> Type -> TR Type + upgrade new_tycon ty + | not (isNewTyCon new_tycon) = do + traceTR (text "(Upgrade) Not matching newtype evidence: " <> + ppr new_tycon <> text " for " <> ppr ty) + return ty + | otherwise = do + traceTR (text "(Upgrade) upgraded " <> ppr ty <> + text " in presence of newtype evidence " <> ppr new_tycon) + (_, vars) <- instTyVars (tyConTyVars new_tycon) + let ty' = mkTyConApp new_tycon (mkTyVarTys vars) + rep_ty = unwrapType ty' + _ <- liftTcM (unifyType Nothing ty rep_ty) + -- assumes that reptype doesn't ^^^^ touch tyconApp args + return ty' + + +zonkTerm :: Term -> TcM Term +zonkTerm = foldTermM (TermFoldM + { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> + return (Term ty' dc v tt) + , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b) + , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> + return$ NewtypeWrap ty' dc t + , fRefWrapM = \ty t -> return RefWrap `ap` + zonkRttiType ty `ap` return t + , fPrimM = (return.) . Prim }) + +zonkRttiType :: TcType -> TcM Type +-- Zonk the type, replacing any unbound Meta tyvars +-- by RuntimeUnk skolems, safely out of Meta-tyvar-land +zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi + ; zonkTcTypeToTypeX ze ty } + +-------------------------------------------------------------------------------- +-- Restore Class predicates out of a representation type +dictsView :: Type -> Type +dictsView ty = ty + + +-- Use only for RTTI types +isMonomorphic :: RttiType -> Bool +isMonomorphic ty = noExistentials && noUniversals + where (tvs, _, ty') = tcSplitSigmaTy ty + noExistentials = noFreeVarsOfType ty' + noUniversals = null tvs + +-- Use only for RTTI types +isMonomorphicOnNonPhantomArgs :: RttiType -> Bool +isMonomorphicOnNonPhantomArgs ty + | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty) + , phantom_vars <- tyConPhantomTyVars tc + , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args + , tyv `notElem` phantom_vars] + = all isMonomorphicOnNonPhantomArgs concrete_args + | Just (ty1, ty2) <- splitFunTy_maybe ty + = all isMonomorphicOnNonPhantomArgs [ty1,ty2] + | otherwise = isMonomorphic ty + +tyConPhantomTyVars :: TyCon -> [TyVar] +tyConPhantomTyVars tc + | isAlgTyCon tc + , Just dcs <- tyConDataCons_maybe tc + , dc_vars <- concatMap dataConUnivTyVars dcs + = tyConTyVars tc \\ dc_vars +tyConPhantomTyVars _ = [] + +type QuantifiedType = ([TyVar], Type) + -- Make the free type variables explicit + -- The returned Type should have no top-level foralls (I believe) + +quantifyType :: Type -> QuantifiedType +-- Generalize the type: find all free and forall'd tyvars +-- and return them, together with the type inside, which +-- should not be a forall type. +-- +-- Thus (quantifyType (forall a. a->[b])) +-- returns ([a,b], a -> [b]) + +quantifyType ty = ( filter isTyVar $ + tyCoVarsOfTypeWellScoped rho + , rho) + where + (_tvs, rho) = tcSplitForAllTys ty diff --git a/compiler/GHC/Runtime/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 8f245479c1..b7899ecc1b 100644 --- a/compiler/GHC/Runtime/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -5,7 +5,7 @@ {-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} -module GHC.Runtime.Layout ( +module GHC.Runtime.Heap.Layout ( -- * Words and bytes WordOff, ByteOff, wordsToBytes, bytesToWordsRoundUp, diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs new file mode 100644 index 0000000000..9eadacca1c --- /dev/null +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -0,0 +1,667 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} + +-- +-- | Interacting with the interpreter, whether it is running on an +-- external process or in the current process. +-- +module GHC.Runtime.Interpreter + ( -- * High-level interface to the interpreter + evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) + , resumeStmt + , abandonStmt + , evalIO + , evalString + , evalStringToIOString + , mallocData + , createBCOs + , addSptEntry + , mkCostCentres + , costCentreStackInfo + , newBreakArray + , enableBreakpoint + , breakpointStatus + , getBreakpointVar + , getClosure + , seqHValue + + -- * The object-code linker + , initObjLinker + , lookupSymbol + , lookupClosure + , loadDLL + , loadArchive + , loadObj + , unloadObj + , addLibrarySearchPath + , removeLibrarySearchPath + , resolveObjs + , findSystemLibrary + + -- * Lower-level API using messages + , iservCmd, Message(..), withIServ, stopIServ + , iservCall, readIServ, writeIServ + , purgeLookupSymbolCache + , freeHValueRefs + , mkFinalizedHValue + , wormhole, wormholeRef + , mkEvalOpts + , fromEvalResult + ) where + +import GhcPrelude + +import GHCi.Message +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.Run +#endif +import GHCi.RemoteTypes +import GHCi.ResolvedBCO +import GHCi.BreakArray (BreakArray) +import Fingerprint +import HscTypes +import UniqFM +import Panic +import DynFlags +import ErrUtils +import Outputable +import Exception +import BasicTypes +import FastString +import Util +import Hooks + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Binary +import Data.Binary.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.IORef +import Foreign hiding (void) +import GHC.Exts.Heap +import GHC.Stack.CCS (CostCentre,CostCentreStack) +import System.Exit +import Data.Maybe +import GHC.IO.Handle.Types (Handle) +#if defined(mingw32_HOST_OS) +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +#else +import System.Posix as Posix +#endif +import System.Directory +import System.Process +import GHC.Conc (getNumProcessors, pseq, par) + +{- Note [Remote GHCi] + +When the flag -fexternal-interpreter is given to GHC, interpreted code +is run in a separate process called iserv, and we communicate with the +external process over a pipe using Binary-encoded messages. + +Motivation +~~~~~~~~~~ + +When the interpreted code is running in a separate process, it can +use a different "way", e.g. profiled or dynamic. This means + +- compiling Template Haskell code with -prof does not require + building the code without -prof first + +- when GHC itself is profiled, it can interpret unprofiled code, + and the same applies to dynamic linking. + +- An unprofiled GHCi can load and run profiled code, which means it + can use the stack-trace functionality provided by profiling without + taking the performance hit on the compiler that profiling would + entail. + +For other reasons see remote-GHCi on the wiki. + +Implementation Overview +~~~~~~~~~~~~~~~~~~~~~~~ + +The main pieces are: + +- libraries/ghci, containing: + - types for talking about remote values (GHCi.RemoteTypes) + - the message protocol (GHCi.Message), + - implementation of the messages (GHCi.Run) + - implementation of Template Haskell (GHCi.TH) + - a few other things needed to run interpreted code + +- top-level iserv directory, containing the codefor the external + server. This is a fairly simple wrapper, most of the functionality + is provided by modules in libraries/ghci. + +- This module which provides the interface to the server used + by the rest of GHC. + +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, +interpreted code is run in the same process as GHC. + +Things that do not work with -fexternal-interpreter +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +dynCompileExpr cannot work, because we have no way to run code of an +unknown type in the remote process. This API fails with an error +message if it is used with -fexternal-interpreter. + +Other Notes on Remote GHCi +~~~~~~~~~~~~~~~~~~~~~~~~~~ + * This wiki page has an implementation overview: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter + * Note [External GHCi pointers] in compiler/ghci/GHCi.hs + * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs +-} + +#if !defined(HAVE_INTERNAL_INTERPRETER) +needExtInt :: IO a +needExtInt = throwIO + (InstallationError "this operation requires -fexternal-interpreter") +#endif + +-- | Run a command in the interpreter's context. With +-- @-fexternal-interpreter@, the command is serialized and sent to an +-- external iserv process, and the response is deserialized (hence the +-- @Binary@ constraint). With @-fno-external-interpreter@ we execute +-- the command directly here. +iservCmd :: Binary a => HscEnv -> Message a -> IO a +iservCmd hsc_env@HscEnv{..} msg + | gopt Opt_ExternalInterpreter hsc_dflags = + withIServ hsc_env $ \iserv -> + uninterruptibleMask_ $ do -- Note [uninterruptibleMask_] + iservCall iserv msg + | otherwise = -- Just run it directly +#if defined(HAVE_INTERNAL_INTERPRETER) + run msg +#else + needExtInt +#endif + +-- Note [uninterruptibleMask_ and iservCmd] +-- +-- If we receive an async exception, such as ^C, while communicating +-- with the iserv process then we will be out-of-sync and not be able +-- to recoever. Thus we use uninterruptibleMask_ during +-- communication. A ^C will be delivered to the iserv process (because +-- signals get sent to the whole process group) which will interrupt +-- the running computation and return an EvalException result. + +-- | Grab a lock on the 'IServ' and do something with it. +-- Overloaded because this is used from TcM as well as IO. +withIServ + :: (MonadIO m, ExceptionMonad m) + => HscEnv -> (IServ -> m a) -> m a +withIServ HscEnv{..} action = + gmask $ \restore -> do + m <- liftIO $ takeMVar hsc_iserv + -- start the iserv process if we haven't done so yet + iserv <- maybe (liftIO $ startIServ hsc_dflags) return m + `gonException` (liftIO $ putMVar hsc_iserv Nothing) + -- free any ForeignHValues that have been garbage collected. + let iserv' = iserv{ iservPendingFrees = [] } + a <- (do + liftIO $ when (not (null (iservPendingFrees iserv))) $ + iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) + -- run the inner action + restore $ action iserv) + `gonException` (liftIO $ putMVar hsc_iserv (Just iserv')) + liftIO $ putMVar hsc_iserv (Just iserv') + return a + + +-- ----------------------------------------------------------------------------- +-- Wrappers around messages + +-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for +-- each of the results. +evalStmt + :: HscEnv -> Bool -> EvalExpr ForeignHValue + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +evalStmt hsc_env step foreign_expr = do + let dflags = hsc_dflags hsc_env + status <- withExpr foreign_expr $ \expr -> + iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr) + handleEvalStatus hsc_env status + where + withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a + withExpr (EvalThis fhv) cont = + withForeignRef fhv $ \hvref -> cont (EvalThis hvref) + withExpr (EvalApp fl fr) cont = + withExpr fl $ \fl' -> + withExpr fr $ \fr' -> + cont (EvalApp fl' fr') + +resumeStmt + :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +resumeStmt hsc_env step resume_ctxt = do + let dflags = hsc_dflags hsc_env + status <- withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv) + handleEvalStatus hsc_env status + +abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO () +abandonStmt hsc_env resume_ctxt = do + withForeignRef resume_ctxt $ \rhv -> + iservCmd hsc_env (AbandonStmt rhv) + +handleEvalStatus + :: HscEnv -> EvalStatus [HValueRef] + -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) +handleEvalStatus hsc_env status = + case status of + EvalBreak a b c d e f -> return (EvalBreak a b c d e f) + EvalComplete alloc res -> + EvalComplete alloc <$> addFinalizer res + where + addFinalizer (EvalException e) = return (EvalException e) + addFinalizer (EvalSuccess rs) = do + EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs + +-- | Execute an action of type @IO ()@ +evalIO :: HscEnv -> ForeignHValue -> IO () +evalIO hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult + +-- | Execute an action of type @IO String@ +evalString :: HscEnv -> ForeignHValue -> IO String +evalString hsc_env fhv = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalString fhv) >>= fromEvalResult + +-- | Execute an action of type @String -> IO String@ +evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String +evalStringToIOString hsc_env fhv str = do + liftIO $ withForeignRef fhv $ \fhv -> + iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult + + +-- | Allocate and store the given bytes in memory, returning a pointer +-- to the memory in the remote process. +mallocData :: HscEnv -> ByteString -> IO (RemotePtr ()) +mallocData hsc_env bs = iservCmd hsc_env (MallocData bs) + +mkCostCentres + :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres hsc_env mod ccs = + iservCmd hsc_env (MkCostCentres mod ccs) + +-- | Create a set of BCOs that may be mutually recursive. +createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef] +createBCOs hsc_env rbcos = do + n_jobs <- case parMakeCount (hsc_dflags hsc_env) of + Nothing -> liftIO getNumProcessors + Just n -> return n + -- Serializing ResolvedBCO is expensive, so if we're in parallel mode + -- (-j<n>) parallelise the serialization. + if (n_jobs == 1) + then + iservCmd hsc_env (CreateBCOs [runPut (put rbcos)]) + + else do + old_caps <- getNumCapabilities + if old_caps == n_jobs + then void $ evaluate puts + else bracket_ (setNumCapabilities n_jobs) + (setNumCapabilities old_caps) + (void $ evaluate puts) + iservCmd hsc_env (CreateBCOs puts) + where + puts = parMap doChunk (chunkList 100 rbcos) + + -- make sure we force the whole lazy ByteString + doChunk c = pseq (LB.length bs) bs + where bs = runPut (put c) + + -- We don't have the parallel package, so roll our own simple parMap + parMap _ [] = [] + parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) + where fx = f x; fxs = parMap f xs + +addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO () +addSptEntry hsc_env fpr ref = + withForeignRef ref $ \val -> + iservCmd hsc_env (AddSptEntry fpr val) + +costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] +costCentreStackInfo hsc_env ccs = + iservCmd hsc_env (CostCentreStackInfo ccs) + +newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray) +newBreakArray hsc_env size = do + breakArray <- iservCmd hsc_env (NewBreakArray size) + mkFinalizedHValue hsc_env breakArray + +enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO () +enableBreakpoint hsc_env ref ix b = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (EnableBreakpoint breakarray ix b) + +breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool +breakpointStatus hsc_env ref ix = do + withForeignRef ref $ \breakarray -> + iservCmd hsc_env (BreakpointStatus breakarray ix) + +getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue) +getBreakpointVar hsc_env ref ix = + withForeignRef ref $ \apStack -> do + mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) + mapM (mkFinalizedHValue hsc_env) mb + +getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue) +getClosure hsc_env ref = + withForeignRef ref $ \hval -> do + mb <- iservCmd hsc_env (GetClosure hval) + mapM (mkFinalizedHValue hsc_env) mb + +seqHValue :: HscEnv -> ForeignHValue -> IO () +seqHValue hsc_env ref = + withForeignRef ref $ \hval -> + iservCmd hsc_env (Seq hval) >>= fromEvalResult + +-- ----------------------------------------------------------------------------- +-- Interface to the object-code linker + +initObjLinker :: HscEnv -> IO () +initObjLinker hsc_env = iservCmd hsc_env InitLinker + +lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ())) +lookupSymbol hsc_env@HscEnv{..} str + | gopt Opt_ExternalInterpreter hsc_dflags = + -- Profiling of GHCi showed a lot of time and allocation spent + -- making cross-process LookupSymbol calls, so I added a GHC-side + -- cache which sped things up quite a lot. We have to be careful + -- to purge this cache when unloading code though. + withIServ hsc_env $ \iserv@IServ{..} -> do + cache <- readIORef iservLookupSymbolCache + case lookupUFM cache str of + Just p -> return (Just p) + Nothing -> do + m <- uninterruptibleMask_ $ + iservCall iserv (LookupSymbol (unpackFS str)) + case m of + Nothing -> return Nothing + Just r -> do + let p = fromRemotePtr r + writeIORef iservLookupSymbolCache $! addToUFM cache str p + return (Just p) + | otherwise = +#if defined(HAVE_INTERNAL_INTERPRETER) + fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) +#else + needExtInt +#endif + +lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef) +lookupClosure hsc_env str = + iservCmd hsc_env (LookupClosure str) + +purgeLookupSymbolCache :: HscEnv -> IO () +purgeLookupSymbolCache hsc_env@HscEnv{..} = + when (gopt Opt_ExternalInterpreter hsc_dflags) $ + withIServ hsc_env $ \IServ{..} -> + writeIORef iservLookupSymbolCache emptyUFM + + +-- | loadDLL loads a dynamic library using the OS's native linker +-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either +-- an absolute pathname to the file, or a relative filename +-- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL +-- searches the standard locations for the appropriate library. +-- +-- Returns: +-- +-- Nothing => success +-- Just err_msg => failure +loadDLL :: HscEnv -> String -> IO (Maybe String) +loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str) + +loadArchive :: HscEnv -> String -> IO () +loadArchive hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadArchive path') + +loadObj :: HscEnv -> String -> IO () +loadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (LoadObj path') + +unloadObj :: HscEnv -> String -> IO () +unloadObj hsc_env path = do + path' <- canonicalizePath path -- Note [loadObj and relative paths] + iservCmd hsc_env (UnloadObj path') + +-- Note [loadObj and relative paths] +-- the iserv process might have a different current directory from the +-- GHC process, so we must make paths absolute before sending them +-- over. + +addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ()) +addLibrarySearchPath hsc_env str = + fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str) + +removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool +removeLibrarySearchPath hsc_env p = + iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p)) + +resolveObjs :: HscEnv -> IO SuccessFlag +resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs + +findSystemLibrary :: HscEnv -> String -> IO (Maybe String) +findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str) + + +-- ----------------------------------------------------------------------------- +-- Raw calls and messages + +-- | Send a 'Message' and receive the response from the iserv process +iservCall :: Binary a => IServ -> Message a -> IO a +iservCall iserv@IServ{..} msg = + remoteCall iservPipe msg + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Read a value from the iserv process +readIServ :: IServ -> Get a -> IO a +readIServ iserv@IServ{..} get = + readPipe iservPipe get + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +-- | Send a value to the iserv process +writeIServ :: IServ -> Put -> IO () +writeIServ iserv@IServ{..} put = + writePipe iservPipe put + `catch` \(e :: SomeException) -> handleIServFailure iserv e + +handleIServFailure :: IServ -> SomeException -> IO a +handleIServFailure IServ{..} e = do + ex <- getProcessExitCode iservProcess + case ex of + Just (ExitFailure n) -> + throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess iservProcess + _ <- waitForProcess iservProcess + throw e + +-- ----------------------------------------------------------------------------- +-- Starting and stopping the iserv process + +startIServ :: DynFlags -> IO IServ +startIServ dflags = do + let flavour + | WayProf `elem` ways dflags = "-prof" + | WayDyn `elem` ways dflags = "-dyn" + | otherwise = "" + prog = pgm_i dflags ++ flavour + opts = getOpts dflags opt_i + debugTraceMsg dflags 3 $ text "Starting " <> text prog + let createProc = lookupHook createIservProcessHook + (\cp -> do { (_,_,_,ph) <- createProcess cp + ; return ph }) + dflags + (ph, rh, wh) <- runWithPipes createProc prog opts + lo_ref <- newIORef Nothing + cache_ref <- newIORef emptyUFM + return $ IServ + { iservPipe = Pipe { pipeRead = rh + , pipeWrite = wh + , pipeLeftovers = lo_ref } + , iservProcess = ph + , iservLookupSymbolCache = cache_ref + , iservPendingFrees = [] + } + +stopIServ :: HscEnv -> IO () +stopIServ HscEnv{..} = + gmask $ \_restore -> do + m <- takeMVar hsc_iserv + maybe (return ()) stop m + putMVar hsc_iserv Nothing + where + stop iserv = do + ex <- getProcessExitCode (iservProcess iserv) + if isJust ex + then return () + else iservCall iserv Shutdown + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) +#if defined(mingw32_HOST_OS) +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt + +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO CInt + +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- createPipeFd -- we read on rfd1 + (rfd2, wfd2) <- createPipeFd -- we write on wfd2 + wh_client <- _get_osfhandle wfd1 + rh_client <- _get_osfhandle rfd2 + let args = show wh_client : show rh_client : opts + ph <- createProc (proc prog args) + rh <- mkHandle rfd1 + wh <- mkHandle wfd2 + return (ph, rh, wh) + where mkHandle :: CInt -> IO Handle + mkHandle fd = (fdToHandle fd) `onException` (c__close fd) + +#else +runWithPipes createProc prog opts = do + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = show wfd1 : show rfd2 : opts + ph <- createProc (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + return (ph, rh, wh) +#endif + +-- ----------------------------------------------------------------------------- +{- Note [External GHCi pointers] + +We have the following ways to reference things in GHCi: + +HValue +------ + +HValue is a direct reference to a value in the local heap. Obviously +we cannot use this to refer to things in the external process. + + +RemoteRef +--------- + +RemoteRef is a StablePtr to a heap-resident value. When +-fexternal-interpreter is used, this value resides in the external +process's heap. RemoteRefs are mostly used to send pointers in +messages between GHC and iserv. + +A RemoteRef must be explicitly freed when no longer required, using +freeHValueRefs, or by attaching a finalizer with mkForeignHValue. + +To get from a RemoteRef to an HValue you can use 'wormholeRef', which +fails with an error message if -fexternal-interpreter is in use. + +ForeignRef +---------- + +A ForeignRef is a RemoteRef with a finalizer that will free the +'RemoteRef' when it is garbage collected. We mostly use ForeignHValue +on the GHC side. + +The finalizer adds the RemoteRef to the iservPendingFrees list in the +IServ record. The next call to iservCmd will free any RemoteRefs in +the list. It was done this way rather than calling iservCmd directly, +because I didn't want to have arbitrary threads calling iservCmd. In +principle it would probably be ok, but it seems less hairy this way. +-} + +-- | Creates a 'ForeignRef' that will automatically release the +-- 'RemoteRef' when it is no longer referenced. +mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a) +mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free + where + !external = gopt Opt_ExternalInterpreter hsc_dflags + hvref = toHValueRef rref + + free :: IO () + free + | not external = freeRemoteRef hvref + | otherwise = + modifyMVar_ hsc_iserv $ \mb_iserv -> + case mb_iserv of + Nothing -> return Nothing -- already shut down + Just iserv@IServ{..} -> + return (Just iserv{iservPendingFrees = hvref : iservPendingFrees}) + +freeHValueRefs :: HscEnv -> [HValueRef] -> IO () +freeHValueRefs _ [] = return () +freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs) + +-- | Convert a 'ForeignRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormhole :: DynFlags -> ForeignRef a -> IO a +wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r) + +-- | Convert an 'RemoteRef' to the value it references directly. This +-- only works when the interpreter is running in the same process as +-- the compiler, so it fails when @-fexternal-interpreter@ is on. +wormholeRef :: DynFlags -> RemoteRef a -> IO a +wormholeRef dflags _r + | gopt Opt_ExternalInterpreter dflags + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") +#if defined(HAVE_INTERNAL_INTERPRETER) + | otherwise + = localRef _r +#else + | otherwise + = throwIO (InstallationError + "can't wormhole a value in a stage1 compiler") +#endif + +-- ----------------------------------------------------------------------------- +-- Misc utils + +mkEvalOpts :: DynFlags -> Bool -> EvalOpts +mkEvalOpts dflags step = + EvalOpts + { useSandboxThread = gopt Opt_GhciSandbox dflags + , singleStep = step + , breakOnException = gopt Opt_BreakOnException dflags + , breakOnError = gopt Opt_BreakOnError dflags } + +fromEvalResult :: EvalResult a -> IO a +fromEvalResult (EvalException e) = throwIO (fromSerializableException e) +fromEvalResult (EvalSuccess a) = return a diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs new file mode 100644 index 0000000000..fb409bd75b --- /dev/null +++ b/compiler/GHC/Runtime/Linker.hs @@ -0,0 +1,1716 @@ +{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- | 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. +module GHC.Runtime.Linker + ( getHValue + , showLinkerState + , linkExpr + , linkDecls + , unload + , withExtendedLinkEnv + , extendLinkEnv + , deleteFromLinkEnv + , extendLoadedPkgs + , linkPackages + , initDynLinker + , linkModule + , linkCmdLineLibs + , uninitializedLinker + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Runtime.Interpreter +import GHCi.RemoteTypes +import GHC.Iface.Load +import GHC.ByteCode.Linker +import GHC.ByteCode.Asm +import GHC.ByteCode.Types +import TcRnMonad +import Packages +import DriverPhases +import Finder +import HscTypes +import Name +import NameEnv +import Module +import ListSetOps +import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) +import DynFlags +import BasicTypes +import Outputable +import Panic +import Util +import ErrUtils +import SrcLoc +import qualified Maybes +import UniqDSet +import FastString +import GHC.Platform +import SysTools +import FileCleanup + +-- Standard libraries +import Control.Monad + +import Data.Char (isSpace) +import Data.IORef +import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +import Data.Maybe +import Control.Concurrent.MVar + +import System.FilePath +import System.Directory +import System.IO.Unsafe +import System.Environment (lookupEnv) + +#if defined(mingw32_HOST_OS) +import System.Win32.Info (getSystemDirectory) +#endif + +import Exception + +{- ********************************************************************** + + The Linker's state + + ********************************************************************* -} + +{- +The persistent linker state *must* match the actual state of the +C dynamic linker at all times. + +The MVar used to hold the PersistentLinkerState contains a Maybe +PersistentLinkerState. The MVar serves to ensure mutual exclusion between +multiple loaded copies of the GHC library. The Maybe may be Nothing to +indicate that the linker has not yet been initialised. + +The PersistentLinkerState maps Names to actual closures (for +interpreted code only), for use during linking. +-} + +uninitializedLinker :: IO DynLinker +uninitializedLinker = + newMVar Nothing >>= (pure . DynLinker) + +uninitialised :: a +uninitialised = panic "Dynamic linker not initialised" + +modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ dl f = + modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised) + +modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS dl f = + modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised) + where fmapFst f = fmap (\(x, y) -> (f x, y)) + +readPLS :: DynLinker -> IO PersistentLinkerState +readPLS dl = + (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl) + +modifyMbPLS_ + :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () +modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f + +emptyPLS :: DynFlags -> PersistentLinkerState +emptyPLS _ = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [], + temp_sos = [] } + + -- 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 = map toInstalledUnitId [rtsUnitId] + +extendLoadedPkgs :: DynLinker -> [InstalledUnitId] -> IO () +extendLoadedPkgs dl pkgs = + modifyPLS_ dl $ \s -> + return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } + +extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO () +extendLinkEnv dl new_bindings = + modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do + let new_ce = extendClosureEnv closure_env new_bindings + return $! pls{ closure_env = new_ce } + -- strictness is important for not retaining old copies of the pls + +deleteFromLinkEnv :: DynLinker -> [Name] -> IO () +deleteFromLinkEnv dl to_remove = + modifyPLS_ dl $ \pls -> do + let ce = closure_env pls + let new_ce = delListFromNameEnv ce to_remove + return pls{ closure_env = new_ce } + +-- | Get the 'HValue' associated with the given name. +-- +-- May cause loading the module that contains the name. +-- +-- Throws a 'ProgramError' if loading fails or the name cannot be found. +getHValue :: HscEnv -> Name -> IO ForeignHValue +getHValue hsc_env name = do + let dl = hsc_dynLinker hsc_env + initDynLinker hsc_env + pls <- modifyPLS dl $ \pls -> do + if (isExternalName name) then do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan + [nameModule name] + if (failed ok) then throwGhcExceptionIO (ProgramError "") + else return (pls', pls') + else + return (pls, pls) + case lookupNameEnv (closure_env pls) name of + Just (_,aa) -> return aa + Nothing + -> ASSERT2(isExternalName name, ppr name) + do let sym_to_find = nameToCLabel name "closure" + m <- lookupClosure hsc_env (unpackFS sym_to_find) + case m of + Just hvref -> mkFinalizedHValue hsc_env hvref + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" + (unpackFS sym_to_find) + +linkDependencies :: HscEnv -> PersistentLinkerState + -> SrcSpan -> [Module] + -> IO (PersistentLinkerState, SuccessFlag) +linkDependencies hsc_env pls span needed_mods = do +-- initDynLinker (hsc_dflags hsc_env) dl + let hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay dflags span + + -- Find what packages and linkables are required + (lnks, pkgs) <- getLinkDeps hsc_env hpt pls + maybe_normal_osuf span needed_mods + + -- Link the packages and modules required + pls1 <- linkPackages' hsc_env pkgs pls + linkModules hsc_env pls1 lnks + + +-- | Temporarily extend the linker state. + +withExtendedLinkEnv :: (ExceptionMonad m) => + DynLinker -> [(Name,ForeignHValue)] -> m a -> m a +withExtendedLinkEnv dl new_env action + = gbracket (liftIO $ extendLinkEnv dl new_env) + (\_ -> reset_old_env) + (\_ -> action) + where + -- Remember that the linker state might be side-effected + -- during the execution of the IO action, and we don't want to + -- lose those changes (we might have linked a new module or + -- package), so the reset action only removes the names we + -- added earlier. + reset_old_env = liftIO $ do + modifyPLS_ dl $ \pls -> + let cur = closure_env pls + new = delListFromNameEnv cur (map fst new_env) + in return pls{ closure_env = new } + + +-- | Display the persistent linker state. +showLinkerState :: DynLinker -> DynFlags -> IO () +showLinkerState dl dflags + = do pls <- readPLS dl + putLogMsg dflags NoReason SevDump noSrcSpan + (defaultDumpStyle dflags) + (vcat [text "----- Linker state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) + + +{- ********************************************************************** + + Initialisation + + ********************************************************************* -} + +-- | Initialise the dynamic linker. This entails +-- +-- a) Calling the C initialisation procedure, +-- +-- b) Loading any packages specified on the command line, +-- +-- 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 @ldInputs@, +-- +-- e) Loading any MacOS frameworks. +-- +-- NOTE: 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 :: HscEnv -> IO () +initDynLinker hsc_env = do + let dl = hsc_dynLinker hsc_env + modifyMbPLS_ dl $ \pls -> do + case pls of + Just _ -> return pls + Nothing -> Just <$> reallyInitDynLinker hsc_env + +reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState +reallyInitDynLinker hsc_env = do + -- Initialise the linker state + let dflags = hsc_dflags hsc_env + pls0 = emptyPLS dflags + + -- (a) initialise the C dynamic linker + initObjLinker hsc_env + + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- linkPackages' hsc_env (preloadPackages (pkgState dflags)) pls0 + + -- steps (c), (d) and (e) + linkCmdLineLibs' hsc_env pls + + +linkCmdLineLibs :: HscEnv -> IO () +linkCmdLineLibs hsc_env = do + let dl = hsc_dynLinker hsc_env + initDynLinker hsc_env + modifyPLS_ dl $ \pls -> do + linkCmdLineLibs' hsc_env pls + +linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState +linkCmdLineLibs' hsc_env pls = + do + let dflags@(DynFlags { ldInputs = cmdline_ld_inputs + , libraryPaths = lib_paths_base}) + = hsc_dflags hsc_env + + -- (c) Link libraries from the command-line + let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] + + -- On Windows we want to add libpthread by default just as GCC would. + -- However because we don't know the actual name of pthread's dll we + -- need to defer this to the locateLib call so we can't initialize it + -- inside of the rts. Instead we do it here to be able to find the + -- import library for pthreads. See #13210. + let platform = targetPlatform dflags + os = platformOS platform + minus_ls = case os of + OSMinGW32 -> "pthread" : minus_ls_1 + _ -> minus_ls_1 + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags os + + lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base + + maybePutStrLn dflags "Search directories (user):" + maybePutStr dflags (unlines $ map (" "++) lib_paths_env) + maybePutStrLn dflags "Search directories (gcc):" + maybePutStr dflags (unlines $ map (" "++) gcc_paths) + + libspecs + <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls + + -- (d) Link .o files from the command-line + classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] + + -- (e) Link any MacOS frameworks + let platform = targetPlatform dflags + let (framework_paths, frameworks) = + if platformUsesFrameworks platform + then (frameworkPaths dflags, cmdlineFrameworks dflags) + else ([],[]) + + -- Finally do (c),(d),(e) + let cmdline_lib_specs = catMaybes classified_ld_inputs + ++ libspecs + ++ map Framework frameworks + if null cmdline_lib_specs then return pls + else do + + -- Add directories to library search paths, this only has an effect + -- on Windows. On Unix OSes this function is a NOP. + let all_paths = let paths = takeDirectory (pgm_c dflags) + : framework_paths + ++ lib_paths_base + ++ [ takeDirectory dll | DLLPath dll <- libspecs ] + in nub $ map normalise paths + let lib_paths = nub $ lib_paths_base ++ gcc_paths + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + + let merged_specs = mergeStaticObjects cmdline_lib_specs + pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls + merged_specs + + maybePutStr dflags "final link ... " + ok <- resolveObjs hsc_env + + -- DLLs are loaded, reset the search paths + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache + + if succeeded ok then maybePutStrLn dflags "done" + else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") + + return pls1 + +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of +-- cyclic symbol references when dynamically linking. Specifically, we link +-- together all of the static objects into a single shared object, avoiding +-- the issue we saw in #13786. +mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec] +mergeStaticObjects specs = go [] specs + where + go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec] + go accum (Objects objs : rest) = go (objs ++ accum) rest + go accum@(_:_) rest = Objects (reverse accum) : go [] rest + go [] (spec:rest) = spec : go [] rest + go [] [] = [] + +{- Note [preload packages] + +Why do we need to preload packages from the command line? This is an +explanation copied from #2437: + +I tried to implement the suggestion from #3560, thinking it would be +easy, but there are two reasons we link in packages eagerly when they +are mentioned on the command line: + + * So that you can link in extra object files or libraries that + depend on the packages. e.g. ghc -package foo -lbar where bar is a + C library that depends on something in foo. So we could link in + foo eagerly if and only if there are extra C libs or objects to + link in, but.... + + * Haskell code can depend on a C function exported by a package, and + the normal dependency tracking that TH uses can't know about these + dependencies. The test ghcilink004 relies on this, for example. + +I conclude that we need two -package flags: one that says "this is a +package I want to make available", and one that says "this is a +package I want to link in eagerly". Would that be too complicated for +users? +-} + +classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput dflags f + | isObjectFilename platform f = return (Just (Objects [f])) + | isDynLibFilename platform f = return (Just (DLLPath f)) + | otherwise = do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) + return Nothing + where platform = targetPlatform dflags + +preloadLib + :: HscEnv -> [String] -> [String] -> PersistentLinkerState + -> LibrarySpec -> IO PersistentLinkerState +preloadLib hsc_env lib_paths framework_paths pls lib_spec = do + maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Objects static_ishs -> do + (b, pls1) <- preload_statics lib_paths static_ishs + maybePutStrLn dflags (if b then "done" else "not found") + return pls1 + + Archive static_ish -> do + b <- preload_static_archive lib_paths static_ish + maybePutStrLn dflags (if b then "done" else "not found") + return pls + + DLL dll_unadorned -> do + maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm | platformOS platform /= OSDarwin -> + preloadFailed mm lib_paths lib_spec + Just mm | otherwise -> do + -- As a backup, on Darwin, try to also load a .so file + -- since (apparently) some things install that way - see + -- ticket #8770. + let libfile = ("lib" ++ dll_unadorned) <.> "so" + err2 <- loadDLL hsc_env libfile + case err2 of + Nothing -> maybePutStrLn dflags "done" + Just _ -> preloadFailed mm lib_paths lib_spec + return pls + + DLLPath dll_path -> do + do maybe_errstr <- loadDLL hsc_env dll_path + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm lib_paths lib_spec + return pls + + Framework framework -> + if platformUsesFrameworks (targetPlatform dflags) + then do maybe_errstr <- loadFramework hsc_env framework_paths framework + case maybe_errstr of + Nothing -> maybePutStrLn dflags "done" + Just mm -> preloadFailed mm framework_paths lib_spec + return pls + else panic "preloadLib Framework" + + where + dflags = hsc_dflags hsc_env + + platform = targetPlatform dflags + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr dflags "failed.\n" + throwGhcExceptionIO $ + CmdLineError ( + "user specified .o/.so/.DLL could not be loaded (" + ++ sys_errmsg ++ ")\nWhilst trying to load: " + ++ showLS spec ++ "\nAdditional directories searched:" + ++ (if null paths then " (none)" else + intercalate "\n" (map (" "++) paths))) + + -- Not interested in the paths in the static case. + preload_statics _paths names + = do b <- or <$> mapM doesFileExist names + if not b then return (False, pls) + else if dynamicGhc + then do pls1 <- dynLoadObjs hsc_env pls names + return (True, pls1) + else do mapM_ (loadObj hsc_env) names + return (True, pls) + + preload_static_archive _paths name + = do b <- doesFileExist name + if not b then return False + else do if dynamicGhc + then throwGhcExceptionIO $ + CmdLineError dynamic_msg + else loadArchive hsc_env name + return True + where + dynamic_msg = unlines + [ "User-specified static library could not be loaded (" + ++ name ++ ")" + , "Loading static libraries is not supported in this configuration." + , "Try using a dynamic library instead." + ] + + +{- ********************************************************************** + + Link a byte-code expression + + ********************************************************************* -} + +-- | Link a single expression, /including/ first linking packages and +-- modules that this expression depends on. +-- +-- Raises an IO exception ('ProgramError') if it can't find a compiled +-- version of the dependents to link. +-- +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue +linkExpr hsc_env span root_ul_bco + = do { + -- Initialise the linker (if it's not been done already) + ; initDynLinker hsc_env + + -- Extract the DynLinker value for passing into required places + ; let dl = hsc_dynLinker hsc_env + + -- Take lock for the actual work. + ; modifyPLS dl $ \pls0 -> do { + + -- Link the packages and modules required + ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + ; if failed ok then + throwGhcExceptionIO (ProgramError "") + else do { + + -- Link the expression itself + let ie = itbl_env pls + ce = closure_env pls + + -- Link the necessary packages and linkables + + ; let nobreakarray = error "no break array" + bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] + ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco + ; [root_hvref] <- createBCOs hsc_env [resolved] + ; fhv <- mkFinalizedHValue hsc_env root_hvref + ; return (pls, fhv) + }}} + where + free_names = uniqDSetToList (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 :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) + + +checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +checkNonStdWay dflags srcspan + | gopt Opt_ExternalInterpreter dflags = return Nothing + -- with -fexternal-interpreter we load the .o files, whatever way + -- they were built. If they were built for a non-std way, then + -- we will use the appropriate variant of the iserv binary to load them. + + | interpWays == haskellWays = return Nothing + -- Only if we are compiling with the same ways as GHC is built + -- with, can we dynamically load those object files. (see #3604) + + | objectSuf dflags == normalObjectSuffix && not (null haskellWays) + = failNonStd dflags srcspan + + | otherwise = return (Just (interpTag ++ "o")) + where + haskellWays = filter (not . wayRTSOnly) (ways dflags) + interpTag = case mkBuildTag interpWays of + "" -> "" + tag -> tag ++ "_" + +normalObjectSuffix :: String +normalObjectSuffix = phaseInputExt StopLn + +failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) +failNonStd dflags srcspan = dieWith dflags srcspan $ + text "Cannot load" <+> compWay <+> + text "objects when GHC is built" <+> ghciWay $$ + text "To fix this, either:" $$ + text " (1) Use -fexternal-interpreter, or" $$ + text " (2) Build the program twice: once" <+> + ghciWay <> text ", and then" $$ + text " with" <+> compWay <+> + text "using -osuf to set a different object file suffix." + where compWay + | WayDyn `elem` ways dflags = text "-dynamic" + | WayProf `elem` ways dflags = text "-prof" + | otherwise = text "normal" + ghciWay + | dynamicGhc = text "with -dynamic" + | rtsIsProfiled = text "with -prof" + | otherwise = text "the normal way" + +getLinkDeps :: HscEnv -> HomePackageTable + -> PersistentLinkerState + -> Maybe FilePath -- replace object suffices? + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO ([Linkable], [InstalledUnitId]) -- ... then link these first +-- Fails with an IO exception if it can't find enough files + +getLinkDeps hsc_env hpt pls replace_osuf span mods +-- Find all the packages and linkables that a set of modules depends on + = do { + -- 1. Find the dependent home-pkg-modules/packages from each iface + -- (omitting modules from the interactive package, which is already linked) + ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods) + emptyUniqDSet emptyUniqDSet; + + ; let { + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + mods_needed = mods_s `minusList` linked_mods ; + pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ; + + linked_mods = map (moduleName.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 + ; let { osuf = objectSuf dflags } + ; lnks_needed <- mapM (get_linkable osuf) mods_needed + + ; return (lnks_needed, pkgs_needed) } + where + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + -- The ModIface contains the transitive closure of the module dependencies + -- within the current package, *except* for boot modules: if we encounter + -- a boot module, we have to find its real interface and discover the + -- dependencies of that. Hence we need to traverse the dependency + -- tree recursively. See bug #936, testcase ghci/prog007. + follow_deps :: [Module] -- modules to follow + -> UniqDSet ModuleName -- accum. module dependencies + -> UniqDSet InstalledUnitId -- accum. package dependencies + -> IO ([ModuleName], [InstalledUnitId]) -- result + follow_deps [] acc_mods acc_pkgs + = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs) + follow_deps (mod:mods) acc_mods acc_pkgs + = do + mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $ + loadInterface msg mod (ImportByUser False) + iface <- case mb_iface of + Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Maybes.Succeeded iface -> return iface + + when (mi_boot iface) $ link_boot_mod_error mod + + let + pkg = moduleUnitId mod + deps = mi_deps iface + + pkg_deps = dep_pkgs deps + (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps) + where is_boot (m,True) = Left m + is_boot (m,False) = Right m + + boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps + acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps) + acc_pkgs' = addListToUniqDSet acc_pkgs $ map fst pkg_deps + -- + if pkg /= this_pkg + then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toInstalledUnitId pkg)) + else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) + acc_mods' acc_pkgs' + where + msg = text "need to link module" <+> ppr mod <+> + text "due to use of Template Haskell" + + + link_boot_mod_error mod = + throwGhcExceptionIO (ProgramError (showSDoc dflags ( + text "module" <+> ppr mod <+> + text "cannot be linked; it is only available as a boot module"))) + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith dflags span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + -- This one is a build-system bug + + get_linkable osuf mod_name -- A home-package module + | Just mod_info <- lookupHpt hpt mod_name + = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info)) + | otherwise + = do -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod + _ -> no_obj mod_name + where + found loc mod = do { + -- ...and then find the linkable for it + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk + }} + + adjust_linkable lnk + | Just new_osuf <- replace_osuf = do + new_uls <- mapM (adjust_ul new_osuf) + (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul new_osuf (DotO file) = do + MASSERT(osuf `isSuffixOf` file) + let file_base = fromJust (stripExtension osuf file) + new_file = file_base <.> new_osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith dflags span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) + adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp) + adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp) + adjust_ul _ l@(BCOs {}) = return l + + + +{- ********************************************************************** + + Loading a Decls statement + + ********************************************************************* -} + +linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () +linkDecls hsc_env span cbc@CompiledByteCode{..} = do + -- Initialise the linker (if it's not been done already) + initDynLinker hsc_env + + -- Extract the DynLinker for passing into required places + let dl = hsc_dynLinker hsc_env + + -- Take lock for the actual work. + modifyPLS dl $ \pls0 -> do + + -- Link the packages and modules required + (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + if failed ok + then throwGhcExceptionIO (ProgramError "") + else do + + -- Link the expression itself + let ie = plusNameEnv (itbl_env pls) bc_itbls + ce = closure_env pls + + -- Link the necessary packages and linkables + new_bindings <- linkSomeBCOs hsc_env ie ce [cbc] + nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings + let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs + , itbl_env = ie } + return (pls2, ()) + where + free_names = uniqDSetToList $ + foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos + + 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. + +{- ********************************************************************** + + Loading a single module + + ********************************************************************* -} + +linkModule :: HscEnv -> Module -> IO () +linkModule hsc_env mod = do + initDynLinker hsc_env + let dl = hsc_dynLinker hsc_env + modifyPLS_ dl $ \pls -> do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] + if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module") + else return pls' + +{- ********************************************************************** + + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules + + ********************************************************************* -} + +linkModules :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +linkModules hsc_env pls linkables + = mask_ $ do -- don't want to be interrupted by ^C in here + + let (objs, bcos) = partition isObjectLinkable + (concatMap partitionLinkable linkables) + + -- Load objects first; they can't depend on BCOs + (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs + + if failed ok_flag then + return (pls1, Failed) + else do + pls2 <- dynLinkBCOs hsc_env pls1 bcos + return (pls2, 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 + (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj}, + li {linkableUnlinked=li_uls_bco}] + _ -> [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 + _ -> 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 + + +{- ********************************************************************** + + The object-code linker + + ********************************************************************* -} + +dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO (PersistentLinkerState, SuccessFlag) +dynLinkObjs hsc_env pls objs = do + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + wanted_objs = map nameOfObject unlinkeds + + if interpreterDynamic (hsc_dflags hsc_env) + then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs + return (pls2, Succeeded) + else do mapM_ (loadObj hsc_env) wanted_objs + + -- Link them all together + ok <- resolveObjs hsc_env + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + return (pls1, Succeeded) + else do + pls2 <- unload_wkr hsc_env [] pls1 + return (pls2, Failed) + + +dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] + -> IO PersistentLinkerState +dynLoadObjs _ pls [] = return pls +dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do + let dflags = hsc_dflags hsc_env + let platform = targetPlatform dflags + let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] + let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] + (soFile, libPath , libName) <- + newTempLibName dflags TFL_CurrentModule (soExt platform) + let + dflags2 = dflags { + -- We don't want the original ldInputs in + -- (they're already linked in), but we do want + -- to link against previous dynLoadObjs + -- libraries if there were any, so that the linker + -- can resolve dependencies when it loads this + -- library. + ldInputs = + concatMap (\l -> [ Option ("-l" ++ l) ]) + (nub $ snd <$> temp_sos) + ++ concatMap (\lp -> [ Option ("-L" ++ lp) + , Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp ]) + (nub $ fst <$> temp_sos) + ++ concatMap + (\lp -> + [ Option ("-L" ++ lp) + , Option "-Xlinker" + , Option "-rpath" + , Option "-Xlinker" + , Option lp + ]) + minus_big_ls + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + ++ map (\l -> Option ("-l" ++ l)) minus_ls, + -- Add -l options and -L options from dflags. + -- + -- When running TH for a non-dynamic way, we still + -- need to make -l flags to link against the dynamic + -- libraries, so we need to add WayDyn to ways. + -- + -- Even if we're e.g. profiling, we still want + -- the vanilla dynamic libraries, so we set the + -- ways / build tag to be just WayDyn. + ways = [WayDyn], + buildTag = mkBuildTag [WayDyn], + outputFile = Just soFile + } + -- link all "loaded packages" so symbols in those can be resolved + -- Note: We are loading packages with local scope, so to see the + -- symbols in this link we must link all loaded packages again. + linkDynLib dflags2 objs pkgs_loaded + + -- if we got this far, extend the lifetime of the library file + changeTempFilesLifetime dflags TFL_GhcSession [soFile] + m <- loadDLL hsc_env soFile + case m of + Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Just err -> panic ("Loading temp shared object failed: " ++ err) + +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 + +{- ********************************************************************** + + The byte-code linker + + ********************************************************************* -} + + +dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable] + -> IO PersistentLinkerState +dynLinkBCOs hsc_env pls bcos = do + + 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 + + + ies = map bc_itbls cbcs + gce = closure_env pls + final_ie = foldr plusNameEnv (itbl_env pls) ies + + names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs + + -- We only want to add the external ones to the ClosureEnv + let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs + + -- Immediately release any HValueRefs we're not going to add + freeHValueRefs hsc_env (map snd to_drop) + -- Wrap finalizers on the ones we want to keep + new_binds <- makeForeignNamedHValueRefs hsc_env to_add + + return pls1 { closure_env = extendClosureEnv gce new_binds, + itbl_env = final_ie } + +-- Link a bunch of BCOs and return references to their values +linkSomeBCOs :: HscEnv + -> ItblEnv + -> ClosureEnv + -> [CompiledByteCode] + -> IO [(Name,HValueRef)] + -- The returned HValueRefs are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + +linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods [] + where + fun CompiledByteCode{..} inner accum = + case bc_breaks of + Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) + Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> + inner ((breakarray, bc_bcos) : accum) + + do_link [] = return [] + do_link mods = do + let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] + names = map (unlinkedBCOName . snd) flat + bco_ix = mkNameEnv (zip names [0..]) + resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco + | (breakarray, bco) <- flat ] + hvrefs <- createBCOs hsc_env resolved + return (zip names hvrefs) + +-- | Useful to apply to the result of 'linkSomeBCOs' +makeForeignNamedHValueRefs + :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)] +makeForeignNamedHValueRefs hsc_env bindings = + mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings + +{- ********************************************************************** + + Unload some object modules + + ********************************************************************* -} + +-- --------------------------------------------------------------------------- +-- | 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 :: HscEnv + -> [Linkable] -- ^ The linkables to *keep*. + -> IO () +unload hsc_env linkables + = mask_ $ do -- mask, so we're safe from Ctrl-C in here + + -- Initialise the linker (if it's not been done already) + initDynLinker hsc_env + + -- Extract DynLinker for passing into required places + let dl = hsc_dynLinker hsc_env + + new_pls + <- modifyPLS dl $ \pls -> do + pls1 <- unload_wkr hsc_env linkables pls + return (pls1, pls1) + + let dflags = hsc_dflags hsc_env + debugTraceMsg dflags 3 $ + text "unload: retaining objs" <+> ppr (objs_loaded new_pls) + debugTraceMsg dflags 3 $ + text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) + return () + +unload_wkr :: HscEnv + -> [Linkable] -- stable linkables + -> PersistentLinkerState + -> IO PersistentLinkerState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the PLS get and put) + +unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..} = do + -- NB. careful strictness here to avoid keeping the old PLS when + -- we're unloading some code. -fghci-leak-check with the tests in + -- testsuite/ghci can detect space leaks here. + + let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables + + discard keep l = not (linkableInSet l keep) + + (objs_to_unload, remaining_objs_loaded) = + partition (discard objs_to_keep) objs_loaded + (bcos_to_unload, remaining_bcos_loaded) = + partition (discard bcos_to_keep) bcos_loaded + + mapM_ unloadObjs objs_to_unload + mapM_ unloadObjs bcos_to_unload + + -- If we unloaded any object files at all, we need to purge the cache + -- of lookupSymbol results. + when (not (null (objs_to_unload ++ + filter (not . null . linkableObjs) bcos_to_unload))) $ + purgeLookupSymbolCache hsc_env + + let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded + + -- Note that we want to remove all *local* + -- (i.e. non-isExternal) names too (these are the + -- temporary bindings from the command line). + keep_name (n,_) = isExternalName n && + nameModule n `elemModuleSet` bcos_retained + + itbl_env' = filterNameEnv keep_name itbl_env + closure_env' = filterNameEnv keep_name closure_env + + !new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } + + return new_pls + where + unloadObjs :: Linkable -> IO () + unloadObjs lnk + | dynamicGhc = return () + -- We don't do any cleanup when linking objects with the + -- dynamic linker. Doing so introduces extra complexity for + -- not much benefit. + + -- Code unloading currently disabled due to instability. + -- See #16841. + -- id False, so that the pattern-match checker doesn't complain + | id False -- otherwise + = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk] + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + | otherwise = return () -- see #16841 + +{- ********************************************************************** + + Loading packages + + ********************************************************************* -} + +data LibrarySpec + = Objects [FilePath] -- Full path names of set of .o files, including trailing .o + -- We allow batched loading to ensure that cyclic symbol + -- references can be resolved (see #13786). + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | Archive FilePath -- Full path name of a .a file, including trailing .a + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On Windows "burble" denotes "burble.DLL" or "libburble.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 + +instance Outputable LibrarySpec where + ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Archive a) = text "Archive" <+> text a + ppr (DLL s) = text "DLL" <+> text s + ppr (DLLPath f) = text "DLLPath" <+> text f + ppr (Framework s) = text "Framework" <+> text s + +-- 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 :: [PackageName] +partOfGHCi + | isWindowsHost || isDarwinHost = [] + | otherwise = map (PackageName . mkFastString) + ["base", "template-haskell", "editline"] + +showLS :: LibrarySpec -> String +showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" +showLS (Archive nm) = "(static archive) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +showLS (DLLPath nm) = "(dynamic) " ++ nm +showLS (Framework nm) = "(framework) " ++ nm + +-- | 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. +-- +linkPackages :: HscEnv -> [LinkerUnitId] -> IO () +-- NOTE: in fact, since each module tracks all the packages it depends on, +-- we don't really need to use the package-config dependencies. +-- +-- 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 hsc_env new_pkgs = do + -- It's probably not safe to try to load packages concurrently, so we take + -- a lock. + initDynLinker hsc_env + let dl = hsc_dynLinker hsc_env + modifyPLS_ dl $ \pls -> do + linkPackages' hsc_env new_pkgs pls + +linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState + -> IO PersistentLinkerState +linkPackages' hsc_env new_pks pls = do + pkgs' <- link (pkgs_loaded pls) new_pks + return $! pls { pkgs_loaded = pkgs' } + where + dflags = hsc_dflags hsc_env + + link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId] + link pkgs new_pkgs = + foldM link_one pkgs new_pkgs + + link_one pkgs new_pkg + | new_pkg `elem` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg + = do { -- Link dependents first + pkgs' <- link pkgs (depends pkg_cfg) + -- Now link the package itself + ; linkPackage hsc_env pkg_cfg + ; return (new_pkg : pkgs') } + + | otherwise + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg))) + + +linkPackage :: HscEnv -> UnitInfo -> IO () +linkPackage hsc_env pkg + = do + let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + is_dyn = interpreterDynamic dflags + dirs | is_dyn = Packages.libraryDynDirs pkg + | otherwise = Packages.libraryDirs pkg + + let hs_libs = Packages.hsLibraries pkg + -- The FFI GHCi import lib isn't needed as + -- compiler/ghci/Linker.hs + rts/Linker.c link the + -- interpreted references to FFI to the compiled FFI. + -- We therefore filter it out so that we don't get + -- duplicate symbol errors. + hs_libs' = filter ("HSffi" /=) hs_libs + + -- 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 possibility 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. + extra_libs = + (if null (Packages.extraGHCiLibraries pkg) + then Packages.extraLibraries pkg + else Packages.extraGHCiLibraries pkg) + ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ] + -- See Note [Fork/Exec Windows] + gcc_paths <- getGCCPaths dflags (platformOS platform) + dirs_env <- addEnvPaths "LIBRARY_PATH" dirs + + hs_classifieds + <- mapM (locateLib hsc_env True dirs_env gcc_paths) hs_libs' + extra_classifieds + <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs + let classifieds = hs_classifieds ++ extra_classifieds + + -- Complication: all the .so's must be loaded before any of the .o's. + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Objects objs <- classifieds + , obj <- objs ] + archs = [ arch | Archive arch <- classifieds ] + + -- Add directories to library search paths + let dll_paths = map takeDirectory known_dlls + all_paths = nub $ map normalise $ dll_paths ++ dirs + all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths + pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env + + maybePutStr dflags + ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") + + -- See comments with partOfGHCi + when (packageName pkg `notElem` partOfGHCi) $ do + loadFrameworks hsc_env platform pkg + -- See Note [Crash early load_dyn and locateLib] + -- Crash early if can't load any of `known_dlls` + mapM_ (load_dyn hsc_env True) known_dlls + -- For remaining `dlls` crash early only when there is surely + -- no package's DLL around ... (not is_dyn) + mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) 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 hsc_env) objs + mapM_ (loadArchive hsc_env) archs + + maybePutStr dflags "linking ... " + ok <- resolveObjs hsc_env + + -- DLLs are loaded, reset the search paths + -- Import libraries will be loaded via loadArchive so only + -- reset the DLL search path after all archives are loaded + -- as well. + mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache + + if succeeded ok + then maybePutStrLn dflags "done." + else let errmsg = "unable to load package `" + ++ sourcePackageIdString pkg ++ "'" + in throwGhcExceptionIO (InstallationError errmsg) + +{- +Note [Crash early load_dyn and locateLib] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a package is "normal" (exposes it's code from more than zero Haskell +modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then +it has it's code compiled and linked into the DLL, which GHCi linker picks +when loading the package's code (see the big comment in the beginning of +`locateLib`). + +When loading DLLs, GHCi linker simply calls the system's `dlopen` or +`LoadLibrary` APIs. This is quite different from the case when GHCi linker +loads an object file or static library. When loading an object file or static +library GHCi linker parses them and resolves all symbols "manually". +These object file or static library may reference some external symbols +defined in some external DLLs. And GHCi should know which these +external DLLs are. + +But when GHCi loads a DLL, it's the *system* linker who manages all +the necessary dependencies, and it is able to load this DLL not having +any extra info. Thus we don't *have to* crash in this case even if we +are unable to load any supposed dependencies explicitly. + +Suppose during GHCi session a client of the package wants to +`foreign import` a symbol which isn't exposed by the package DLL, but +is exposed by such an external (dependency) DLL. +If the DLL isn't *explicitly* loaded because `load_dyn` failed to do +this, then the client code eventually crashes because the GHCi linker +isn't able to locate this symbol (GHCi linker maintains a list of +explicitly loaded DLLs it looks into when trying to find a symbol). + +This is why we still should try to load all the dependency DLLs +even though we know that the system linker loads them implicitly when +loading the package DLL. + +Why we still keep the `crash_early` opportunity then not allowing such +a permissive behaviour for any DLLs? Well, we, perhaps, improve a user +experience in some cases slightly. + +But if it happens there exist other corner cases where our current +usage of `crash_early` flag is overly restrictive, we may lift the +restriction very easily. +-} + +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +load_dyn :: HscEnv -> Bool -> FilePath -> IO () +load_dyn hsc_env crash_early dll = do + r <- loadDLL hsc_env dll + case r of + Nothing -> return () + Just err -> + if crash_early + then cmdLineErrorIO err + else let dflags = hsc_dflags hsc_env in + when (wopt Opt_WarnMissedExtraSharedLib dflags) + $ putLogMsg dflags + (Reason Opt_WarnMissedExtraSharedLib) SevWarning + noSrcSpan (defaultUserStyle dflags)(note err) + where + note err = vcat $ map text + [ err + , "It's OK if you don't want to use symbols from it directly." + , "(the package DLL is loaded by the system linker" + , " which manages dependencies by itself)." ] + +loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO () +loadFrameworks hsc_env platform pkg + = when (platformUsesFrameworks platform) $ mapM_ load frameworks + where + fw_dirs = Packages.frameworkDirs pkg + frameworks = Packages.frameworks pkg + + load fw = do r <- loadFramework hsc_env fw_dirs fw + case r of + Nothing -> return () + Just err -> cmdLineErrorIO ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" ) + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume that addDLL in the RTS can find it, +-- which generally means that it should be a dynamic library in the +-- standard system search path. +-- For GHCi we tend to prefer dynamic libraries over static ones as +-- they are easier to load and manage, have less overhead. +locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String + -> IO LibrarySpec +locateLib hsc_env is_hs lib_dirs gcc_dirs lib + | not is_hs + -- For non-Haskell libraries (e.g. gmp, iconv): + -- first look in library-dirs for a dynamic library (on User paths only) + -- (libfoo.so) + -- then try looking for import libraries on Windows (on User paths only) + -- (.dll.a, .lib) + -- first look in library-dirs for a dynamic library (on GCC paths only) + -- (libfoo.so) + -- then check for system dynamic libraries (e.g. kernel32.dll on windows) + -- then try looking for import libraries on Windows (on GCC paths only) + -- (.dll.a, .lib) + -- then look in library-dirs for a static library (libfoo.a) + -- then look in library-dirs and inplace GCC for a dynamic library (libfoo.so) + -- then try looking for import libraries on Windows (.dll.a, .lib) + -- then look in library-dirs and inplace GCC for a static library (libfoo.a) + -- then try "gcc --print-file-name" to search gcc's search path + -- for a dynamic library (#5289) + -- otherwise, assume loadDLL can find it + -- + -- The logic is a bit complicated, but the rationale behind it is that + -- loading a shared library for us is O(1) while loading an archive is + -- O(n). Loading an import library is also O(n) so in general we prefer + -- shared libraries because they are simpler and faster. + -- + = findDll user `orElse` + tryImpLib user `orElse` + findDll gcc `orElse` + findSysDll `orElse` + tryImpLib gcc `orElse` + findArchive `orElse` + tryGcc `orElse` + assumeDll + + | loading_dynamic_hs_libs -- search for .so libraries first. + = findHSDll `orElse` + findDynObject `orElse` + assumeDll + + | otherwise + -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a + = findObject `orElse` + findArchive `orElse` + assumeDll + + where + dflags = hsc_dflags hsc_env + dirs = lib_dirs ++ gcc_dirs + gcc = False + user = True + + obj_file + | is_hs && loading_profiled_hs_libs = lib <.> "p_o" + | otherwise = lib <.> "o" + dyn_obj_file = lib <.> "dyn_o" + arch_files = [ "lib" ++ lib ++ lib_tag <.> "a" + , lib <.> "a" -- native code has no lib_tag + , "lib" ++ lib, lib + ] + lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" + + loading_profiled_hs_libs = interpreterProfiled dflags + loading_dynamic_hs_libs = interpreterDynamic dflags + + import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib" + , "lib" ++ lib <.> "dll.a", lib <.> "dll.a" + ] + + hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags + hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name + + so_name = mkSOName platform lib + lib_so_name = "lib" ++ so_name + dyn_lib_file = case (arch, os) of + (ArchX86_64, OSSolaris2) -> "64" </> so_name + _ -> so_name + + findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file + findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file + findArchive = let local name = liftM (fmap Archive) $ findFile dirs name + in apply (map local arch_files) + findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file + findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs + in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file + findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ + findSystemLibrary hsc_env so_name + tryGcc = let search = searchForLibUsingGcc dflags + dllpath = liftM (fmap DLLPath) + short = dllpath $ search so_name lib_dirs + full = dllpath $ search lib_so_name lib_dirs + gcc name = liftM (fmap Archive) $ search name lib_dirs + files = import_libs ++ arch_files + in apply $ short : full : map gcc files + tryImpLib re = case os of + OSMinGW32 -> + let dirs' = if re == user then lib_dirs else gcc_dirs + implib name = liftM (fmap Archive) $ + findFile dirs' name + in apply (map implib import_libs) + _ -> return Nothing + + -- TH Makes use of the interpreter so this failure is not obvious. + -- So we are nice and warn/inform users why we fail before we do. + -- But only for haskell libraries, as C libraries don't have a + -- profiling/non-profiling distinction to begin with. + assumeDll + | is_hs + , not loading_dynamic_hs_libs + , interpreterProfiled dflags + = do + warningMsg dflags + (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ + text " \tTrying dynamic library instead. If this fails try to rebuild" <+> + text "libraries with profiling support.") + return (DLL lib) + | otherwise = return (DLL lib) + infixr `orElse` + f `orElse` g = f >>= maybe g return + + apply :: [IO (Maybe a)] -> IO (Maybe a) + apply [] = return Nothing + apply (x:xs) = do x' <- x + if isJust x' + then return x' + else apply xs + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + +searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc dflags so dirs = do + -- GCC does not seem to extend the library search path (using -L) when using + -- --print-file-name. So instead pass it a new base location. + str <- askLd dflags (map (FileOption "-B") dirs + ++ [Option "--print-file-name", Option so]) + let file = case lines str of + [] -> "" + l:_ -> l + if (file == so) + then return Nothing + else do b <- doesFileExist file -- file could be a folder (see #16063) + return (if b then Just file else Nothing) + +-- | Retrieve the list of search directory GCC and the System use to find +-- libraries and components. See Note [Fork/Exec Windows]. +getGCCPaths :: DynFlags -> OS -> IO [FilePath] +getGCCPaths dflags os + = case os of + OSMinGW32 -> + do gcc_dirs <- getGccSearchDirectory dflags "libraries" + sys_dirs <- getSystemDirectories + return $ nub $ gcc_dirs ++ sys_dirs + _ -> return [] + +-- | Cache for the GCC search directories as this can't easily change +-- during an invocation of GHC. (Maybe with some env. variable but we'll) +-- deal with that highly unlikely scenario then. +{-# NOINLINE gccSearchDirCache #-} +gccSearchDirCache :: IORef [(String, [String])] +gccSearchDirCache = unsafePerformIO $ newIORef [] + +-- Note [Fork/Exec Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- fork/exec is expensive on Windows, for each time we ask GCC for a library we +-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. +-- So instead get a list of location that GCC would search and use findDirs +-- which hopefully is written in an optimized mannor to take advantage of +-- caching. At the very least we remove the overhead of the fork/exec and waits +-- which dominate a large percentage of startup time on Windows. +getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] +getGccSearchDirectory dflags key = do + cache <- readIORef gccSearchDirCache + case lookup key cache of + Just x -> return x + Nothing -> do + str <- askLd dflags [Option "--print-search-dirs"] + let line = dropWhile isSpace str + name = key ++ ": =" + if null line + then return [] + else do let val = split $ find name line + dirs <- filterM doesDirectoryExist val + modifyIORef' gccSearchDirCache ((key, dirs):) + return val + where split :: FilePath -> [FilePath] + split r = case break (==';') r of + (s, [] ) -> [s] + (s, (_:xs)) -> s : split xs + + find :: String -> String -> String + find r x = let lst = lines x + val = filter (r `isPrefixOf`) lst + in if null val + then [] + else case break (=='=') (head val) of + (_ , []) -> [] + (_, (_:xs)) -> xs + +-- | Get a list of system search directories, this to alleviate pressure on +-- the findSysDll function. +getSystemDirectories :: IO [FilePath] +#if defined(mingw32_HOST_OS) +getSystemDirectories = fmap (:[]) getSystemDirectory +#else +getSystemDirectories = return [] +#endif + +-- | Merge the given list of paths with those in the environment variable +-- given. If the variable does not exist then just return the identity. +addEnvPaths :: String -> [String] -> IO [String] +addEnvPaths name list + = do -- According to POSIX (chapter 8.3) a zero-length prefix means current + -- working directory. Replace empty strings in the env variable with + -- `working_dir` (see also #14695). + working_dir <- getCurrentDirectory + values <- lookupEnv name + case values of + Nothing -> return list + Just arr -> return $ list ++ splitEnv working_dir arr + where + splitEnv :: FilePath -> String -> [String] + splitEnv working_dir value = + case break (== envListSep) value of + (x, [] ) -> + [if null x then working_dir else x] + (x, (_:xs)) -> + (if null x then working_dir else x) : splitEnv working_dir xs +#if defined(mingw32_HOST_OS) + envListSep = ';' +#else + envListSep = ':' +#endif + +-- ---------------------------------------------------------------------------- +-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + +-- Darwin / MacOS X only: load a framework +-- a framework is a dynamic library packaged inside a directory of the same +-- name. They are searched for in different paths than normal libraries. +loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String) +loadFramework hsc_env extraPaths rootname + = do { either_dir <- tryIO getHomeDirectory + ; let homeFrameworkPath = case either_dir of + Left _ -> [] + Right dir -> [dir </> "Library/Frameworks"] + ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths + ; mb_fwk <- findFile ps fwk_file + ; case mb_fwk of + Just fwk_path -> loadDLL hsc_env fwk_path + Nothing -> return (Just "not found") } + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up + where + fwk_file = rootname <.> "framework" </> rootname + -- sorry for the hardcoded paths, I hope they won't change anytime soon: + defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] + +{- ********************************************************************** + + Helper functions + + ********************************************************************* -} + +maybePutStr :: DynFlags -> String -> IO () +maybePutStr dflags s + = when (verbosity dflags > 1) $ + putLogMsg dflags + NoReason + SevInteractive + noSrcSpan + (defaultUserStyle dflags) + (text s) + +maybePutStrLn :: DynFlags -> String -> IO () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs new file mode 100644 index 0000000000..5b2f506c6d --- /dev/null +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- +-- Types for the Dynamic Linker +-- +-- (c) The University of Glasgow 2019 +-- +----------------------------------------------------------------------------- + +module GHC.Runtime.Linker.Types ( + DynLinker(..), + PersistentLinkerState(..), + LinkerUnitId, + Linkable(..), + Unlinked(..), + SptEntry(..) + ) where + +import GhcPrelude ( FilePath, String, show ) +import Data.Time ( UTCTime ) +import Data.Maybe ( Maybe ) +import Control.Concurrent.MVar ( MVar ) +import Module ( InstalledUnitId, Module ) +import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode ) +import Outputable +import Var ( Id ) +import GHC.Fingerprint.Type ( Fingerprint ) +import NameEnv ( NameEnv ) +import Name ( Name ) +import GHCi.RemoteTypes ( ForeignHValue ) + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +newtype DynLinker = + DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } + +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 :: ![LinkerUnitId], + + -- we need to remember the name of previous temporary DLL/.so + -- libraries so we can link them (see #10322) + temp_sos :: ![(FilePath, String)] } + +-- TODO: Make this type more precise +type LinkerUnitId = InstalledUnitId + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = LM { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- StaticPtrTable. + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in StaticPtrTable. +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs new file mode 100644 index 0000000000..a1c7c2a0fa --- /dev/null +++ b/compiler/GHC/Runtime/Loader.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE CPP, MagicHash #-} + +-- | Dynamically lookup up values from modules and loading them. +module GHC.Runtime.Loader ( + initializePlugins, + -- * Loading plugins + loadFrontendPlugin, + + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModuleForPlugins, + + -- * Loading values + getValueSafely, + getHValueSafely, + lessUnsafeCoerce + ) where + +import GhcPrelude +import DynFlags + +import GHC.Runtime.Linker ( linkModule, getHValue ) +import GHC.Runtime.Interpreter ( wormhole ) +import SrcLoc ( noSrcSpan ) +import Finder ( findPluginModule, cannotFindModule ) +import TcRnMonad ( initTcInteractive, initIfaceTcRn ) +import GHC.Iface.Load ( loadPluginInterface ) +import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName + , gre_name, mkRdrQual ) +import OccName ( OccName, mkVarOcc ) +import GHC.Rename.Names ( gresFromAvails ) +import Plugins +import PrelNames ( pluginTyConName, frontendPluginTyConName ) + +import HscTypes +import GHCi.RemoteTypes ( HValue ) +import Type ( Type, eqType, mkTyConTy ) +import TyCoPpr ( pprTyThingCategory ) +import TyCon ( TyCon ) +import Name ( Name, nameModule_maybe ) +import Id ( idType ) +import Module ( Module, ModuleName ) +import Panic +import FastString +import ErrUtils +import Outputable +import Exception +import Hooks + +import Control.Monad ( when, unless ) +import Data.Maybe ( mapMaybe ) +import GHC.Exts ( unsafeCoerce# ) + +-- | Loads the plugins specified in the pluginModNames field of the dynamic +-- flags. Should be called after command line arguments are parsed, but before +-- actual compilation starts. Idempotent operation. Should be re-called if +-- pluginModNames or pluginModNameOpts changes. +initializePlugins :: HscEnv -> DynFlags -> IO DynFlags +initializePlugins hsc_env df + | map lpModuleName (cachedPlugins df) + == pluginModNames df -- plugins not changed + && all (\p -> paArguments (lpPlugin p) + == argumentsForPlugin p (pluginModNameOpts df)) + (cachedPlugins df) -- arguments not changed + = return df -- no need to reload plugins + | otherwise + = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) + let df' = df { cachedPlugins = loadedPlugins } + df'' <- withPlugins df' runDflagsPlugin df' + return df'' + + where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) + runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags + +loadPlugins :: HscEnv -> IO [LoadedPlugin] +loadPlugins hsc_env + = do { unless (null to_load) $ + checkExternalInterpreter hsc_env + ; plugins <- mapM loadPlugin to_load + ; return $ zipWith attachOptions to_load plugins } + where + dflags = hsc_dflags hsc_env + to_load = pluginModNames dflags + + attachOptions mod_nm (plug, mod) = + LoadedPlugin (PluginWithArgs plug (reverse options)) mod + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + + +loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin +loadFrontendPlugin hsc_env mod_name = do + checkExternalInterpreter hsc_env + fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName + hsc_env mod_name + +-- #14335 +checkExternalInterpreter :: HscEnv -> IO () +checkExternalInterpreter hsc_env = + when (gopt Opt_ExternalInterpreter dflags) $ + throwCmdLineError $ showSDoc dflags $ + text "Plugins require -fno-external-interpreter" + where + dflags = hsc_dflags hsc_env + +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) +loadPlugin' occ_name plugin_name hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name occ_name + dflags = hsc_dflags hsc_env + ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name + plugin_rdr_name + ; case mb_name of { + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The module", ppr mod_name + , text "did not export the plugin name" + , ppr plugin_rdr_name ]) ; + Just (name, mod_iface) -> + + do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The value", ppr name + , text "did not have the type" + , ppr pluginTyConName, text "as required"]) + Just plugin -> return (plugin, mod_iface) } } } + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTcInteractive hsc_env $ + initIfaceTcRn $ + mapM_ (loadPluginInterface doc) modules) + >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name + + mb_con_thing <- lookupTypeHscEnv hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env val_name expected_type = do + mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type + case mb_hval of + Nothing -> return Nothing + Just hval -> do + value <- lessUnsafeCoerce dflags "getValueSafely" hval + return (Just value) + where + dflags = hsc_dflags hsc_env + +getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) +getHValueSafely hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupTypeHscEnv hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do linkModule hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- getHValue hsc_env val_name >>= wormhole dflags + return (Just hval) + else return Nothing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: DynFlags -> String -> a -> IO b +lessUnsafeCoerce dflags context what = do + debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> + (text "...") + output <- evaluate (unsafeCoerce# what) + debugTraceMsg dflags 3 (text "Successfully evaluated coercion") + return output + + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the +-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name' +-- could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +-- +-- Can only be used for looking up names while loading plugins (and is +-- *not* suitable for use within plugins). The interface file is +-- loaded very partially: just enough that it can be used, without its +-- rules and instances affecting (and being linked from!) the module +-- being compiled. This was introduced by 57d6798. +-- +-- Need the module as well to record information in the interface file +lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName + -> IO (Maybe (Name, ModIface)) +lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do + -- First find the package the module resides in by searching exposed packages and home modules + found_module <- findPluginModule hsc_env mod_name + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_iface) <- initTcInteractive hsc_env $ + initIfaceTcRn $ + loadPluginInterface doc mod + case mb_iface of + Just iface -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + , is_qual = False, is_dloc = noSrcSpan } + imp_spec = ImpSpec decl_spec ImpAll + env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) + case lookupGRE_RdrName rdr_name env of + [gre] -> return (Just (gre_name gre, iface)) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + + Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + doc = text "contains a name used in an invocation of lookupRdrNameInModule" + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] + +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcExceptionIO . CmdLineError diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index ccbad37210..881d0340a5 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -26,7 +26,7 @@ import BasicTypes import Demand import DynFlags import Id -import GHC.Runtime.Layout ( WordOff ) +import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Stg.Syntax import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index 347d908b44..436b37fced 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -19,7 +19,7 @@ import GhcPrelude import GHC.StgToCmm.Closure ( idPrimRep ) -import GHC.Runtime.Layout ( WordOff ) +import GHC.Runtime.Heap.Layout ( WordOff ) import Id ( Id ) import TyCon ( PrimRep(..), primElemRepSizeB ) import BasicTypes ( RepArity ) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 977fa4649e..089fec789c 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -31,7 +31,7 @@ import GHC.StgToCmm.Foreign (emitPrimCall) import GHC.Cmm.Graph import CoreSyn ( AltCon(..), tickishIsCode ) import GHC.Cmm.BlockId -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.Utils diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 724ca6000a..b171e7a1fb 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -67,7 +67,7 @@ module GHC.StgToCmm.Closure ( import GhcPrelude import GHC.Stg.Syntax -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Ppr.Expr() -- For Outputable instances diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 7d86620708..eb7f9223d7 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -33,7 +33,7 @@ import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Cmm.Graph -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import CostCentre import Module import DataCon diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 1befdd7d3a..95c8f7defb 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -354,7 +354,7 @@ We want to generate an assignment y := x We want to allow this assignment to be generated in the case when the types are compatible, because this allows some slightly-dodgy but -occasionally-useful casts to be used, such as in RtClosureInspect +occasionally-useful casts to be used, such as in GHC.Runtime.Heap.Inspect where we cast an HValue to a MutVar# so we can print out the contents of the MutVar#. If instead we generate code that enters the HValue, then we'll get a runtime panic, because the HValue really is a diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 62a948d13c..b2302a175a 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -35,7 +35,7 @@ import GHC.Cmm.Graph import Type import GHC.Types.RepType import GHC.Cmm.CLabel -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import ForeignCall import DynFlags import Maybes diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 085d47219f..0656cb2a08 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -37,7 +37,7 @@ import GHC.StgToCmm.Env import GHC.Cmm.Graph import GHC.Cmm.Dataflow.Label -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index e78221de3a..9139c36f0b 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -42,7 +42,7 @@ import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils import GHC.Cmm.Graph -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Utils diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 4f7d2e1220..34709f3d67 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -68,7 +68,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import Module import Id import VarEnv diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 6c5a836d7b..63cb5a532f 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -48,7 +48,7 @@ import TyCon import GHC.Cmm.CLabel import GHC.Cmm.Utils import PrimOp -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import FastString import Outputable import Util diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 581e8279dc..068b768073 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -28,7 +28,7 @@ import GhcPrelude import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.Cmm.Graph import GHC.Cmm diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index fbb121dae6..22f91518f3 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -116,7 +116,7 @@ import GHC.Cmm.Expr import GHC.Cmm.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import Module import Name diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 373beeed07..3611a64f75 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -66,7 +66,7 @@ import ForeignCall import IdInfo import Type import TyCon -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import Module import Literal import Digraph |