From da7f74797e8c322006eba385c9cbdce346dd1d43 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Fri, 17 Jan 2020 15:13:04 +0100 Subject: Module hierarchy: ByteCode and Runtime (cf #13009) Update haddock submodule --- compiler/GHC/ByteCode/Asm.hs | 566 ++++++ compiler/GHC/ByteCode/InfoTable.hs | 76 + compiler/GHC/ByteCode/Instr.hs | 373 ++++ compiler/GHC/ByteCode/Linker.hs | 184 ++ compiler/GHC/ByteCode/Types.hs | 182 ++ compiler/GHC/Cmm.hs | 2 +- compiler/GHC/Cmm/CallConv.hs | 2 +- compiler/GHC/Cmm/Graph.hs | 2 +- compiler/GHC/Cmm/Info.hs | 2 +- compiler/GHC/Cmm/Info/Build.hs | 2 +- compiler/GHC/Cmm/LayoutStack.hs | 2 +- compiler/GHC/Cmm/Node.hs | 2 +- compiler/GHC/Cmm/Parser.y | 2 +- compiler/GHC/Cmm/Utils.hs | 2 +- compiler/GHC/CoreToByteCode.hs | 2036 ++++++++++++++++++++ compiler/GHC/CoreToStg/Prep.hs | 2 +- compiler/GHC/Data/Bitmap.hs | 2 +- compiler/GHC/Runtime/Debugger.hs | 237 +++ compiler/GHC/Runtime/Eval.hs | 1271 ++++++++++++ compiler/GHC/Runtime/Eval/Types.hs | 89 + compiler/GHC/Runtime/Heap/Inspect.hs | 1355 +++++++++++++ compiler/GHC/Runtime/Heap/Layout.hs | 563 ++++++ compiler/GHC/Runtime/Interpreter.hs | 667 +++++++ compiler/GHC/Runtime/Layout.hs | 563 ------ compiler/GHC/Runtime/Linker.hs | 1716 +++++++++++++++++ compiler/GHC/Runtime/Linker/Types.hs | 112 ++ compiler/GHC/Runtime/Loader.hs | 283 +++ compiler/GHC/Stg/Lift/Analysis.hs | 2 +- compiler/GHC/StgToCmm/ArgRep.hs | 2 +- compiler/GHC/StgToCmm/Bind.hs | 2 +- compiler/GHC/StgToCmm/Closure.hs | 2 +- compiler/GHC/StgToCmm/DataCon.hs | 2 +- compiler/GHC/StgToCmm/Expr.hs | 2 +- compiler/GHC/StgToCmm/Foreign.hs | 2 +- compiler/GHC/StgToCmm/Heap.hs | 2 +- compiler/GHC/StgToCmm/Layout.hs | 2 +- compiler/GHC/StgToCmm/Monad.hs | 2 +- compiler/GHC/StgToCmm/Prim.hs | 2 +- compiler/GHC/StgToCmm/Prof.hs | 2 +- compiler/GHC/StgToCmm/Ticky.hs | 2 +- compiler/GHC/StgToCmm/Utils.hs | 2 +- compiler/basicTypes/Literal.hs | 2 +- compiler/cbits/keepCAFsForGHCi.c | 15 + compiler/deSugar/Coverage.hs | 4 +- compiler/ghc.cabal.in | 33 +- compiler/ghci/ByteCodeAsm.hs | 566 ------ compiler/ghci/ByteCodeGen.hs | 2036 -------------------- compiler/ghci/ByteCodeInstr.hs | 373 ---- compiler/ghci/ByteCodeItbls.hs | 76 - compiler/ghci/ByteCodeLink.hs | 184 -- compiler/ghci/ByteCodeTypes.hs | 182 -- compiler/ghci/Debugger.hs | 237 --- compiler/ghci/GHCi.hs | 667 ------- compiler/ghci/Linker.hs | 1707 ---------------- compiler/ghci/LinkerTypes.hs | 112 -- compiler/ghci/RtClosureInspect.hs | 1355 ------------- compiler/ghci/keepCAFsForGHCi.c | 15 - compiler/main/DynFlags.hs | 2 +- compiler/main/DynamicLoading.hs | 283 --- compiler/main/GHC.hs | 20 +- compiler/main/GhcMake.hs | 2 +- compiler/main/HscMain.hs | 8 +- compiler/main/HscTypes.hs | 8 +- compiler/main/InteractiveEval.hs | 1271 ------------ compiler/main/InteractiveEvalTypes.hs | 89 - compiler/simplCore/SimplCore.hs | 2 +- compiler/typecheck/TcErrors.hs | 2 +- compiler/typecheck/TcSplice.hs | 2 +- compiler/typecheck/TcType.hs | 2 +- ghc/GHCi/UI.hs | 10 +- ghc/GHCi/UI/Monad.hs | 2 +- ghc/Main.hs | 4 +- includes/rts/Bytecodes.h | 2 +- includes/stg/MiscClosures.h | 2 +- libraries/ghc-heap/GHC/Exts/Heap.hs | 4 +- libraries/ghci/GHCi/BreakArray.hs | 2 +- libraries/integer-gmp/src/GHC/Integer/Type.hs | 2 +- rts/Disassembler.c | 2 +- rts/PrimOps.cmm | 2 +- testsuite/tests/codeGen/should_run/T13825-unit.hs | 2 +- testsuite/tests/ghc-api/T4891/T4891.hs | 6 +- testsuite/tests/ghci/should_run/ghcirun004.hs | 2 +- testsuite/tests/rts/linker/LinkerUnload.hs | 2 +- .../T11223/T11223_link_order_a_b_2_fail.stderr | 2 +- ...1223_link_order_a_b_2_fail.stderr-ws-32-mingw32 | 2 +- ...1223_link_order_a_b_2_fail.stderr-ws-64-mingw32 | 2 +- .../T11223/T11223_simple_duplicate_lib.stderr | 2 +- ...11223_simple_duplicate_lib.stderr-ws-32-mingw32 | 2 +- ...11223_simple_duplicate_lib.stderr-ws-64-mingw32 | 2 +- utils/haddock | 2 +- 90 files changed, 9822 insertions(+), 9814 deletions(-) create mode 100644 compiler/GHC/ByteCode/Asm.hs create mode 100644 compiler/GHC/ByteCode/InfoTable.hs create mode 100644 compiler/GHC/ByteCode/Instr.hs create mode 100644 compiler/GHC/ByteCode/Linker.hs create mode 100644 compiler/GHC/ByteCode/Types.hs create mode 100644 compiler/GHC/CoreToByteCode.hs create mode 100644 compiler/GHC/Runtime/Debugger.hs create mode 100644 compiler/GHC/Runtime/Eval.hs create mode 100644 compiler/GHC/Runtime/Eval/Types.hs create mode 100644 compiler/GHC/Runtime/Heap/Inspect.hs create mode 100644 compiler/GHC/Runtime/Heap/Layout.hs create mode 100644 compiler/GHC/Runtime/Interpreter.hs delete mode 100644 compiler/GHC/Runtime/Layout.hs create mode 100644 compiler/GHC/Runtime/Linker.hs create mode 100644 compiler/GHC/Runtime/Linker/Types.hs create mode 100644 compiler/GHC/Runtime/Loader.hs create mode 100644 compiler/cbits/keepCAFsForGHCi.c delete mode 100644 compiler/ghci/ByteCodeAsm.hs delete mode 100644 compiler/ghci/ByteCodeGen.hs delete mode 100644 compiler/ghci/ByteCodeInstr.hs delete mode 100644 compiler/ghci/ByteCodeItbls.hs delete mode 100644 compiler/ghci/ByteCodeLink.hs delete mode 100644 compiler/ghci/ByteCodeTypes.hs delete mode 100644 compiler/ghci/Debugger.hs delete mode 100644 compiler/ghci/GHCi.hs delete mode 100644 compiler/ghci/Linker.hs delete mode 100644 compiler/ghci/LinkerTypes.hs delete mode 100644 compiler/ghci/RtClosureInspect.hs delete mode 100644 compiler/ghci/keepCAFsForGHCi.c delete mode 100644 compiler/main/DynamicLoading.hs delete mode 100644 compiler/main/InteractiveEval.hs delete mode 100644 compiler/main/InteractiveEvalTypes.hs 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 "" + +-- ----------------------------------------------------------------------------- +-- 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 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 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# 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): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshall code mentioned + in the CCALL insn, passing it (& ), + 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 + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G + 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 = "" + , 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 "" 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 "") + 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, "") + +-- 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 "") 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("") + | 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 "" + | t == stableNamePrimTyCon = text "" + | t == statePrimTyCon = text "" + | t == proxyPrimTyCon = text "" + | t == realWorldTyCon = text "" + | t == threadIdPrimTyCon = text "" + | t == weakPrimTyCon = text "" + | t == arrayPrimTyCon = text "" + | t == smallArrayPrimTyCon = text "" + | t == byteArrayPrimTyCon = text "" + | t == mutableArrayPrimTyCon = text "" + | t == smallMutableArrayPrimTyCon = text "" + | t == mutableByteArrayPrimTyCon = text "" + | t == mutVarPrimTyCon = text "" + | t == mVarPrimTyCon = text "" + | t == tVarPrimTyCon = text "" + | 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: + + = + +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 +-- 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/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs new file mode 100644 index 0000000000..b7899ecc1b --- /dev/null +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -0,0 +1,563 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- Storage manager representation of closures + +{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} + +module GHC.Runtime.Heap.Layout ( + -- * Words and bytes + WordOff, ByteOff, + wordsToBytes, bytesToWordsRoundUp, + roundUpToWords, roundUpTo, + + StgWord, fromStgWord, toStgWord, + StgHalfWord, fromStgHalfWord, toStgHalfWord, + halfWordSize, halfWordSizeInBits, + + -- * Closure representation + SMRep(..), -- CmmInfo sees the rep; no one else does + IsStatic, + ClosureTypeInfo(..), ArgDescr(..), Liveness, + ConstrDescription, + + -- ** Construction + mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, + smallArrPtrsRep, arrWordsRep, + + -- ** Predicates + isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, + isStackRep, + + -- ** Size-related things + heapClosureSizeW, + fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, + arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, + smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, + fixedHdrSize, + + -- ** RTS closure types + rtsClosureType, rET_SMALL, rET_BIG, + aRG_GEN, aRG_GEN_BIG, + + -- ** Arrays + card, cardRoundUp, cardTableSizeB, cardTableSizeW + ) where + +import GhcPrelude + +import BasicTypes( ConTagZ ) +import DynFlags +import Outputable +import GHC.Platform +import FastString + +import Data.Word +import Data.Bits +import Data.ByteString (ByteString) + +{- +************************************************************************ +* * + Words and bytes +* * +************************************************************************ +-} + +-- | Word offset, or word count +type WordOff = Int + +-- | Byte offset, or byte count +type ByteOff = Int + +-- | Round up the given byte count to the next byte count that's a +-- multiple of the machine's word size. +roundUpToWords :: DynFlags -> ByteOff -> ByteOff +roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags) + +-- | Round up @base@ to a multiple of @size@. +roundUpTo :: ByteOff -> ByteOff -> ByteOff +roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1)) + +-- | Convert the given number of words to a number of bytes. +-- +-- This function morally has type @WordOff -> ByteOff@, but uses @Num +-- a@ to allow for overloading. +wordsToBytes :: Num a => DynFlags -> a -> a +wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n +{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} +{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} + +-- | First round the given byte count up to a multiple of the +-- machine's word size and then convert the result to words. +bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff +bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size + where word_size = wORD_SIZE dflags +-- StgWord is a type representing an StgWord on the target platform. +-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform +newtype StgWord = StgWord Word64 + deriving (Eq, Bits) + +fromStgWord :: StgWord -> Integer +fromStgWord (StgWord i) = toInteger i + +toStgWord :: DynFlags -> Integer -> StgWord +toStgWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgWord (-1) + -- do the right thing + PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) + PW8 -> StgWord (fromInteger i) + +instance Outputable StgWord where + ppr (StgWord i) = integer (toInteger i) + +-- + +-- A Word32 is large enough to hold half a Word for either a 32bit or +-- 64bit platform +newtype StgHalfWord = StgHalfWord Word32 + deriving Eq + +fromStgHalfWord :: StgHalfWord -> Integer +fromStgHalfWord (StgHalfWord w) = toInteger w + +toStgHalfWord :: DynFlags -> Integer -> StgHalfWord +toStgHalfWord dflags i + = case platformWordSize (targetPlatform dflags) of + -- These conversions mean that things like toStgHalfWord (-1) + -- do the right thing + PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) + PW8 -> StgHalfWord (fromInteger i :: Word32) + +instance Outputable StgHalfWord where + ppr (StgHalfWord w) = integer (toInteger w) + +-- | Half word size in bytes +halfWordSize :: DynFlags -> ByteOff +halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2 + +halfWordSizeInBits :: DynFlags -> Int +halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2 + +{- +************************************************************************ +* * +\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} +* * +************************************************************************ +-} + +-- | A description of the layout of a closure. Corresponds directly +-- to the closure types in includes/rts/storage/ClosureTypes.h. +data SMRep + = HeapRep -- GC routines consult sizes in info tbl + IsStatic + !WordOff -- # ptr words + !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) + ClosureTypeInfo -- type-specific info + + | ArrayPtrsRep + !WordOff -- # ptr words + !WordOff -- # card table words + + | SmallArrayPtrsRep + !WordOff -- # ptr words + + | ArrayWordsRep + !WordOff -- # bytes expressed in words, rounded up + + | StackRep -- Stack frame (RET_SMALL or RET_BIG) + Liveness + + | RTSRep -- The RTS needs to declare info tables with specific + Int -- type tags, so this form lets us override the default + SMRep -- tag for an SMRep. + +-- | True <=> This is a static closure. Affects how we garbage-collect it. +-- Static closure have an extra static link field at the end. +-- Constructors do not have a static variant; see Note [static constructors] +type IsStatic = Bool + +-- From an SMRep you can get to the closure type defined in +-- includes/rts/storage/ClosureTypes.h. Described by the function +-- rtsClosureType below. + +data ClosureTypeInfo + = Constr ConTagZ ConstrDescription + | Fun FunArity ArgDescr + | Thunk + | ThunkSelector SelectorOffset + | BlackHole + | IndStatic + +type ConstrDescription = ByteString -- result of dataConIdentity +type FunArity = Int +type SelectorOffset = Int + +------------------------- +-- We represent liveness bitmaps as a Bitmap (whose internal +-- representation really is a bitmap). These are pinned onto case return +-- vectors to indicate the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single +-- word (StgWord) are stored as a single word, while larger bitmaps are +-- stored as a pointer to an array of words. + +type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead + -- False <=> ptr + +------------------------- +-- An ArgDescr describes the argument pattern of a function + +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... + + | ArgGen -- General case + Liveness -- Details about the arguments + + +----------------------------------------------------------------------------- +-- Construction + +mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo + -> SMRep +mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info + = HeapRep is_static + ptr_wds + (nonptr_wds + slop_wds) + cl_type_info + where + slop_wds + | is_static = 0 + | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) + + hdr_size = closureTypeHdrSize dflags cl_type_info + payload_size = ptr_wds + nonptr_wds + +mkRTSRep :: Int -> SMRep -> SMRep +mkRTSRep = RTSRep + +mkStackRep :: [Bool] -> SMRep +mkStackRep liveness = StackRep liveness + +blackHoleRep :: SMRep +blackHoleRep = HeapRep False 0 0 BlackHole + +indStaticRep :: SMRep +indStaticRep = HeapRep True 1 0 IndStatic + +arrPtrsRep :: DynFlags -> WordOff -> SMRep +arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) + +smallArrPtrsRep :: WordOff -> SMRep +smallArrPtrsRep elems = SmallArrayPtrsRep elems + +arrWordsRep :: DynFlags -> ByteOff -> SMRep +arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) + +----------------------------------------------------------------------------- +-- Predicates + +isStaticRep :: SMRep -> IsStatic +isStaticRep (HeapRep is_static _ _ _) = is_static +isStaticRep (RTSRep _ rep) = isStaticRep rep +isStaticRep _ = False + +isStackRep :: SMRep -> Bool +isStackRep StackRep{} = True +isStackRep (RTSRep _ rep) = isStackRep rep +isStackRep _ = False + +isConRep :: SMRep -> Bool +isConRep (HeapRep _ _ _ Constr{}) = True +isConRep _ = False + +isThunkRep :: SMRep -> Bool +isThunkRep (HeapRep _ _ _ Thunk) = True +isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True +isThunkRep (HeapRep _ _ _ BlackHole) = True +isThunkRep (HeapRep _ _ _ IndStatic) = True +isThunkRep _ = False + +isFunRep :: SMRep -> Bool +isFunRep (HeapRep _ _ _ Fun{}) = True +isFunRep _ = False + +isStaticNoCafCon :: SMRep -> Bool +-- This should line up exactly with CONSTR_NOCAF below +-- See Note [Static NoCaf constructors] +isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True +isStaticNoCafCon _ = False + + +----------------------------------------------------------------------------- +-- Size-related things + +fixedHdrSize :: DynFlags -> ByteOff +fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) + +-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) +fixedHdrSizeW :: DynFlags -> WordOff +fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags + +-- | Size of the profiling part of a closure header +-- (StgProfHeader in includes/rts/storage/Closures.h) +profHdrSize :: DynFlags -> WordOff +profHdrSize dflags + | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags + | otherwise = 0 + +-- | The garbage collector requires that every closure is at least as +-- big as this. +minClosureSize :: DynFlags -> WordOff +minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags + +arrWordsHdrSize :: DynFlags -> ByteOff +arrWordsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags + +arrWordsHdrSizeW :: DynFlags -> WordOff +arrWordsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags) + +arrPtrsHdrSize :: DynFlags -> ByteOff +arrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags + +arrPtrsHdrSizeW :: DynFlags -> WordOff +arrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + +smallArrPtrsHdrSize :: DynFlags -> ByteOff +smallArrPtrsHdrSize dflags + = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags + +smallArrPtrsHdrSizeW :: DynFlags -> WordOff +smallArrPtrsHdrSizeW dflags = + fixedHdrSizeW dflags + + (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) + +-- Thunks have an extra header word on SMP, so the update doesn't +-- splat the payload. +thunkHdrSize :: DynFlags -> WordOff +thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags + +hdrSize :: DynFlags -> SMRep -> ByteOff +hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) + +hdrSizeW :: DynFlags -> SMRep -> WordOff +hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty +hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags +hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags +hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags +hdrSizeW _ _ = panic "SMRep.hdrSizeW" + +nonHdrSize :: DynFlags -> SMRep -> ByteOff +nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) + +nonHdrSizeW :: SMRep -> WordOff +nonHdrSizeW (HeapRep _ p np _) = p + np +nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct +nonHdrSizeW (SmallArrayPtrsRep elems) = elems +nonHdrSizeW (ArrayWordsRep words) = words +nonHdrSizeW (StackRep bs) = length bs +nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep + +-- | The total size of the closure, in words. +heapClosureSizeW :: DynFlags -> SMRep -> WordOff +heapClosureSizeW dflags (HeapRep _ p np ty) + = closureTypeHdrSize dflags ty + p + np +heapClosureSizeW dflags (ArrayPtrsRep elems ct) + = arrPtrsHdrSizeW dflags + elems + ct +heapClosureSizeW dflags (SmallArrayPtrsRep elems) + = smallArrPtrsHdrSizeW dflags + elems +heapClosureSizeW dflags (ArrayWordsRep words) + = arrWordsHdrSizeW dflags + words +heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" + +closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff +closureTypeHdrSize dflags ty = case ty of + Thunk -> thunkHdrSize dflags + ThunkSelector{} -> thunkHdrSize dflags + BlackHole -> thunkHdrSize dflags + IndStatic -> thunkHdrSize dflags + _ -> fixedHdrSizeW dflags + -- All thunks use thunkHdrSize, even if they are non-updatable. + -- this is because we don't have separate closure types for + -- updatable vs. non-updatable thunks, so the GC can't tell the + -- difference. If we ever have significant numbers of non- + -- updatable thunks, it might be worth fixing this. + +-- --------------------------------------------------------------------------- +-- Arrays + +-- | The byte offset into the card table of the card for a given element +card :: DynFlags -> Int -> Int +card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags + +-- | Convert a number of elements to a number of cards, rounding up +cardRoundUp :: DynFlags -> Int -> Int +cardRoundUp dflags i = + card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) + +-- | The size of a card table, in bytes +cardTableSizeB :: DynFlags -> Int -> ByteOff +cardTableSizeB dflags elems = cardRoundUp dflags elems + +-- | The size of a card table, in words +cardTableSizeW :: DynFlags -> Int -> WordOff +cardTableSizeW dflags elems = + bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) + +----------------------------------------------------------------------------- +-- deriving the RTS closure type from an SMRep + +#include "../includes/rts/storage/ClosureTypes.h" +#include "../includes/rts/storage/FunTypes.h" +-- Defines CONSTR, CONSTR_1_0 etc + +-- | Derives the RTS closure type from an 'SMRep' +rtsClosureType :: SMRep -> Int +rtsClosureType rep + = case rep of + RTSRep ty _ -> ty + + -- See Note [static constructors] + HeapRep _ 1 0 Constr{} -> CONSTR_1_0 + HeapRep _ 0 1 Constr{} -> CONSTR_0_1 + HeapRep _ 2 0 Constr{} -> CONSTR_2_0 + HeapRep _ 1 1 Constr{} -> CONSTR_1_1 + HeapRep _ 0 2 Constr{} -> CONSTR_0_2 + HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF + -- See Note [Static NoCaf constructors] + HeapRep _ _ _ Constr{} -> CONSTR + + HeapRep False 1 0 Fun{} -> FUN_1_0 + HeapRep False 0 1 Fun{} -> FUN_0_1 + HeapRep False 2 0 Fun{} -> FUN_2_0 + HeapRep False 1 1 Fun{} -> FUN_1_1 + HeapRep False 0 2 Fun{} -> FUN_0_2 + HeapRep False _ _ Fun{} -> FUN + + HeapRep False 1 0 Thunk -> THUNK_1_0 + HeapRep False 0 1 Thunk -> THUNK_0_1 + HeapRep False 2 0 Thunk -> THUNK_2_0 + HeapRep False 1 1 Thunk -> THUNK_1_1 + HeapRep False 0 2 Thunk -> THUNK_0_2 + HeapRep False _ _ Thunk -> THUNK + + HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR + + HeapRep True _ _ Fun{} -> FUN_STATIC + HeapRep True _ _ Thunk -> THUNK_STATIC + HeapRep False _ _ BlackHole -> BLACKHOLE + HeapRep False _ _ IndStatic -> IND_STATIC + + _ -> panic "rtsClosureType" + +-- We export these ones +rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int +rET_SMALL = RET_SMALL +rET_BIG = RET_BIG +aRG_GEN = ARG_GEN +aRG_GEN_BIG = ARG_GEN_BIG + +{- +Note [static constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to have a CONSTR_STATIC closure type, and each constructor had +two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with +CONSTR_STATIC. + +This distinction was removed, because when copying a data structure +into a compact region, we must copy static constructors into the +compact region too. If we didn't do this, we would need to track the +references from the compact region out to the static constructors, +because they might (indirectly) refer to CAFs. + +Since static constructors will be copied to the heap, if we wanted to +use different info tables for static and dynamic constructors, we +would have to switch the info pointer when copying the constructor +into the compact region, which means we would need an extra field of +the static info table to point to the dynamic one. + +However, since the distinction between static and dynamic closure +types is never actually needed (other than for assertions), we can +just drop the distinction and use the same info table for both. + +The GC *does* need to distinguish between static and dynamic closures, +but it does this using the HEAP_ALLOCED() macro which checks whether +the address of the closure resides within the dynamic heap. +HEAP_ALLOCED() doesn't read the closure's info table. + +Note [Static NoCaf constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we know that a top-level binding 'x' is not Caffy (ie no CAFs are +reachable from 'x'), then a statically allocated constructor (Just x) +is also not Caffy, and the garbage collector need not follow its +argument fields. Exploiting this would require two static info tables +for Just, for the two cases where the argument was Caffy or non-Caffy. + +Currently we don't do this; instead we treat nullary constructors +as non-Caffy, and the others as potentially Caffy. + + +************************************************************************ +* * + Pretty printing of SMRep and friends +* * +************************************************************************ +-} + +instance Outputable ClosureTypeInfo where + ppr = pprTypeInfo + +instance Outputable SMRep where + ppr (HeapRep static ps nps tyinfo) + = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) + where + header = text "HeapRep" + <+> if static then text "static" else empty + <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps + pp_n :: String -> Int -> SDoc + pp_n _ 0 = empty + pp_n s n = int n <+> text s + + ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size + + ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size + + ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words + + ppr (StackRep bs) = text "StackRep" <+> ppr bs + + ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep + +instance Outputable ArgDescr where + ppr (ArgSpec n) = text "ArgSpec" <+> ppr n + ppr (ArgGen ls) = text "ArgGen" <+> ppr ls + +pprTypeInfo :: ClosureTypeInfo -> SDoc +pprTypeInfo (Constr tag descr) + = text "Con" <+> + braces (sep [ text "tag:" <+> ppr tag + , text "descr:" <> text (show descr) ]) + +pprTypeInfo (Fun arity args) + = text "Fun" <+> + braces (sep [ text "arity:" <+> ppr arity + , ptext (sLit ("fun_type:")) <+> ppr args ]) + +pprTypeInfo (ThunkSelector offset) + = text "ThunkSel" <+> ppr offset + +pprTypeInfo Thunk = text "Thunk" +pprTypeInfo BlackHole = text "BlackHole" +pprTypeInfo IndStatic = text "IndStatic" 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) 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/Layout.hs b/compiler/GHC/Runtime/Layout.hs deleted file mode 100644 index 8f245479c1..0000000000 --- a/compiler/GHC/Runtime/Layout.hs +++ /dev/null @@ -1,563 +0,0 @@ --- (c) The University of Glasgow 2006 --- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --- --- Storage manager representation of closures - -{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} - -module GHC.Runtime.Layout ( - -- * Words and bytes - WordOff, ByteOff, - wordsToBytes, bytesToWordsRoundUp, - roundUpToWords, roundUpTo, - - StgWord, fromStgWord, toStgWord, - StgHalfWord, fromStgHalfWord, toStgHalfWord, - halfWordSize, halfWordSizeInBits, - - -- * Closure representation - SMRep(..), -- CmmInfo sees the rep; no one else does - IsStatic, - ClosureTypeInfo(..), ArgDescr(..), Liveness, - ConstrDescription, - - -- ** Construction - mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep, - smallArrPtrsRep, arrWordsRep, - - -- ** Predicates - isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon, - isStackRep, - - -- ** Size-related things - heapClosureSizeW, - fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize, - arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW, - smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW, - fixedHdrSize, - - -- ** RTS closure types - rtsClosureType, rET_SMALL, rET_BIG, - aRG_GEN, aRG_GEN_BIG, - - -- ** Arrays - card, cardRoundUp, cardTableSizeB, cardTableSizeW - ) where - -import GhcPrelude - -import BasicTypes( ConTagZ ) -import DynFlags -import Outputable -import GHC.Platform -import FastString - -import Data.Word -import Data.Bits -import Data.ByteString (ByteString) - -{- -************************************************************************ -* * - Words and bytes -* * -************************************************************************ --} - --- | Word offset, or word count -type WordOff = Int - --- | Byte offset, or byte count -type ByteOff = Int - --- | Round up the given byte count to the next byte count that's a --- multiple of the machine's word size. -roundUpToWords :: DynFlags -> ByteOff -> ByteOff -roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags) - --- | Round up @base@ to a multiple of @size@. -roundUpTo :: ByteOff -> ByteOff -> ByteOff -roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1)) - --- | Convert the given number of words to a number of bytes. --- --- This function morally has type @WordOff -> ByteOff@, but uses @Num --- a@ to allow for overloading. -wordsToBytes :: Num a => DynFlags -> a -> a -wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n -{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-} -{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-} - --- | First round the given byte count up to a multiple of the --- machine's word size and then convert the result to words. -bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff -bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size - where word_size = wORD_SIZE dflags --- StgWord is a type representing an StgWord on the target platform. --- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform -newtype StgWord = StgWord Word64 - deriving (Eq, Bits) - -fromStgWord :: StgWord -> Integer -fromStgWord (StgWord i) = toInteger i - -toStgWord :: DynFlags -> Integer -> StgWord -toStgWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgWord (-1) - -- do the right thing - PW4 -> StgWord (fromIntegral (fromInteger i :: Word32)) - PW8 -> StgWord (fromInteger i) - -instance Outputable StgWord where - ppr (StgWord i) = integer (toInteger i) - --- - --- A Word32 is large enough to hold half a Word for either a 32bit or --- 64bit platform -newtype StgHalfWord = StgHalfWord Word32 - deriving Eq - -fromStgHalfWord :: StgHalfWord -> Integer -fromStgHalfWord (StgHalfWord w) = toInteger w - -toStgHalfWord :: DynFlags -> Integer -> StgHalfWord -toStgHalfWord dflags i - = case platformWordSize (targetPlatform dflags) of - -- These conversions mean that things like toStgHalfWord (-1) - -- do the right thing - PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16)) - PW8 -> StgHalfWord (fromInteger i :: Word32) - -instance Outputable StgHalfWord where - ppr (StgHalfWord w) = integer (toInteger w) - --- | Half word size in bytes -halfWordSize :: DynFlags -> ByteOff -halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2 - -halfWordSizeInBits :: DynFlags -> Int -halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2 - -{- -************************************************************************ -* * -\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} -* * -************************************************************************ --} - --- | A description of the layout of a closure. Corresponds directly --- to the closure types in includes/rts/storage/ClosureTypes.h. -data SMRep - = HeapRep -- GC routines consult sizes in info tbl - IsStatic - !WordOff -- # ptr words - !WordOff -- # non-ptr words INCLUDING SLOP (see mkHeapRep below) - ClosureTypeInfo -- type-specific info - - | ArrayPtrsRep - !WordOff -- # ptr words - !WordOff -- # card table words - - | SmallArrayPtrsRep - !WordOff -- # ptr words - - | ArrayWordsRep - !WordOff -- # bytes expressed in words, rounded up - - | StackRep -- Stack frame (RET_SMALL or RET_BIG) - Liveness - - | RTSRep -- The RTS needs to declare info tables with specific - Int -- type tags, so this form lets us override the default - SMRep -- tag for an SMRep. - --- | True <=> This is a static closure. Affects how we garbage-collect it. --- Static closure have an extra static link field at the end. --- Constructors do not have a static variant; see Note [static constructors] -type IsStatic = Bool - --- From an SMRep you can get to the closure type defined in --- includes/rts/storage/ClosureTypes.h. Described by the function --- rtsClosureType below. - -data ClosureTypeInfo - = Constr ConTagZ ConstrDescription - | Fun FunArity ArgDescr - | Thunk - | ThunkSelector SelectorOffset - | BlackHole - | IndStatic - -type ConstrDescription = ByteString -- result of dataConIdentity -type FunArity = Int -type SelectorOffset = Int - -------------------------- --- We represent liveness bitmaps as a Bitmap (whose internal --- representation really is a bitmap). These are pinned onto case return --- vectors to indicate the state of the stack for the garbage collector. --- --- In the compiled program, liveness bitmaps that fit inside a single --- word (StgWord) are stored as a single word, while larger bitmaps are --- stored as a pointer to an array of words. - -type Liveness = [Bool] -- One Bool per word; True <=> non-ptr or dead - -- False <=> ptr - -------------------------- --- An ArgDescr describes the argument pattern of a function - -data ArgDescr - = ArgSpec -- Fits one of the standard patterns - !Int -- RTS type identifier ARG_P, ARG_N, ... - - | ArgGen -- General case - Liveness -- Details about the arguments - - ------------------------------------------------------------------------------ --- Construction - -mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo - -> SMRep -mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info - = HeapRep is_static - ptr_wds - (nonptr_wds + slop_wds) - cl_type_info - where - slop_wds - | is_static = 0 - | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) - - hdr_size = closureTypeHdrSize dflags cl_type_info - payload_size = ptr_wds + nonptr_wds - -mkRTSRep :: Int -> SMRep -> SMRep -mkRTSRep = RTSRep - -mkStackRep :: [Bool] -> SMRep -mkStackRep liveness = StackRep liveness - -blackHoleRep :: SMRep -blackHoleRep = HeapRep False 0 0 BlackHole - -indStaticRep :: SMRep -indStaticRep = HeapRep True 1 0 IndStatic - -arrPtrsRep :: DynFlags -> WordOff -> SMRep -arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) - -smallArrPtrsRep :: WordOff -> SMRep -smallArrPtrsRep elems = SmallArrayPtrsRep elems - -arrWordsRep :: DynFlags -> ByteOff -> SMRep -arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes) - ------------------------------------------------------------------------------ --- Predicates - -isStaticRep :: SMRep -> IsStatic -isStaticRep (HeapRep is_static _ _ _) = is_static -isStaticRep (RTSRep _ rep) = isStaticRep rep -isStaticRep _ = False - -isStackRep :: SMRep -> Bool -isStackRep StackRep{} = True -isStackRep (RTSRep _ rep) = isStackRep rep -isStackRep _ = False - -isConRep :: SMRep -> Bool -isConRep (HeapRep _ _ _ Constr{}) = True -isConRep _ = False - -isThunkRep :: SMRep -> Bool -isThunkRep (HeapRep _ _ _ Thunk) = True -isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True -isThunkRep (HeapRep _ _ _ BlackHole) = True -isThunkRep (HeapRep _ _ _ IndStatic) = True -isThunkRep _ = False - -isFunRep :: SMRep -> Bool -isFunRep (HeapRep _ _ _ Fun{}) = True -isFunRep _ = False - -isStaticNoCafCon :: SMRep -> Bool --- This should line up exactly with CONSTR_NOCAF below --- See Note [Static NoCaf constructors] -isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True -isStaticNoCafCon _ = False - - ------------------------------------------------------------------------------ --- Size-related things - -fixedHdrSize :: DynFlags -> ByteOff -fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags) - --- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h) -fixedHdrSizeW :: DynFlags -> WordOff -fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags - --- | Size of the profiling part of a closure header --- (StgProfHeader in includes/rts/storage/Closures.h) -profHdrSize :: DynFlags -> WordOff -profHdrSize dflags - | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags - | otherwise = 0 - --- | The garbage collector requires that every closure is at least as --- big as this. -minClosureSize :: DynFlags -> WordOff -minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags - -arrWordsHdrSize :: DynFlags -> ByteOff -arrWordsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags - -arrWordsHdrSizeW :: DynFlags -> WordOff -arrWordsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags) - -arrPtrsHdrSize :: DynFlags -> ByteOff -arrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags - -arrPtrsHdrSizeW :: DynFlags -> WordOff -arrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - -smallArrPtrsHdrSize :: DynFlags -> ByteOff -smallArrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags - -smallArrPtrsHdrSizeW :: DynFlags -> WordOff -smallArrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags) - --- Thunks have an extra header word on SMP, so the update doesn't --- splat the payload. -thunkHdrSize :: DynFlags -> WordOff -thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags - -hdrSize :: DynFlags -> SMRep -> ByteOff -hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep) - -hdrSizeW :: DynFlags -> SMRep -> WordOff -hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty -hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags -hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags -hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags -hdrSizeW _ _ = panic "SMRep.hdrSizeW" - -nonHdrSize :: DynFlags -> SMRep -> ByteOff -nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep) - -nonHdrSizeW :: SMRep -> WordOff -nonHdrSizeW (HeapRep _ p np _) = p + np -nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct -nonHdrSizeW (SmallArrayPtrsRep elems) = elems -nonHdrSizeW (ArrayWordsRep words) = words -nonHdrSizeW (StackRep bs) = length bs -nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep - --- | The total size of the closure, in words. -heapClosureSizeW :: DynFlags -> SMRep -> WordOff -heapClosureSizeW dflags (HeapRep _ p np ty) - = closureTypeHdrSize dflags ty + p + np -heapClosureSizeW dflags (ArrayPtrsRep elems ct) - = arrPtrsHdrSizeW dflags + elems + ct -heapClosureSizeW dflags (SmallArrayPtrsRep elems) - = smallArrPtrsHdrSizeW dflags + elems -heapClosureSizeW dflags (ArrayWordsRep words) - = arrWordsHdrSizeW dflags + words -heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" - -closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff -closureTypeHdrSize dflags ty = case ty of - Thunk -> thunkHdrSize dflags - ThunkSelector{} -> thunkHdrSize dflags - BlackHole -> thunkHdrSize dflags - IndStatic -> thunkHdrSize dflags - _ -> fixedHdrSizeW dflags - -- All thunks use thunkHdrSize, even if they are non-updatable. - -- this is because we don't have separate closure types for - -- updatable vs. non-updatable thunks, so the GC can't tell the - -- difference. If we ever have significant numbers of non- - -- updatable thunks, it might be worth fixing this. - --- --------------------------------------------------------------------------- --- Arrays - --- | The byte offset into the card table of the card for a given element -card :: DynFlags -> Int -> Int -card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags - --- | Convert a number of elements to a number of cards, rounding up -cardRoundUp :: DynFlags -> Int -> Int -cardRoundUp dflags i = - card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) - --- | The size of a card table, in bytes -cardTableSizeB :: DynFlags -> Int -> ByteOff -cardTableSizeB dflags elems = cardRoundUp dflags elems - --- | The size of a card table, in words -cardTableSizeW :: DynFlags -> Int -> WordOff -cardTableSizeW dflags elems = - bytesToWordsRoundUp dflags (cardTableSizeB dflags elems) - ------------------------------------------------------------------------------ --- deriving the RTS closure type from an SMRep - -#include "../includes/rts/storage/ClosureTypes.h" -#include "../includes/rts/storage/FunTypes.h" --- Defines CONSTR, CONSTR_1_0 etc - --- | Derives the RTS closure type from an 'SMRep' -rtsClosureType :: SMRep -> Int -rtsClosureType rep - = case rep of - RTSRep ty _ -> ty - - -- See Note [static constructors] - HeapRep _ 1 0 Constr{} -> CONSTR_1_0 - HeapRep _ 0 1 Constr{} -> CONSTR_0_1 - HeapRep _ 2 0 Constr{} -> CONSTR_2_0 - HeapRep _ 1 1 Constr{} -> CONSTR_1_1 - HeapRep _ 0 2 Constr{} -> CONSTR_0_2 - HeapRep _ 0 _ Constr{} -> CONSTR_NOCAF - -- See Note [Static NoCaf constructors] - HeapRep _ _ _ Constr{} -> CONSTR - - HeapRep False 1 0 Fun{} -> FUN_1_0 - HeapRep False 0 1 Fun{} -> FUN_0_1 - HeapRep False 2 0 Fun{} -> FUN_2_0 - HeapRep False 1 1 Fun{} -> FUN_1_1 - HeapRep False 0 2 Fun{} -> FUN_0_2 - HeapRep False _ _ Fun{} -> FUN - - HeapRep False 1 0 Thunk -> THUNK_1_0 - HeapRep False 0 1 Thunk -> THUNK_0_1 - HeapRep False 2 0 Thunk -> THUNK_2_0 - HeapRep False 1 1 Thunk -> THUNK_1_1 - HeapRep False 0 2 Thunk -> THUNK_0_2 - HeapRep False _ _ Thunk -> THUNK - - HeapRep False _ _ ThunkSelector{} -> THUNK_SELECTOR - - HeapRep True _ _ Fun{} -> FUN_STATIC - HeapRep True _ _ Thunk -> THUNK_STATIC - HeapRep False _ _ BlackHole -> BLACKHOLE - HeapRep False _ _ IndStatic -> IND_STATIC - - _ -> panic "rtsClosureType" - --- We export these ones -rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int -rET_SMALL = RET_SMALL -rET_BIG = RET_BIG -aRG_GEN = ARG_GEN -aRG_GEN_BIG = ARG_GEN_BIG - -{- -Note [static constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We used to have a CONSTR_STATIC closure type, and each constructor had -two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with -CONSTR_STATIC. - -This distinction was removed, because when copying a data structure -into a compact region, we must copy static constructors into the -compact region too. If we didn't do this, we would need to track the -references from the compact region out to the static constructors, -because they might (indirectly) refer to CAFs. - -Since static constructors will be copied to the heap, if we wanted to -use different info tables for static and dynamic constructors, we -would have to switch the info pointer when copying the constructor -into the compact region, which means we would need an extra field of -the static info table to point to the dynamic one. - -However, since the distinction between static and dynamic closure -types is never actually needed (other than for assertions), we can -just drop the distinction and use the same info table for both. - -The GC *does* need to distinguish between static and dynamic closures, -but it does this using the HEAP_ALLOCED() macro which checks whether -the address of the closure resides within the dynamic heap. -HEAP_ALLOCED() doesn't read the closure's info table. - -Note [Static NoCaf constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we know that a top-level binding 'x' is not Caffy (ie no CAFs are -reachable from 'x'), then a statically allocated constructor (Just x) -is also not Caffy, and the garbage collector need not follow its -argument fields. Exploiting this would require two static info tables -for Just, for the two cases where the argument was Caffy or non-Caffy. - -Currently we don't do this; instead we treat nullary constructors -as non-Caffy, and the others as potentially Caffy. - - -************************************************************************ -* * - Pretty printing of SMRep and friends -* * -************************************************************************ --} - -instance Outputable ClosureTypeInfo where - ppr = pprTypeInfo - -instance Outputable SMRep where - ppr (HeapRep static ps nps tyinfo) - = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace) - where - header = text "HeapRep" - <+> if static then text "static" else empty - <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps - pp_n :: String -> Int -> SDoc - pp_n _ 0 = empty - pp_n s n = int n <+> text s - - ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size - - ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size - - ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words - - ppr (StackRep bs) = text "StackRep" <+> ppr bs - - ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep - -instance Outputable ArgDescr where - ppr (ArgSpec n) = text "ArgSpec" <+> ppr n - ppr (ArgGen ls) = text "ArgGen" <+> ppr ls - -pprTypeInfo :: ClosureTypeInfo -> SDoc -pprTypeInfo (Constr tag descr) - = text "Con" <+> - braces (sep [ text "tag:" <+> ppr tag - , text "descr:" <> text (show descr) ]) - -pprTypeInfo (Fun arity args) - = text "Fun" <+> - braces (sep [ text "arity:" <+> ppr arity - , ptext (sLit ("fun_type:")) <+> ppr args ]) - -pprTypeInfo (ThunkSelector offset) - = text "ThunkSel" <+> ppr offset - -pprTypeInfo Thunk = text "Thunk" -pprTypeInfo BlackHole = text "BlackHole" -pprTypeInfo IndStatic = text "IndStatic" 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 diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 526115d5ef..8e4d82a0f3 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -846,6 +846,6 @@ Here are the moving parts: it in the code generators, but it seems simpler to do it once and for all in CoreToSTG. - In ByteCodeAsm we just lower it as a 0 literal, because + In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's all boxed and lifted to the host GC anyway. -} diff --git a/compiler/cbits/keepCAFsForGHCi.c b/compiler/cbits/keepCAFsForGHCi.c new file mode 100644 index 0000000000..ba635b0d95 --- /dev/null +++ b/compiler/cbits/keepCAFsForGHCi.c @@ -0,0 +1,15 @@ +#include + +// This file is only included in the dynamic library. +// It contains an __attribute__((constructor)) function (run prior to main()) +// which sets the keepCAFs flag in the RTS, before any Haskell code is run. +// This is required so that GHCi can use dynamic libraries instead of HSxyz.o +// files. + +static void keepCAFsForGHCi(void) __attribute__((constructor)); + +static void keepCAFsForGHCi(void) +{ + keepCAFs = 1; +} + diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 0092e991ef..3e124b5829 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -14,10 +14,10 @@ module Coverage (addTicksToBinds, hpcInitCode) where import GhcPrelude as Prelude -import qualified GHCi +import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes import Data.Array -import ByteCodeTypes +import GHC.ByteCode.Types import GHC.Stack.CCS import Type import GHC.Hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index c965973403..84a912998f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -156,7 +156,7 @@ Library c-sources: cbits/cutils.c cbits/genSym.c - ghci/keepCAFsForGHCi.c + cbits/keepCAFsForGHCi.c hs-source-dirs: . @@ -165,7 +165,6 @@ Library cmm coreSyn deSugar - ghci iface llvmGen main @@ -304,7 +303,7 @@ Library GHC.StgToCmm.Ticky GHC.StgToCmm.Utils GHC.StgToCmm.ExtCode - GHC.Runtime.Layout + GHC.Runtime.Heap.Layout CoreArity CoreFVs CoreLint @@ -380,13 +379,13 @@ Library GhcMake GhcPlugins GhcPrelude - DynamicLoading HeaderInfo HscMain HscStats HscTypes - InteractiveEval - InteractiveEvalTypes + GHC.Runtime.Eval + GHC.Runtime.Eval.Types + GHC.Runtime.Loader UnitInfo Packages PlatformConstants @@ -650,14 +649,14 @@ Library Dwarf.Types Dwarf.Constants GHC.ThToHs - ByteCodeTypes - ByteCodeAsm - ByteCodeGen - ByteCodeInstr - ByteCodeItbls - ByteCodeLink - Debugger - LinkerTypes - Linker - RtClosureInspect - GHCi + GHC.ByteCode.Types + GHC.ByteCode.Asm + GHC.ByteCode.Instr + GHC.ByteCode.InfoTable + GHC.ByteCode.Linker + GHC.CoreToByteCode + GHC.Runtime.Debugger + GHC.Runtime.Linker.Types + GHC.Runtime.Linker + GHC.Runtime.Heap.Inspect + GHC.Runtime.Interpreter diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs deleted file mode 100644 index adf701b7e5..0000000000 --- a/compiler/ghci/ByteCodeAsm.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeAsm ( - assembleBCOs, assembleOneBCO, - - bcoFreeNames, - SizedSeq, sizeSS, ssElts, - iNTERP_STACK_CHECK_THRESH - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeInstr -import ByteCodeItbls -import ByteCodeTypes -import GHCi.RemoteTypes -import GHCi - -import HscTypes -import Name -import NameSet -import Literal -import TyCon -import FastString -import GHC.StgToCmm.Layout ( ArgRep(..) ) -import GHC.Runtime.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 "ByteCodeAsm.literal: LitNumInteger" - LitNumNatural -> panic "ByteCodeAsm.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/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs deleted file mode 100644 index 5d5b2990e6..0000000000 --- a/compiler/ghci/ByteCodeGen.hs +++ /dev/null @@ -1,2036 +0,0 @@ -{-# 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 --- - --- | ByteCodeGen: Generate bytecode from Core -module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeInstr -import ByteCodeAsm -import ByteCodeTypes - -import GHCi -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.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 "ByteCodeGen"<+>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 "ByteCodeGen.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 "ByteCodeGen"<+>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 "ByteCodeGen.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 $ "ByteCodeGen.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 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 "ByteCodeGen.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 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# 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 "ByteCodeGen.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 "ByteCodeGen.generateCCall: missing or invalid World token?" - | otherwise - = reverse (tail a_reps_pushed_r_to_l) - - -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. - -- push_args is the code to do that. - -- d_after_args is the stack depth once the args are on. - - -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, 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): - - - ... - - Addr# address_of_C_fn - (must be an unboxed type) - - The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), - 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 "ByteCodeGen.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 "ByteCodeGen: 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 - JMP L_Exit - - L1: TESTEQ_I 1 L2 - PUSH_G - JMP L_Exit - ...etc... - Ln: TESTEQ_I n L_fail - PUSH_G - 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 "ByteCodeGen.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 "ByteCodeGen.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/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs deleted file mode 100644 index 9cdd297dbd..0000000000 --- a/compiler/ghci/ByteCodeInstr.hs +++ /dev/null @@ -1,373 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -funbox-strict-fields #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeInstrs: Bytecode instruction definitions -module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeTypes -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.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 "" - --- ----------------------------------------------------------------------------- --- 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/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs deleted file mode 100644 index 2138482051..0000000000 --- a/compiler/ghci/ByteCodeItbls.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes -module ByteCodeItbls ( mkITbls ) where - -#include "HsVersions.h" - -import GhcPrelude - -import ByteCodeTypes -import GHCi -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/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs deleted file mode 100644 index 9138d1c125..0000000000 --- a/compiler/ghci/ByteCodeLink.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | ByteCodeLink: Bytecode assembler and linker -module ByteCodeLink ( - 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 GHCi -import ByteCodeTypes -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 "ByteCodeLink: 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 "ByteCodeLink.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 "ByteCodeLink.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 "ByteCodeLink.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/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs deleted file mode 100644 index 0c0c34ad64..0000000000 --- a/compiler/ghci/ByteCodeTypes.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | Bytecode assembler types -module ByteCodeTypes - ( 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 compiler/main/InteractiveEval.hs - --- 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/ghci/Debugger.hs b/compiler/ghci/Debugger.hs deleted file mode 100644 index 7bfc4eff4c..0000000000 --- a/compiler/ghci/Debugger.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# 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 Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where - -import GhcPrelude - -import Linker -import RtClosureInspect - -import GHCi -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/ghci/GHCi.hs b/compiler/ghci/GHCi.hs deleted file mode 100644 index 8795b30973..0000000000 --- a/compiler/ghci/GHCi.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-} - --- --- | Interacting with the interpreter, whether it is running on an --- external process or in the current process. --- -module GHCi - ( -- * 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 (GHCi) 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) 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/ghci/Linker.hs b/compiler/ghci/Linker.hs deleted file mode 100644 index 773d396ac9..0000000000 --- a/compiler/ghci/Linker.hs +++ /dev/null @@ -1,1707 +0,0 @@ -{-# 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 Linker ( getHValue, showLinkerState, - linkExpr, linkDecls, unload, withExtendedLinkEnv, - extendLinkEnv, deleteFromLinkEnv, - extendLoadedPkgs, - linkPackages, initDynLinker, linkModule, - linkCmdLineLibs, - uninitializedLinker - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import GHCi -import GHCi.RemoteTypes -import GHC.Iface.Load -import ByteCodeLink -import ByteCodeAsm -import ByteCodeTypes -import TcRnMonad -import Packages -import DriverPhases -import Finder -import HscTypes -import Name -import NameEnv -import Module -import ListSetOps -import LinkerTypes (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 "ByteCodeLink.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/ghci/LinkerTypes.hs b/compiler/ghci/LinkerTypes.hs deleted file mode 100644 index 4cdfc198da..0000000000 --- a/compiler/ghci/LinkerTypes.hs +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------ --- --- Types for the Dynamic Linker --- --- (c) The University of Glasgow 2019 --- ------------------------------------------------------------------------------ - -module LinkerTypes ( - 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 ByteCodeTypes ( 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/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs deleted file mode 100644 index 9ed5eaef9f..0000000000 --- a/compiler/ghci/RtClosureInspect.hs +++ /dev/null @@ -1,1355 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-} - ------------------------------------------------------------------------------ --- --- GHC Interactive support for inspecting arbitrary closures at runtime --- --- Pepe Iborra (supported by Google SoC) 2006 --- ------------------------------------------------------------------------------ -module RtClosureInspect( - -- * 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 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.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("") - | 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 "" - | t == stableNamePrimTyCon = text "" - | t == statePrimTyCon = text "" - | t == proxyPrimTyCon = text "" - | t == realWorldTyCon = text "" - | t == threadIdPrimTyCon = text "" - | t == weakPrimTyCon = text "" - | t == arrayPrimTyCon = text "" - | t == smallArrayPrimTyCon = text "" - | t == byteArrayPrimTyCon = text "" - | t == mutableArrayPrimTyCon = text "" - | t == smallMutableArrayPrimTyCon = text "" - | t == mutableByteArrayPrimTyCon = text "" - | t == mutVarPrimTyCon = text "" - | t == mVarPrimTyCon = text "" - | t == tVarPrimTyCon = text "" - | 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: - - = - -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 --- 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/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c deleted file mode 100644 index ba635b0d95..0000000000 --- a/compiler/ghci/keepCAFsForGHCi.c +++ /dev/null @@ -1,15 +0,0 @@ -#include - -// This file is only included in the dynamic library. -// It contains an __attribute__((constructor)) function (run prior to main()) -// which sets the keepCAFs flag in the RTS, before any Haskell code is run. -// This is required so that GHCi can use dynamic libraries instead of HSxyz.o -// files. - -static void keepCAFsForGHCi(void) __attribute__((constructor)); - -static void keepCAFsForGHCi(void) -{ - keepCAFs = 1; -} - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1ca0f0bb17..2276559cd6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1106,7 +1106,7 @@ data DynFlags = DynFlags { -- loaded here is directed by pluginModNames. Arguments are loaded from -- pluginModNameOpts. The purpose of this field is to cache the plugins so -- they don't have to be loaded each time they are needed. See - -- 'DynamicLoading.initializePlugins'. + -- 'GHC.Runtime.Loader.initializePlugins'. staticPlugins :: [StaticPlugin], -- ^ static plugins which do not need dynamic loading. These plugins are -- intended to be added by GHC API users directly to this list. diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs deleted file mode 100644 index a48f0238be..0000000000 --- a/compiler/main/DynamicLoading.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | Dynamically lookup up values from modules and loading them. -module DynamicLoading ( - initializePlugins, - -- * Loading plugins - loadFrontendPlugin, - - -- * Force loading information - forceLoadModuleInterfaces, - forceLoadNameModuleInterface, - forceLoadTyCon, - - -- * Finding names - lookupRdrNameInModuleForPlugins, - - -- * Loading values - getValueSafely, - getHValueSafely, - lessUnsafeCoerce - ) where - -import GhcPrelude -import DynFlags - -import Linker ( linkModule, getHValue ) -import GHCi ( 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/main/GHC.hs b/compiler/main/GHC.hs index 1510947e7b..49017611ce 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -132,7 +132,7 @@ module GHC ( -- ** Compiling expressions HValue, parseExpr, compileParsedExpr, - InteractiveEval.compileExpr, dynCompileExpr, + GHC.Runtime.Eval.compileExpr, dynCompileExpr, ForeignHValue, compileExprRemote, compileParsedExprRemote, @@ -154,8 +154,8 @@ module GHC ( modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), - InteractiveEval.back, - InteractiveEval.forward, + GHC.Runtime.Eval.back, + GHC.Runtime.Eval.forward, -- * Abstract syntax elements @@ -295,10 +295,10 @@ module GHC ( import GhcPrelude hiding (init) -import ByteCodeTypes -import InteractiveEval -import InteractiveEvalTypes -import GHCi +import GHC.ByteCode.Types +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Types +import GHC.Runtime.Interpreter import GHCi.RemoteTypes import PprTyThing ( pprFamInst ) @@ -1526,15 +1526,15 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> - return $ InteractiveEval.getHistorySpan hsc_env h + return $ GHC.Runtime.Eval.getHistorySpan hsc_env h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a + liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term obtainTermFromId bound force id = withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id + liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0f1e5cdc4b..2a597a205d 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -35,7 +35,7 @@ module GhcMake( import GhcPrelude -import qualified Linker ( unload ) +import qualified GHC.Runtime.Linker as Linker import DriverPhases import DriverPipeline diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8ce49e4aab..8e7a9db87a 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -89,10 +89,10 @@ import GhcPrelude import Data.Data hiding (Fixity, TyCon) import Data.Maybe ( fromJust ) import Id -import GHCi ( addSptEntry ) +import GHC.Runtime.Interpreter ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) -import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import Linker +import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) +import GHC.Runtime.Linker import CoreTidy ( tidyExpr ) import Type ( Type ) import {- Kind parts of -} Type ( Kind ) @@ -147,7 +147,7 @@ import Hooks import TcEnv import PrelNames import Plugins -import DynamicLoading ( initializePlugins ) +import GHC.Runtime.Loader ( initializePlugins ) import DynFlags import ErrUtils diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index b43c41db2a..33f827e2c6 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -155,8 +155,8 @@ module HscTypes ( import GhcPrelude -import ByteCodeTypes -import InteractiveEvalTypes ( Resume ) +import GHC.ByteCode.Types +import GHC.Runtime.Eval.Types ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes import GHC.ForeignSrcLang @@ -190,7 +190,7 @@ import TysWiredIn import Packages hiding ( Version(..) ) import CmdLineParser import DynFlags -import LinkerTypes ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) import DriverPhases ( Phase, HscSource(..), hscSourceString , isHsBootOrSig, isHsigFile ) import qualified DriverPhases as Phase @@ -1680,7 +1680,7 @@ data InteractiveContext ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The cached 'GlobalRdrEnv', built by - -- 'InteractiveEval.setContext' and updated regularly + -- 'GHC.Runtime.Eval.setContext' and updated regularly -- It contains everything in scope at the command line, -- including everything in ic_tythings diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs deleted file mode 100644 index badb746718..0000000000 --- a/compiler/main/InteractiveEval.hs +++ /dev/null @@ -1,1271 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, - RecordWildCards, BangPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEval ( - 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 InteractiveEvalTypes - -import 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 ByteCodeTypes -import 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 RtClosureInspect -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 = "" - , 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 "" 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 "") - 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, "") - --- 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 `compiler/main/InteractiveEval.hs: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 `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates - the Id list) doesn't find an Id in the ByteCode environement. - 2.) If function `compiler/main/InteractiveEval.hs: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 "") 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/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs deleted file mode 100644 index 3bc043f88b..0000000000 --- a/compiler/main/InteractiveEvalTypes.hs +++ /dev/null @@ -1,89 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005-2007 --- --- Running statements interactively --- --- ----------------------------------------------------------------------------- - -module InteractiveEvalTypes ( - 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/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index b8fb162432..026631df37 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -52,7 +52,7 @@ import SrcLoc import Util import Module import Plugins ( withPlugins, installCoreToDos ) -import DynamicLoading -- ( initializePlugins ) +import GHC.Runtime.Loader -- ( initializePlugins ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import UniqFM diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 9557efa40c..3fd70d0a2b 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -2946,7 +2946,7 @@ Note [Runtime skolems] ~~~~~~~~~~~~~~~~~~~~~~ We want to give a reasonably helpful error message for ambiguity arising from *runtime* skolems in the debugger. These -are created by in RtClosureInspect.zonkRTTIType. +are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. ************************************************************************ * * diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 566db1c1df..485948a5a3 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -57,7 +57,7 @@ import Control.Monad import GHCi.Message import GHCi.RemoteTypes -import GHCi +import GHC.Runtime.Interpreter import HscMain -- These imports are the reason that TcSplice -- is very high up the module hierarchy diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 4cec96a847..ac3820884e 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -1025,7 +1025,7 @@ isMetaTyVar tv -- isAmbiguousTyVar is used only when reporting type errors -- It picks out variables that are unbound, namely meta -- type variables and the RuntimUnk variables created by --- RtClosureInspect.zonkRTTIType. These are "ambiguous" in +-- GHC.Runtime.Heap.Inspect.zonkRTTIType. These are "ambiguous" in -- the sense that they stand for an as-yet-unknown type isAmbiguousTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index f49c1834d3..6bca4e8dba 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -33,10 +33,10 @@ import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' ) import GHCi.UI.Monad hiding ( args, runStmt ) import GHCi.UI.Tags import GHCi.UI.Info -import Debugger +import GHC.Runtime.Debugger -- The GHC interface -import GHCi +import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHCi.BreakArray import DynFlags @@ -68,7 +68,7 @@ import qualified Lexer import StringBuffer import Outputable hiding ( printForUser, printForUserPartWay ) -import DynamicLoading ( initializePlugins ) +import GHC.Runtime.Loader ( initializePlugins ) -- Other random utilities import BasicTypes hiding ( isTopLevel ) @@ -76,7 +76,7 @@ import Config import Digraph import Encoding import FastString -import Linker +import GHC.Runtime.Linker import Maybes ( orElse, expectJust ) import NameSet import Panic hiding ( showException ) @@ -3153,7 +3153,7 @@ ticket contains an analysis of the situation and suggests the solution implemented above. The same filter was also implemented to fix #11051 [3]. See the -Note [What to show to users] in compiler/main/InteractiveEval.hs +Note [What to show to users] in GHC.Runtime.Eval [1] https://gitlab.haskell.org/ghc/ghc/issues/12525 [2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489 diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 63356d6418..6bd584bbe6 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -48,7 +48,7 @@ import SrcLoc import Module import RdrName (mkOrig) import PrelNames (gHC_GHCI_HELPERS) -import GHCi +import GHC.Runtime.Interpreter import GHCi.RemoteTypes import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl) import GHC.Hs.Utils diff --git a/ghc/Main.hs b/ghc/Main.hs index 6514a00345..c30109d5aa 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -33,10 +33,10 @@ import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) #endif -- Frontend plugins -import DynamicLoading ( loadFrontendPlugin ) +import GHC.Runtime.Loader ( loadFrontendPlugin ) import Plugins #if defined(HAVE_INTERNAL_INTERPRETER) -import DynamicLoading ( initializePlugins ) +import GHC.Runtime.Loader ( initializePlugins ) #endif import Module ( ModuleName ) diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h index e5d55f694f..f7a0d6f151 100644 --- a/includes/rts/Bytecodes.h +++ b/includes/rts/Bytecodes.h @@ -17,7 +17,7 @@ /* NOTE: - THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeAsm.hs). + THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/GHC/ByteCode/Asm.hs). DO NOT PUT C-SPECIFIC STUFF IN HERE! I hope that's clear :-) diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 0843b95b37..e69e28ecaf 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -72,7 +72,7 @@ RTS_RET(stg_restore_cccs_eval); // RTS_FUN(stg_interp_constr6_entry); // RTS_FUN(stg_interp_constr7_entry); // -// This is referenced using the FFI in the compiler (ByteCodeItbls), +// This is referenced using the FFI in the compiler (GHC.ByteCode.InfoTable), // so we can't give it the correct type here because the prototypes // would clash (FFI references are always declared with type StgWord[] // in the generated C code). diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs index 4865dd60c9..c1f2376729 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap.hs @@ -122,7 +122,7 @@ getClosureRaw x = do ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers pure (Ptr iptr, rawWds, ptrList) --- From compiler/ghci/RtClosureInspect.hs +-- From GHC.Runtime.Heap.Inspect amap' :: (t -> b) -> Array Int t -> [b] amap' f (Array i0 i _ arr#) = map g [0 .. i - i0] where g (I# i#) = case indexArray# arr# i# of @@ -145,7 +145,7 @@ getClosure x = do case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF -> do (p, m, n) <- dataConNames iptr - if m == "ByteCodeInstr" && n == "BreakInfo" + if m == "GHC.ByteCode.Instr" && n == "BreakInfo" then pure $ UnsupportedClosure itbl else pure $ ConstrClosure itbl pts npts p m n diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index 8ab813a5a7..a0f9d03bdc 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -19,7 +19,7 @@ module GHCi.BreakArray ( BreakArray - (BA) -- constructor is exported only for ByteCodeGen + (BA) -- constructor is exported only for GHC.CoreToByteCode , newBreakArray , getBreak , setBreakOn diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs index 44a2964895..cc94089828 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -159,7 +159,7 @@ data Integer = S# !Int# -- ^ iff value in @]-inf, minBound::'Int'[@ range -- NOTE: the above representation is baked into the GHCi debugger in --- compiler/ghci/RtClosureInspect.hs. If you change it here, fixes +-- GHC.Runtime.Heap.Inspect. If you change it here, fixes -- will be required over there too. Tests for this are in -- testsuite/tests/ghci.debugger. diff --git a/rts/Disassembler.c b/rts/Disassembler.c index 01d6c3b1d9..d5593c8a07 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -324,7 +324,7 @@ disInstr ( StgBCO *bco, int pc ) /* Something of a kludge .. how do we know where the end of the insn array is, since it isn't recorded anywhere? Answer: the first short is the number of bytecodes which follow it. - See ByteCodeGen.linkBCO.insns_arr for construction ... + See GHC.CoreToByteCode.linkBCO.insns_arr for construction ... */ void disassemble( StgBCO *bco ) { diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 78a958d5ec..e1f6fab93a 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -2109,7 +2109,7 @@ stg_mkApUpd0zh ( P_ bco ) W_ ap; // This function is *only* used to wrap zero-arity BCOs in an - // updatable wrapper (see ByteCodeLink.hs). An AP thunk is always + // updatable wrapper (see GHC.ByteCode.Linker). An AP thunk is always // saturated and always points directly to a FUN or BCO. ASSERT(%INFO_TYPE(%GET_STD_INFO(bco)) == HALF_W_(BCO) && StgBCO_arity(bco) == HALF_W_(0)); diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs index 85777bfe72..1c8d6e2155 100644 --- a/testsuite/tests/codeGen/should_run/T13825-unit.hs +++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs @@ -2,7 +2,7 @@ module Main where import DynFlags import GHC.Types.RepType -import GHC.Runtime.Layout +import GHC.Runtime.Heap.Layout import GHC.StgToCmm.Layout import GHC.StgToCmm.Closure import GHC diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs index 62edae0e78..feb792862b 100644 --- a/testsuite/tests/ghc-api/T4891/T4891.hs +++ b/testsuite/tests/ghc-api/T4891/T4891.hs @@ -1,15 +1,15 @@ {-# LANGUAGE BangPatterns #-} module Main where -import ByteCodeLink +import GHC.ByteCode.Linker import CoreMonad import Data.Array import DataCon import GHC import GHC.Exts.Heap import HscTypes -import Linker -import RtClosureInspect +import GHC.Runtime.Linker +import GHC.Runtime.Heap.Inspect import TcEnv import Type import TcRnMonad diff --git a/testsuite/tests/ghci/should_run/ghcirun004.hs b/testsuite/tests/ghci/should_run/ghcirun004.hs index f3e3095275..1a1c474427 100644 --- a/testsuite/tests/ghci/should_run/ghcirun004.hs +++ b/testsuite/tests/ghci/should_run/ghcirun004.hs @@ -1,5 +1,5 @@ -- crashes in 7.2.1 and earlier, due to bogus calculations of label --- offsets in ByteCodeAsm for a BCO with large instructions. +-- offsets in GHC.ByteCode.Asm for a BCO with large instructions. main = print (map foo [1,50..5000] ) diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs index 9d6b243256..d26fae57ea 100644 --- a/testsuite/tests/rts/linker/LinkerUnload.hs +++ b/testsuite/tests/rts/linker/LinkerUnload.hs @@ -2,7 +2,7 @@ module LinkerUnload (init) where import GHC import DynFlags -import Linker +import GHC.Runtime.Linker as Linker import System.Environment import MonadUtils ( MonadIO(..) ) diff --git a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr index 30d756f058..3ec6cb6ca5 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr +++ b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2: ^^ Could not load 'c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 index 1b32baf67e..5304e84a37 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 +++ b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2.exe: ^^ Could not load '_c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 index d38e1c00ec..5396070515 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 +++ b/testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2.exe: ^^ Could not load 'c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr index 0f54eab090..b5d1872a8d 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr +++ b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2: ^^ Could not load 'c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32 b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32 index 6226dda848..fcf9f6cbd9 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32 +++ b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32 @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2.exe: ^^ Could not load '_c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-64-mingw32 b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-64-mingw32 index 5b9103e606..84742a8271 100644 --- a/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-64-mingw32 +++ b/testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-64-mingw32 @@ -12,7 +12,7 @@ This could be caused by: ghc-stage2.exe: ^^ Could not load 'c', dependency unresolved. See top entry above. -ByteCodeLink: can't find label +GHC.ByteCode.Linker: can't find label During interactive linking, GHCi couldn't find the following symbol: c This may be due to you not asking GHCi to load extra object files, diff --git a/utils/haddock b/utils/haddock index e7a650a94d..d838d08f0a 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit e7a650a94dbc118c423e684b27203a52baf34ff5 +Subproject commit d838d08f0ac0173dc704d51191b1c1976964b6f1 -- cgit v1.2.1