ghc-lib 9.2.7.20230228 → 9.2.8.20230729

raw patch · 21 files changed

+3/−4157 lines, 21 filesdep ~ghc-lib-parserdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-lib-parser, transformers

API changes (from Hackage documentation)

Files

• compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +0/−164
• compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +0/−99
• compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +0/−161
• compiler/GHC/Driver/Backpack.hs +0/−908
• compiler/GHC/Driver/MakeFile.hs +0/−454
• compiler/GHC/Linker.hs +0/−36
• compiler/GHC/Plugins.hs +0/−175
• compiler/GHC/Runtime/Debugger.hs +0/−250
• compiler/GHC/Tc/Plugin.hs +0/−190
• ghc-lib.cabal +3/−25
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs +0/−12
• libraries/ghc-boot/GHC/HandleEncoding.hs +0/−32
• libraries/ghci/GHCi/CreateBCO.hs +0/−205
• libraries/ghci/GHCi/InfoTable.hsc +0/−432
• libraries/ghci/GHCi/ObjLink.hs +0/−195
• libraries/ghci/GHCi/Run.hs +0/−398
• libraries/ghci/GHCi/Signals.hs +0/−47
• libraries/ghci/GHCi/StaticPtrTable.hs +0/−25
• libraries/ghci/GHCi/TH.hs +0/−272
• libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +0/−20
• libraries/template-haskell/Language/Haskell/TH/Quote.hs +0/−57

@@ -1,164 +0,0 @@---- | Utils for calculating general worst, bound, squeese and free, functions.------   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"---           Michael Smith, Normal Ramsey, Glenn Holloway.---           PLDI 2004------   These general versions are not used in GHC proper because they are too slow.---   Instead, hand written optimised versions are provided for each architecture---   in MachRegs*.hs------   This code is here because we can test the architecture specific code against---   it.----module GHC.CmmToAsm.Reg.Graph.Base (-        RegClass(..),-        Reg(..),-        RegSub(..),--        worst,-        bound,-        squeese-) where--import GHC.Prelude--import GHC.Types.Unique.Set-import GHC.Types.Unique.FM-import GHC.Types.Unique-import GHC.Builtin.Uniques-import GHC.Utils.Monad (concatMapM)----- Some basic register classes.---      These aren't necessarily in 1-to-1 correspondence with the allocatable---      RegClasses in MachRegs.hs-data RegClass-        -- general purpose regs-        = ClassG32      -- 32 bit GPRs-        | ClassG16      -- 16 bit GPRs-        | ClassG8       -- 8  bit GPRs--        -- floating point regs-        | ClassF64      -- 64 bit FPRs-        deriving (Show, Eq, Enum)----- | A register of some class-data Reg-        -- a register of some class-        = Reg RegClass Int--        -- a sub-component of one of the other regs-        | RegSub RegSub Reg-        deriving (Show, Eq)----- | so we can put regs in UniqSets-instance Uniquable Reg where-        getUnique (Reg c i)-         = mkRegSingleUnique-         $ fromEnum c * 1000 + i--        getUnique (RegSub s (Reg c i))-         = mkRegSubUnique-         $ fromEnum s * 10000 + fromEnum c * 1000 + i--        getUnique (RegSub _ (RegSub _ _))-          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."----- | A subcomponent of another register-data RegSub-        = SubL16        -- lowest 16 bits-        | SubL8         -- lowest  8 bits-        | SubL8H        -- second lowest 8 bits-        deriving (Show, Enum, Ord, Eq)----- | Worst case displacement------      a node N of classN has some number of neighbors,---      all of which are from classC.------      (worst neighbors classN classC) is the maximum number of potential---      colors for N that can be lost by coloring its neighbors.------ This should be hand coded/cached for each particular architecture,---      because the compute time is very long..-worst   :: (RegClass    -> UniqSet Reg)-        -> (Reg         -> UniqSet Reg)-        -> Int -> RegClass -> RegClass -> Int--worst regsOfClass regAlias neighbors classN classC- = let  regAliasS regs  = unionManyUniqSets-                        $ map regAlias-                        $ nonDetEltsUniqSet regs-                        -- This is non-deterministic but we do not-                        -- currently support deterministic code-generation.-                        -- See Note [Unique Determinism and code generation]--        -- all the regs in classes N, C-        regsN           = regsOfClass classN-        regsC           = regsOfClass classC--        -- all the possible subsets of c which have size < m-        regsS           = filter (\s -> sizeUniqSet s >= 1-                                     && sizeUniqSet s <= neighbors)-                        $ powersetLS regsC--        -- for each of the subsets of C, the regs which conflict-        -- with posiblities for N-        regsS_conflict-                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS--  in    maximum $ map sizeUniqSet $ regsS_conflict----- | For a node N of classN and neighbors of classesC---      (bound classN classesC) is the maximum number of potential---      colors for N that can be lost by coloring its neighbors.-bound   :: (RegClass    -> UniqSet Reg)-        -> (Reg         -> UniqSet Reg)-        -> RegClass -> [RegClass] -> Int--bound regsOfClass regAlias classN classesC- = let  regAliasS regs  = unionManyUniqSets-                        $ map regAlias-                        $ nonDetEltsUFM regs-                        -- See Note [Unique Determinism and code generation]--        regsC_aliases-                = unionManyUniqSets-                $ map (regAliasS . getUniqSet . regsOfClass) classesC--        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases--   in   sizeUniqSet overlap----- | The total squeese on a particular node with a list of neighbors.------   A version of this should be constructed for each particular architecture,---   possibly including uses of bound, so that aliased registers don't get---   counted twice, as per the paper.-squeese :: (RegClass    -> UniqSet Reg)-        -> (Reg         -> UniqSet Reg)-        -> RegClass -> [(Int, RegClass)] -> Int--squeese regsOfClass regAlias classN countCs-        = sum-        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)-        $ countCs----- | powerset (for lists)-powersetL :: [a] -> [[a]]-powersetL       = concatMapM (\x -> [[],[x]])----- | powersetLS (list of sets)-powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]-powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s-  -- See Note [Unique Determinism and code generation]

@@ -1,99 +0,0 @@--- | Register coalescing.-module GHC.CmmToAsm.Reg.Graph.Coalesce (-        regCoalesce,-        slurpJoinMovs-) where-import GHC.Prelude--import GHC.CmmToAsm.Reg.Liveness-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg--import GHC.Cmm-import GHC.Data.Bag-import GHC.Data.Graph.Directed-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Types.Unique.Supply----- | Do register coalescing on this top level thing------   For Reg -> Reg moves, if the first reg dies at the same time the---   second reg is born then the mov only serves to join live ranges.---   The two regs can be renamed to be the same and the move instruction---   safely erased.-regCoalesce-        :: Instruction instr-        => [LiveCmmDecl statics instr]-        -> UniqSM [LiveCmmDecl statics instr]--regCoalesce code- = do-        let joins       = foldl' unionBags emptyBag-                        $ map slurpJoinMovs code--        let alloc       = foldl' buildAlloc emptyUFM-                        $ bagToList joins--        let patched     = map (patchEraseLive (sinkReg alloc)) code--        return patched----- | Add a v1 = v2 register renaming to the map.---   The register with the lowest lexical name is set as the---   canonical version.-buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg-buildAlloc fm (r1, r2)- = let  rmin    = min r1 r2-        rmax    = max r1 r2-   in   addToUFM fm rmax rmin----- | Determine the canonical name for a register by following---   v1 = v2 renamings in this map.-sinkReg :: UniqFM Reg Reg -> Reg -> Reg-sinkReg fm r- = case lookupUFM fm r of-        Nothing -> r-        Just r' -> sinkReg fm r'----- | Slurp out mov instructions that only serve to join live ranges.------   During a mov, if the source reg dies and the destination reg is---   born then we can rename the two regs to the same thing and---   eliminate the move.-slurpJoinMovs-        :: Instruction instr-        => LiveCmmDecl statics instr-        -> Bag (Reg, Reg)--slurpJoinMovs live-        = slurpCmm emptyBag live- where-        slurpCmm   rs  CmmData{}-         = rs--        slurpCmm   rs (CmmProc _ _ _ sccs)-         = foldl' slurpBlock rs (flattenSCCs sccs)--        slurpBlock rs (BasicBlock _ instrs)-         = foldl' slurpLI    rs instrs--        slurpLI    rs (LiveInstr _      Nothing)    = rs-        slurpLI    rs (LiveInstr instr (Just live))-                | Just (r1, r2) <- takeRegRegMoveInstr instr-                , elementOfUniqSet r1 $ liveDieRead live-                , elementOfUniqSet r2 $ liveBorn live--                -- only coalesce movs between two virtuals for now,-                -- else we end up with allocatable regs in the live-                -- regs list..-                , isVirtualReg r1 && isVirtualReg r2-                = consBag (r1, r2) rs--                | otherwise-                = rs-

@@ -1,161 +0,0 @@---- | A description of the register set of the X86.------   This isn't used directly in GHC proper.------   See RegArchBase.hs for the reference.---   See MachRegs.hs for the actual trivColorable function used in GHC.----module GHC.CmmToAsm.Reg.Graph.X86 (-        classOfReg,-        regsOfClass,-        regName,-        regAlias,-        worst,-        squeese,-) where--import GHC.Prelude--import GHC.CmmToAsm.Reg.Graph.Base  (Reg(..), RegSub(..), RegClass(..))-import GHC.Types.Unique.Set--import qualified Data.Array as A----- | Determine the class of a register-classOfReg :: Reg -> RegClass-classOfReg reg- = case reg of-        Reg c _         -> c--        RegSub SubL16 _ -> ClassG16-        RegSub SubL8  _ -> ClassG8-        RegSub SubL8H _ -> ClassG8----- | Determine all the regs that make up a certain class.-regsOfClass :: RegClass -> UniqSet Reg-regsOfClass c- = case c of-        ClassG32-         -> mkUniqSet   [ Reg ClassG32  i-                        | i <- [0..7] ]--        ClassG16-         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)-                        | i <- [0..7] ]--        ClassG8-         -> unionUniqSets-                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])-                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])--        ClassF64-         -> mkUniqSet   [ Reg ClassF64  i-                        | i <- [0..5] ]----- | Determine the common name of a reg---      returns Nothing if this reg is not part of the machine.-regName :: Reg -> Maybe String-regName reg- = case reg of-        Reg ClassG32 i-         | i <= 7 ->-           let names = A.listArray (0,8)-                       [ "eax", "ebx", "ecx", "edx"-                       , "ebp", "esi", "edi", "esp" ]-           in Just $ names A.! i--        RegSub SubL16 (Reg ClassG32 i)-         | i <= 7 ->-           let names = A.listArray (0,8)-                       [ "ax", "bx", "cx", "dx"-                       , "bp", "si", "di", "sp"]-           in Just $ names A.! i--        RegSub SubL8  (Reg ClassG32 i)-         | i <= 3 ->-           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]-           in Just $ names A.! i--        RegSub SubL8H (Reg ClassG32 i)-         | i <= 3 ->-           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]-           in Just $ names A.! i--        _         -> Nothing----- | Which regs alias what other regs.-regAlias :: Reg -> UniqSet Reg-regAlias reg- = case reg of--        -- 32 bit regs alias all of the subregs-        Reg ClassG32 i--         -- for eax, ebx, ecx, eds-         |  i <= 3-         -> mkUniqSet-         $ [ Reg ClassG32 i,   RegSub SubL16 reg-           , RegSub SubL8 reg, RegSub SubL8H reg ]--         -- for esi, edi, esp, ebp-         | 4 <= i && i <= 7-         -> mkUniqSet-         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]--        -- 16 bit subregs alias the whole reg-        RegSub SubL16 r@(Reg ClassG32 _)-         ->     regAlias r--        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg-        RegSub SubL8  r@(Reg ClassG32 _)-         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]--        RegSub SubL8H r@(Reg ClassG32 _)-         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]--        -- fp-        Reg ClassF64 _-         -> unitUniqSet reg--        _ -> error "regAlias: invalid register"----- | Optimised versions of RegColorBase.{worst, squeese} specific to x86-worst :: Int -> RegClass -> RegClass -> Int-worst n classN classC- = case classN of-        ClassG32-         -> case classC of-                ClassG32        -> min n 8-                ClassG16        -> min n 8-                ClassG8         -> min n 4-                ClassF64        -> 0--        ClassG16-         -> case classC of-                ClassG32        -> min n 8-                ClassG16        -> min n 8-                ClassG8         -> min n 4-                ClassF64        -> 0--        ClassG8-         -> case classC of-                ClassG32        -> min (n*2) 8-                ClassG16        -> min (n*2) 8-                ClassG8         -> min n 8-                ClassF64        -> 0--        ClassF64-         -> case classC of-                ClassF64        -> min n 6-                _               -> 0--squeese :: RegClass -> [(Int, RegClass)] -> Int-squeese classN countCs-        = sum (map (\(i, classC) -> worst i classN classC) countCs)-

@@ -1,908 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}----- | This is the driver for the 'ghc --backpack' mode, which--- is a reimplementation of the "package manager" bits of--- Backpack directly in GHC.  The basic method of operation--- is to compile packages and then directly insert them into--- GHC's in memory database.------ The compilation products of this mode aren't really suitable--- for Cabal, because GHC makes up component IDs for the things--- it builds and doesn't serialize out the database contents.--- But it's still handy for constructing tests.--module GHC.Driver.Backpack (doBackpack) where--#include "GhclibHsVersions.h"--import GHC.Prelude---- In a separate module because it hooks into the parser.-import GHC.Driver.Backpack.Syntax-import GHC.Driver.Config-import GHC.Driver.Monad-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Main-import GHC.Driver.Make-import GHC.Driver.Env-import GHC.Driver.Errors--import GHC.Parser-import GHC.Parser.Header-import GHC.Parser.Lexer-import GHC.Parser.Annotation-import GHC.Parser.Errors.Ppr--import GHC hiding (Failed, Succeeded)-import GHC.Tc.Utils.Monad-import GHC.Iface.Recomp-import GHC.Builtin.Names--import GHC.Types.SrcLoc-import GHC.Types.SourceError-import GHC.Types.SourceText-import GHC.Types.SourceFile-import GHC.Types.Unique.FM-import GHC.Types.Unique.DFM-import GHC.Types.Unique.DSet--import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Error-import GHC.Utils.Logger--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.External-import GHC.Unit.State-import GHC.Unit.Finder-import GHC.Unit.Module.Graph-import GHC.Unit.Module.ModSummary-import GHC.Unit.Home.ModInfo--import GHC.Linker.Types--import qualified GHC.LanguageExtensions as LangExt--import GHC.Data.Maybe-import GHC.Data.StringBuffer-import GHC.Data.FastString-import qualified GHC.Data.EnumSet as EnumSet-import qualified GHC.Data.ShortText as ST--import Data.List ( partition )-import System.Exit-import Control.Monad-import System.FilePath-import Data.Version---- for the unification-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Set as Set---- | Entry point to compile a Backpack file.-doBackpack :: [FilePath] -> Ghc ()-doBackpack [src_filename] = do-    logger <- getLogger--    -- Apply options from file to dflags-    dflags0 <- getDynFlags-    let dflags1 = dflags0-    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename-    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts-    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})-    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline-    liftIO $ checkProcessArgsResult unhandled_flags-    liftIO $ handleFlagWarnings logger dflags warns-    -- TODO: Preprocessing not implemented--    buf <- liftIO $ hGetStringBuffer src_filename-    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great-    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of-        PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))-        POk _ pkgname_bkp -> do-            -- OK, so we have an LHsUnit PackageName, but we want an-            -- LHsUnit HsComponentId.  So let's rename it.-            hsc_env <- getSession-            let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp-            initBkpM src_filename bkp $-                forM_ (zip [1..] bkp) $ \(i, lunit) -> do-                    let comp_name = unLoc (hsunitName (unLoc lunit))-                    msgTopPackage (i,length bkp) comp_name-                    innerBkpM $ do-                        let (cid, insts) = computeUnitId lunit-                        if null insts-                            then if cid == Indefinite (UnitId (fsLit "main"))-                                    then compileExe lunit-                                    else compileUnit cid []-                            else typecheckUnit cid insts-doBackpack _ =-    throwGhcException (CmdLineError "--backpack can only process a single file")--computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)])-computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])-  where-    cid = hsComponentId (unLoc (hsunitName unit))-    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))-    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname-    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet-    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet-    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =-        unitFreeModuleHoles (convertHsComponentId hsuid)---- | Tiny enum for all types of Backpack operations we may do.-data SessionType-    -- | A compilation operation which will result in a-    -- runnable executable being produced.-    = ExeSession-    -- | A type-checking operation which produces only-    -- interface files, no object files.-    | TcSession-    -- | A compilation operation which produces both-    -- interface files and object files.-    | CompSession-    deriving (Eq)---- | Create a temporary Session to do some sort of type checking or--- compilation.-withBkpSession :: IndefUnitId-               -> [(ModuleName, Module)]-               -> [(Unit, ModRenaming)]-               -> SessionType   -- what kind of session are we doing-               -> BkpM a        -- actual action to run-               -> BkpM a-withBkpSession cid insts deps session_type do_this = do-    dflags <- getDynFlags-    let cid_fs = unitFS (indefUnit cid)-        is_primary = False-        uid_str = unpackFS (mkInstantiatedUnitHash cid insts)-        cid_str = unpackFS cid_fs-        -- There are multiple units in a single Backpack file, so we-        -- need to separate out the results in those cases.  Right now,-        -- we follow this hierarchy:-        --      $outputdir/$compid          --> typecheck results-        --      $outputdir/$compid/$unitid  --> compile results-        key_base p | Just f <- p dflags = f-                   | otherwise          = "."-        sub_comp p | is_primary = p-                   | otherwise = p </> cid_str-        outdir p | CompSession <- session_type-                 -- Special case when package is definite-                 , not (null insts) = sub_comp (key_base p) </> uid_str-                 | otherwise = sub_comp (key_base p)--        mk_temp_env hsc_env = hsc_env-            { hsc_dflags   = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env)-            }-        mk_temp_dflags unit_state dflags = dflags-            { backend = case session_type of-                            TcSession -> NoBackend-                            _         -> backend dflags-            , homeUnitInstantiations_ = insts-                                     -- if we don't have any instantiation, don't-                                     -- fill `homeUnitInstanceOfId` as it makes no-                                     -- sense (we're not instantiating anything)-            , homeUnitInstanceOf_   = if null insts then Nothing else Just (indefUnit cid)-            , homeUnitId_ = case session_type of-                TcSession -> newUnitId cid Nothing-                -- No hash passed if no instances-                _ | null insts -> newUnitId cid Nothing-                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))---            -- If we're type-checking an indefinite package, we want to-            -- turn on interface writing.  However, if the user also-            -- explicitly passed in `-fno-code`, we DON'T want to write-            -- interfaces unless the user also asked for `-fwrite-interface`.-            -- See Note [-fno-code mode]-            , generalFlags = case session_type of-                -- Make sure to write interfaces when we are type-checking-                -- indefinite packages.-                TcSession-                  | backend dflags /= NoBackend-                  -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)-                _ -> generalFlags dflags--            -- Setup all of the output directories according to our hierarchy-            , objectDir   = Just (outdir objectDir)-            , hiDir       = Just (outdir hiDir)-            , stubDir     = Just (outdir stubDir)-            -- Unset output-file for non exe builds-            , outputFile_ = case session_type of-                ExeSession -> outputFile_ dflags-                _          -> Nothing-            , dynOutputFile_ = case session_type of-                ExeSession -> dynOutputFile_ dflags-                _          -> Nothing-            -- Clear the import path so we don't accidentally grab anything-            , importPaths = []-            -- Synthesize the flags-            , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->-              let uid = unwireUnit unit_state-                        $ improveUnit unit_state-                        $ renameHoleUnit unit_state (listToUFM insts) uid0-              in ExposePackage-                (showSDoc dflags-                    (text "-unit-id" <+> ppr uid <+> ppr rn))-                (UnitIdArg uid) rn) deps-            }-    withTempSession mk_temp_env $ do-      dflags <- getSessionDynFlags-      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()-      setSessionDynFlags dflags -- calls initUnits-      do_this--withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a-withBkpExeSession deps do_this =-    withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this--getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)-getSource cid = do-    bkp_env <- getBkpEnv-    case Map.lookup cid (bkp_table bkp_env) of-        Nothing -> pprPanic "missing needed dependency" (ppr cid)-        Just lunit -> return lunit--typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()-typecheckUnit cid insts = do-    lunit <- getSource cid-    buildUnit TcSession cid insts lunit--compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()-compileUnit cid insts = do-    -- Let everyone know we're building this unit-    msgUnitId (mkVirtUnit cid insts)-    lunit <- getSource cid-    buildUnit CompSession cid insts lunit---- | Compute the dependencies with instantiations of a syntactic--- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a--- unit file, return the 'Unit' corresponding to @p[A=<A>]@.--- The @include_sigs@ parameter controls whether or not we also--- include @dependency signature@ declarations in this calculation.------ Invariant: this NEVER returns UnitId.-hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]-hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)-  where-    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))-        | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)]-        | otherwise = []-      where-        go Nothing = ModRenaming True []-        go (Just lrns) = ModRenaming False (map convRn lrns)-          where-            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)-            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)-    get_dep _ = []--buildUnit :: SessionType -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()-buildUnit session cid insts lunit = do-    -- NB: include signature dependencies ONLY when typechecking.-    -- If we're compiling, it's not necessary to recursively-    -- compile a signature since it isn't going to produce-    -- any object files.-    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)-        raw_deps = map fst deps_w_rns-    hsc_env <- getSession-    -- The compilation dependencies are just the appropriately filled-    -- in unit IDs which must be compiled before we can compile.-    let hsubst = listToUFM insts-        deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps--    -- Build dependencies OR make sure they make sense. BUT NOTE,-    -- we can only check the ones that are fully filled; the rest-    -- we have to defer until we've typechecked our local signature.-    -- TODO: work this into GHC.Driver.Make!!-    forM_ (zip [1..] deps0) $ \(i, dep) ->-        case session of-            TcSession -> return ()-            _ -> compileInclude (length deps0) (i, dep)--    -- IMPROVE IT-    let deps = map (improveUnit (hsc_units hsc_env)) deps0--    mb_old_eps <- case session of-                    TcSession -> fmap Just getEpsGhc-                    _ -> return Nothing--    conf <- withBkpSession cid insts deps_w_rns session $ do--        dflags <- getDynFlags-        mod_graph <- hsunitModuleGraph (unLoc lunit)--        msg <- mkBackpackMsg-        ok <- load' LoadAllTargets (Just msg) mod_graph-        when (failed ok) (liftIO $ exitWith (ExitFailure 1))--        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags-            export_mod ms = (ms_mod_name ms, ms_mod ms)-            -- Export everything!-            mods = [ export_mod ms | ms <- mgModSummaries mod_graph-                                   , ms_hsc_src ms == HsSrcFile ]--        -- Compile relevant only-        hsc_env <- getSession-        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)-            linkables = map (expectJust "bkp link" . hm_linkable)-                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)-                      $ home_mod_infos-            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables-            state     = hsc_units hsc_env--        let compat_fs = unitIdFS (indefUnit cid)-            compat_pn = PackageName compat_fs-            unit_id   = homeUnitId (hsc_home_unit hsc_env)--        return GenericUnitInfo {-            -- Stub data-            unitAbiHash = "",-            unitPackageId = PackageId compat_fs,-            unitPackageName = compat_pn,-            unitPackageVersion = makeVersion [],-            unitId = unit_id,-            unitComponentName = Nothing,-            unitInstanceOf = cid,-            unitInstantiations = insts,-            -- Slight inefficiency here haha-            unitExposedModules = map (\(m,n) -> (m,Just n)) mods,-            unitHiddenModules = [], -- TODO: doc only-            unitDepends = case session of-                        -- Technically, we should state that we depend-                        -- on all the indefinite libraries we used to-                        -- typecheck this.  However, this field isn't-                        -- really used for anything, so we leave it-                        -- blank for now.-                        TcSession -> []-                        _ -> map (toUnitId . unwireUnit state)-                                $ deps ++ [ moduleUnit mod-                                          | (_, mod) <- insts-                                          , not (isHoleModule mod) ],-            unitAbiDepends = [],-            unitLinkerOptions = case session of-                                 TcSession -> []-                                 _ -> map ST.pack $ obj_files,-            unitImportDirs = [ ST.pack $ hi_dir ],-            unitIsExposed = False,-            unitIsIndefinite = case session of-                                 TcSession -> True-                                 _ -> False,-            -- nope-            unitLibraries = [],-            unitExtDepLibsSys = [],-            unitExtDepLibsGhc = [],-            unitLibraryDynDirs = [],-            unitLibraryDirs = [],-            unitExtDepFrameworks = [],-            unitExtDepFrameworkDirs = [],-            unitCcOptions = [],-            unitIncludes = [],-            unitIncludeDirs = [],-            unitHaddockInterfaces = [],-            unitHaddockHTMLs = [],-            unitIsTrusted = False-            }---    addUnit conf-    case mb_old_eps of-        Just old_eps -> updateEpsGhc_ (const old_eps)-        _ -> return ()--compileExe :: LHsUnit HsComponentId -> BkpM ()-compileExe lunit = do-    msgUnitId mainUnit-    let deps_w_rns = hsunitDeps False (unLoc lunit)-        deps = map fst deps_w_rns-        -- no renaming necessary-    forM_ (zip [1..] deps) $ \(i, dep) ->-        compileInclude (length deps) (i, dep)-    withBkpExeSession deps_w_rns $ do-        mod_graph <- hsunitModuleGraph (unLoc lunit)-        msg <- mkBackpackMsg-        ok <- load' LoadAllTargets (Just msg) mod_graph-        when (failed ok) (liftIO $ exitWith (ExitFailure 1))---- | Register a new virtual unit database containing a single unit-addUnit :: GhcMonad m => UnitInfo -> m ()-addUnit u = do-    hsc_env <- getSession-    logger <- getLogger-    let dflags0 = hsc_dflags hsc_env-    newdbs <- case hsc_unit_dbs hsc_env of-        Nothing  -> panic "addUnit: called too early"-        Just dbs ->-         let newdb = UnitDatabase-               { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"-               , unitDatabaseUnits = [u]-               }-         in return (dbs ++ [newdb]) -- added at the end because ordering matters-    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)--    -- update platform constants-    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants--    let unit_env = UnitEnv-          { ue_platform  = targetPlatform dflags-          , ue_namever   = ghcNameVersion dflags-          , ue_home_unit = home_unit-          , ue_units     = unit_state-          }-    setSession $ hsc_env-        { hsc_unit_dbs = Just dbs-        , hsc_dflags   = dflags-        , hsc_unit_env = unit_env-        }--compileInclude :: Int -> (Int, Unit) -> BkpM ()-compileInclude n (i, uid) = do-    hsc_env <- getSession-    let pkgs = hsc_units hsc_env-    msgInclude (i, n) uid-    -- Check if we've compiled it already-    case uid of-      HoleUnit   -> return ()-      RealUnit _ -> return ()-      VirtUnit i -> case lookupUnit pkgs uid of-        Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)-        Just _  -> return ()---- ------------------------------------------------------------------------------- Backpack monad---- | Backpack monad is a 'GhcMonad' which also maintains a little extra state--- beyond the 'Session', c.f. 'BkpEnv'.-type BkpM = IOEnv BkpEnv---- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',--- because we are going to update the 'HscEnv' as we go.-data BkpEnv-    = BkpEnv {-        -- | The session-        bkp_session :: Session,-        -- | The filename of the bkp file we're compiling-        bkp_filename :: FilePath,-        -- | Table of source units which we know how to compile-        bkp_table :: Map IndefUnitId (LHsUnit HsComponentId),-        -- | When a package we are compiling includes another package-        -- which has not been compiled, we bump the level and compile-        -- that.-        bkp_level :: Int-    }---- Blah, to get rid of the default instance for IOEnv--- TODO: just make a proper new monad for BkpM, rather than use IOEnv-instance {-# OVERLAPPING #-} HasDynFlags BkpM where-    getDynFlags = fmap hsc_dflags getSession-instance {-# OVERLAPPING #-} HasLogger BkpM where-    getLogger = fmap hsc_logger getSession---instance GhcMonad BkpM where-    getSession = do-        Session s <- fmap bkp_session getEnv-        readMutVar s-    setSession hsc_env = do-        Session s <- fmap bkp_session getEnv-        writeMutVar s hsc_env---- | Get the current 'BkpEnv'.-getBkpEnv :: BkpM BkpEnv-getBkpEnv = getEnv---- | Get the nesting level, when recursively compiling modules.-getBkpLevel :: BkpM Int-getBkpLevel = bkp_level `fmap` getBkpEnv---- | Run a 'BkpM' computation, with the nesting level bumped one.-innerBkpM :: BkpM a -> BkpM a-innerBkpM do_this =-    -- NB: withTempSession mutates, so we don't have to worry-    -- about bkp_session being stale.-    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this---- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.-updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()-updateEpsGhc_ f = do-    hsc_env <- getSession-    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))---- | Get the EPS from a 'GhcMonad'.-getEpsGhc :: GhcMonad m => m ExternalPackageState-getEpsGhc = do-    hsc_env <- getSession-    liftIO $ readIORef (hsc_EPS hsc_env)---- | Run 'BkpM' in 'Ghc'.-initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a-initBkpM file bkp m =-  reifyGhc $ \session -> do-    let env = BkpEnv {-        bkp_session = session,-        bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],-        bkp_filename = file,-        bkp_level = 0-      }-    runIOEnv env m---- ------------------------------------------------------------------------------- Messaging---- | Print a compilation progress message, but with indentation according--- to @level@ (for nested compilation).-backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()-backpackProgressMsg level logger dflags msg =-    compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr-                                      <> msg---- | Creates a 'Messager' for Backpack compilation; this is basically--- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which--- handles indentation.-mkBackpackMsg :: BkpM Messager-mkBackpackMsg = do-    level <- getBkpLevel-    return $ \hsc_env mod_index recomp node ->-      let dflags = hsc_dflags hsc_env-          logger = hsc_logger hsc_env-          state = hsc_units hsc_env-          showMsg msg reason =-            backpackProgressMsg level logger dflags $ pprWithUnitState state $-                showModuleIndex mod_index <>-                msg <> showModMsg dflags (recompileRequired recomp) node-                    <> reason-      in case node of-        InstantiationNode _ ->-          case recomp of-            MustCompile -> showMsg (text "Instantiating ") empty-            UpToDate-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-              | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")-        ModuleNode _ ->-          case recomp of-            MustCompile -> showMsg (text "Compiling ") empty-            UpToDate-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-              | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")---- | 'PprStyle' for Backpack messages; here we usually want the module to--- be qualified (so we can tell how it was instantiated.) But we try not--- to qualify packages so we can use simple names for them.-backpackStyle :: PprStyle-backpackStyle =-    mkUserStyle-        (QueryQualify neverQualifyNames-                      alwaysQualifyModules-                      neverQualifyPackages) AllTheWay---- | Message when we initially process a Backpack unit.-msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()-msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do-    dflags <- getDynFlags-    logger <- getLogger-    level <- getBkpLevel-    liftIO . backpackProgressMsg level logger dflags-        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn---- | Message when we instantiate a Backpack unit.-msgUnitId :: Unit -> BkpM ()-msgUnitId pk = do-    dflags <- getDynFlags-    logger <- getLogger-    hsc_env <- getSession-    level <- getBkpLevel-    let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger dflags-        $ pprWithUnitState state-        $ text "Instantiating "-           <> withPprStyle backpackStyle (ppr pk)---- | Message when we include a Backpack unit.-msgInclude :: (Int,Int) -> Unit -> BkpM ()-msgInclude (i,n) uid = do-    dflags <- getDynFlags-    logger <- getLogger-    hsc_env <- getSession-    level <- getBkpLevel-    let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger dflags-        $ pprWithUnitState state-        $ showModuleIndex (i, n) <> text "Including "-            <> withPprStyle backpackStyle (ppr uid)---- ------------------------------------------------------------------------------- Conversion from PackageName to HsComponentId--type PackageNameMap a = UniqFM PackageName a---- For now, something really simple, since we're not actually going--- to use this for anything-unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)-unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })-    = (pn, HsComponentId pn (Indefinite (UnitId fs)))--bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId-bkpPackageNameMap units = listToUFM (map unitDefines units)--renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]-renameHsUnits pkgstate m units = map (fmap renameHsUnit) units-  where--    renamePackageName :: PackageName -> HsComponentId-    renamePackageName pn =-        case lookupUFM m pn of-            Nothing ->-                case lookupPackageName pkgstate pn of-                    Nothing -> error "no package name"-                    Just cid -> HsComponentId pn cid-            Just hscid -> hscid--    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId-    renameHsUnit u =-        HsUnit {-            hsunitName = fmap renamePackageName (hsunitName u),-            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)-        }--    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId-    renameHsUnitDecl (DeclD a b c) = DeclD a b c-    renameHsUnitDecl (IncludeD idecl) =-        IncludeD IncludeDecl {-            idUnitId = fmap renameHsUnitId (idUnitId idecl),-            idModRenaming = idModRenaming idecl,-            idSignatureInclude = idSignatureInclude idecl-        }--    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId-    renameHsUnitId (HsUnitId ln subst)-        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)--    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId-    renameHsModuleSubst (lk, lm)-        = (lk, fmap renameHsModuleId lm)--    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId-    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm-    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm--convertHsComponentId :: HsUnitId HsComponentId -> Unit-convertHsComponentId (HsUnitId (L _ hscid) subst)-    = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)--convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)-convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)--convertHsModuleId :: HsModuleId HsComponentId -> Module-convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname-convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname----{--************************************************************************-*                                                                      *-                        Module graph construction-*                                                                      *-************************************************************************--}---- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:------  1. Every module is required to be mentioned, so we don't do any funny---     business with targets or recursively grabbing dependencies.  (We---     could support this in principle).---  2. We support inline modules, whose summary we have to synthesize ourself.------ We don't bother trying to support GHC.Driver.Make for now, it's more trouble--- than it's worth for inline modules.-hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph unit = do-    hsc_env <- getSession--    let decls = hsunitBody unit-        pn = hsPackageName (unLoc (hsunitName unit))-        home_unit = hsc_home_unit hsc_env--    --  1. Create a HsSrcFile/HsigFile summary for every-    --  explicitly mentioned module/signature.-    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =-          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod-        get_decl _ = return Nothing-    nodes <- catMaybes `fmap` mapM get_decl decls--    --  2. For each hole which does not already have an hsig file,-    --  create an "empty" hsig file to induce compilation for the-    --  requirement.-    let hsig_set = Set.fromList-          [ ms_mod_name ms-          | ExtendedModSummary { emsModSummary = ms } <- nodes-          , ms_hsc_src ms == HsigFile-          ]-    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->-        if Set.member mod_name hsig_set-            then return Nothing-            else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name-            -- Using extendModSummaryNoDeps here is okay because we're making a leaf node-            -- representing a signature that can't depend on any other unit.--    -- 3. Return the kaboodle-    return $ mkModuleGraph' $-      (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)--summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary-summariseRequirement pn mod_name = do-    hsc_env <- getSession-    let dflags = hsc_dflags hsc_env--    let PackageName pn_fs = pn-    location <- liftIO $ mkHomeModLocation2 dflags mod_name-                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"--    env <- getBkpEnv-    time <- liftIO $ getModificationUTCTime (bkp_filename env)-    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)-    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)-    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)--    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location--    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name--    return ModSummary {-        ms_mod = mod,-        ms_hsc_src = HsigFile,-        ms_location = location,-        ms_hs_date = time,-        ms_obj_date = Nothing,-        ms_iface_date = hi_timestamp,-        ms_hie_date = hie_timestamp,-        ms_srcimps = [],-        ms_textual_imps = extra_sig_imports,-        ms_parsed_mod = Just (HsParsedModule {-                hpm_module = L loc (HsModule {-                        hsmodAnn = noAnn,-                        hsmodLayout = NoLayoutInfo,-                        hsmodName = Just (L (noAnnSrcSpan loc) mod_name),-                        hsmodExports = Nothing,-                        hsmodImports = [],-                        hsmodDecls = [],-                        hsmodDeprecMessage = Nothing,-                        hsmodHaddockModHeader = Nothing-                    }),-                hpm_src_files = []-            }),-        ms_hspp_file = "", -- none, it came inline-        ms_hspp_opts = dflags,-        ms_hspp_buf = Nothing-        }--summariseDecl :: PackageName-              -> HscSource-              -> Located ModuleName-              -> Maybe (Located HsModule)-              -> BkpM ExtendedModSummary-summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod-summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing-    = do hsc_env <- getSession-         -- TODO: this looks for modules in the wrong place-         r <- liftIO $ summariseModule hsc_env-                         emptyModNodeMap -- GHC API recomp not supported-                         (hscSourceToIsBoot hsc_src)-                         lmodname-                         True -- Target lets you disallow, but not here-                         Nothing -- GHC API buffer support not supported-                         [] -- No exclusions-         case r of-            Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found"))-            Just (Left err) -> throwErrors err-            Just (Right summary) -> return summary---- | Up until now, GHC has assumed a single compilation target per source file.--- Backpack files with inline modules break this model, since a single file--- may generate multiple output files.  How do we decide to name these files?--- Should there only be one output file? This function our current heuristic,--- which is we make a "fake" module and use that.-hsModuleToModSummary :: PackageName-                     -> HscSource-                     -> ModuleName-                     -> Located HsModule-                     -> BkpM ExtendedModSummary-hsModuleToModSummary pn hsc_src modname-                     hsmod = do-    let imps = hsmodImports (unLoc hsmod)-        loc  = getLoc hsmod-    hsc_env <- getSession-    -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation-    -- Use the PACKAGE NAME to find the location-    let PackageName unit_fs = pn-        dflags = hsc_dflags hsc_env-    -- Unfortunately, we have to define a "fake" location in-    -- order to appease the various code which uses the file-    -- name to figure out where to put, e.g. object files.-    -- To add insult to injury, we don't even actually use-    -- these filenames to figure out where the hi files go.-    -- A travesty!-    location0 <- liftIO $ mkHomeModLocation2 dflags modname-                             (unpackFS unit_fs </>-                              moduleNameSlashes modname)-                              (case hsc_src of-                                HsigFile -> "hsig"-                                HsBootFile -> "hs-boot"-                                HsSrcFile -> "hs")-    -- DANGEROUS: bootifying can POISON the module finder cache-    let location = case hsc_src of-                        HsBootFile -> addBootSuffixLocnOut location0-                        _ -> location0-    -- This duplicates a pile of logic in GHC.Driver.Make-    env <- getBkpEnv-    time <- liftIO $ getModificationUTCTime (bkp_filename env)-    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)-    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)--    -- Also copied from 'getImports'-    let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps--             -- GHC.Prim doesn't exist physically, so don't go looking for it.-        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)-                               ord_idecls--        implicit_prelude = xopt LangExt.ImplicitPrelude dflags-        implicit_imports = mkPrelImports modname loc-                                         implicit_prelude imps-        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc $ ideclName i)--    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname--    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)-    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports--    -- So that Finder can find it, even though it doesn't exist...-    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location-    return $ ExtendedModSummary-      { emsModSummary =-          ModSummary {-            ms_mod = this_mod,-            ms_hsc_src = hsc_src,-            ms_location = location,-            ms_hspp_file = (case hiDir dflags of-                            Nothing -> ""-                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",-            ms_hspp_opts = dflags,-            ms_hspp_buf = Nothing,-            ms_srcimps = map convImport src_idecls,-            ms_textual_imps = normal_imports-                           -- We have to do something special here:-                           -- due to merging, requirements may end up with-                           -- extra imports-                           ++ extra_sig_imports-                           ++ ((,) Nothing . noLoc <$> implicit_sigs),-            -- This is our hack to get the parse tree to the right spot-            ms_parsed_mod = Just (HsParsedModule {-                    hpm_module = hsmod,-                    hpm_src_files = [] -- TODO if we preprocessed it-                }),-            ms_hs_date = time,-            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS-            ms_iface_date = hi_timestamp,-            ms_hie_date = hie_timestamp-          }-      , emsInstantiatedUnits = inst_deps-      }---- | Create a new, externally provided hashed unit id from--- a hash.-newUnitId :: IndefUnitId -> Maybe FastString -> UnitId-newUnitId uid mhash = case mhash of-   Nothing   -> indefUnit uid-   Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash)

@@ -1,454 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------------------------- Makefile Dependency Generation------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module GHC.Driver.MakeFile-   ( doMkDependHS-   )-where--#include "GhclibHsVersions.h"--import GHC.Prelude--import qualified GHC-import GHC.Driver.Monad-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Utils.Misc-import GHC.Driver.Env-import qualified GHC.SysTools as SysTools-import GHC.Data.Graph.Directed ( SCC(..) )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import Data.List (partition)-import GHC.Data.FastString-import GHC.Utils.TmpFs--import GHC.Iface.Load (cannotFindModule)--import GHC.Unit.Module-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Graph-import GHC.Unit.Finder--import GHC.Utils.Exception-import GHC.Utils.Error-import GHC.Utils.Logger--import System.Directory-import System.FilePath-import System.IO-import System.IO.Error  ( isEOFError )-import Control.Monad    ( when, forM_ )-import Data.Maybe       ( isJust )-import Data.IORef-import qualified Data.Set as Set-------------------------------------------------------------------------              The main function-----------------------------------------------------------------------doMkDependHS :: GhcMonad m => [FilePath] -> m ()-doMkDependHS srcs = do-    logger <- getLogger--    -- Initialisation-    dflags0 <- GHC.getSessionDynFlags--    -- We kludge things a bit for dependency generation. Rather than-    -- generating dependencies for each way separately, we generate-    -- them once and then duplicate them for each way's osuf/hisuf.-    -- We therefore do the initial dependency generation with an empty-    -- way and .o/.hi extensions, regardless of any flags that might-    -- be specified.-    let dflags = dflags0-            { targetWays_ = Set.empty-            , hiSuf_      = "hi"-            , objectSuf_  = "o"-            }-    GHC.setSessionDynFlags dflags--    when (null (depSuffixes dflags)) $ liftIO $-        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")--    tmpfs <- hsc_tmpfs <$> getSession-    files <- liftIO $ beginMkDependHS logger tmpfs dflags--    -- Do the downsweep to find all the modules-    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs-    GHC.setTargets targets-    let excl_mods = depExcludeMods dflags-    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}--    -- Sort into dependency order-    -- There should be no cycles-    let sorted = GHC.topSortModuleGraph False module_graph Nothing--    -- Print out the dependencies if wanted-    liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)--    -- Process them one by one, dumping results into makefile-    -- and complaining about cycles-    hsc_env <- getSession-    root <- liftIO getCurrentDirectory-    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted--    -- If -ddump-mod-cycles, show cycles in the module graph-    liftIO $ dumpModCycles logger dflags module_graph--    -- Tidy up-    liftIO $ endMkDependHS logger dflags files--    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an-    --exception; if that is not caught it's fine, but at least we have a-    --chance to find out exactly what went wrong.  Uncomment the following-    --line if you disagree.--    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)-------------------------------------------------------------------------              beginMkDependHs---      Create a temporary file,---      find the Makefile,---      slurp through it, etc-----------------------------------------------------------------------data MkDepFiles-  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile-            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile-            mkd_tmp_file  :: FilePath,          -- Name of the temporary file-            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file--beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles-beginMkDependHS logger tmpfs dflags = do-        -- open a new temp file in which to stuff the dependency info-        -- as we go along.-  tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep"-  tmp_hdl <- openFile tmp_file WriteMode--        -- open the makefile-  let makefile = depMakefile dflags-  exists <- doesFileExist makefile-  mb_make_hdl <--        if not exists-        then return Nothing-        else do-           makefile_hdl <- openFile makefile ReadMode--                -- slurp through until we get the magic start string,-                -- copying the contents into dep_makefile-           let slurp = do-                l <- hGetLine makefile_hdl-                if (l == depStartMarker)-                        then return ()-                        else do hPutStrLn tmp_hdl l; slurp--                -- slurp through until we get the magic end marker,-                -- throwing away the contents-           let chuck = do-                l <- hGetLine makefile_hdl-                if (l == depEndMarker)-                        then return ()-                        else chuck--           catchIO slurp-                (\e -> if isEOFError e then return () else ioError e)-           catchIO chuck-                (\e -> if isEOFError e then return () else ioError e)--           return (Just makefile_hdl)---        -- write the magic marker into the tmp file-  hPutStrLn tmp_hdl depStartMarker--  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,-                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})--------------------------------------------------------------------------              processDeps-----------------------------------------------------------------------processDeps :: DynFlags-            -> HscEnv-            -> [ModuleName]-            -> FilePath-            -> Handle           -- Write dependencies to here-            -> SCC ModuleGraphNode-            -> IO ()--- Write suitable dependencies to handle--- Always:---                      this.o : this.hs------ If the dependency is on something other than a .hi file:---                      this.o this.p_o ... : dep--- otherwise---                      this.o ...   : dep.hi---                      this.p_o ... : dep.p_hi---                      ...--- (where .o is $osuf, and the other suffixes come from--- the cmdline -s options).------ For {-# SOURCE #-} imports the "hi" will be "hi-boot".--processDeps dflags _ _ _ _ (CyclicSCC nodes)-  =     -- There shouldn't be any cycles; report them-    throwGhcExceptionIO $ ProgramError $-      showSDoc dflags $ GHC.cyclicModuleErr nodes--processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))-  =     -- There shouldn't be any backpack instantiations; report them as well-    throwGhcExceptionIO $ ProgramError $-      showSDoc dflags $-        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"-             , nest 2 $ ppr node ]--processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))-  = do  { let extra_suffixes = depSuffixes dflags-              include_pkg_deps = depIncludePkgDeps dflags-              src_file  = msHsFilePath node-              obj_file  = msObjFilePath node-              obj_files = insertSuffixes obj_file extra_suffixes--              do_imp loc is_boot pkg_qual imp_mod-                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod-                                               is_boot include_pkg_deps-                     ; case mb_hi of {-                           Nothing      -> return () ;-                           Just hi_file -> do-                     { let hi_files = insertSuffixes hi_file extra_suffixes-                           write_dep (obj,hi) = writeDependency root hdl [obj] hi--                        -- Add one dependency for each suffix;-                        -- e.g.         A.o   : B.hi-                        --              A.x_o : B.x_hi-                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}---                -- Emit std dependency of the object(s) on the source file-                -- Something like       A.o : A.hs-        ; writeDependency root hdl obj_files src_file--          -- add dependency between objects and their corresponding .hi-boot-          -- files if the module has a corresponding .hs-boot file (#14482)-        ; when (isBootSummary node == IsBoot) $ do-            let hi_boot = msHiFilePath node-            let obj     = removeBootSuffix (msObjFilePath node)-            forM_ extra_suffixes $ \suff -> do-               let way_obj     = insertSuffixes obj     [suff]-               let way_hi_boot = insertSuffixes hi_boot [suff]-               mapM_ (writeDependency root hdl way_obj) way_hi_boot--                -- Emit a dependency for each CPP import-        ; when (depIncludeCppDeps dflags) $ do-            -- CPP deps are descovered in the module parsing phase by parsing-            -- comment lines left by the preprocessor.-            -- Note that GHC.parseModule may throw an exception if the module-            -- fails to parse, which may not be desirable (see #16616).-          { session <- Session <$> newIORef hsc_env-          ; parsedMod <- reflectGhc (GHC.parseModule node) session-          ; mapM_ (writeDependency root hdl obj_files)-                  (GHC.pm_extra_src_files parsedMod)-          }--                -- Emit a dependency for each import--        ; let do_imps is_boot idecls = sequence_-                    [ do_imp loc is_boot mb_pkg mod-                    | (mb_pkg, L loc mod) <- idecls,-                      mod `notElem` excl_mods ]--        ; do_imps IsBoot (ms_srcimps node)-        ; do_imps NotBoot (ms_imps node)-        }---findDependency  :: HscEnv-                -> SrcSpan-                -> Maybe FastString     -- package qualifier, if any-                -> ModuleName           -- Imported module-                -> IsBootInterface      -- Source import-                -> Bool                 -- Record dependency on package modules-                -> IO (Maybe FilePath)  -- Interface file-findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps-  = do  {       -- Find the module; this will be fast because-                -- we've done it once during downsweep-          r <- findImportedModule hsc_env imp pkg-        ; case r of-            Found loc _-                -- Home package: just depend on the .hi or hi-boot file-                | isJust (ml_hs_file loc) || include_pkg_deps-                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))--                -- Not in this package: we don't need a dependency-                | otherwise-                -> return Nothing--            fail ->-                throwOneError $ mkPlainMsgEnvelope srcloc $-                     cannotFindModule hsc_env imp fail-        }--------------------------------writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()--- (writeDependency r h [t1,t2] dep) writes to handle h the dependency---      t1 t2 : dep-writeDependency root hdl targets dep-  = do let -- We need to avoid making deps on-           --     c:/foo/...-           -- on cygwin as make gets confused by the :-           -- Making relative deps avoids some instances of this.-           dep' = makeRelative root dep-           forOutput = escapeSpaces . reslash Forwards . normalise-           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'-       hPutStrLn hdl output--------------------------------insertSuffixes-        :: FilePath     -- Original filename;   e.g. "foo.o"-        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]-        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]-        -- Note that the extra bit gets inserted *before* the old suffix-        -- We assume the old suffix contains no dots, so we know where to-        -- split it-insertSuffixes file_name extras-  = [ basename <.> (extra ++ suffix) | extra <- extras ]-  where-    (basename, suffix) = case splitExtension file_name of-                         -- Drop the "." from the extension-                         (b, s) -> (b, drop 1 s)--------------------------------------------------------------------------              endMkDependHs---      Complete the makefile, close the tmp file etc-----------------------------------------------------------------------endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()--endMkDependHS logger dflags-   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,-            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })-  = do-  -- write the magic marker into the tmp file-  hPutStrLn tmp_hdl depEndMarker--  case makefile_hdl of-     Nothing  -> return ()-     Just hdl -> do--          -- slurp the rest of the original makefile and copy it into the output-        let slurp = do-                l <- hGetLine hdl-                hPutStrLn tmp_hdl l-                slurp--        catchIO slurp-                (\e -> if isEOFError e then return () else ioError e)--        hClose hdl--  hClose tmp_hdl  -- make sure it's flushed--        -- Create a backup of the original makefile-  when (isJust makefile_hdl)-       (SysTools.copy logger dflags ("Backing up " ++ makefile)-          makefile (makefile++".bak"))--        -- Copy the new makefile in place-  SysTools.copy logger dflags "Installing new makefile" tmp_file makefile-----------------------------------------------------------------------              Module cycles--------------------------------------------------------------------dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()-dumpModCycles logger dflags module_graph-  | not (dopt Opt_D_dump_mod_cycles dflags)-  = return ()--  | null cycles-  = putMsg logger dflags (text "No module cycles")--  | otherwise-  = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)-  where-    topoSort = filterToposortToModules $-      GHC.topSortModuleGraph True module_graph Nothing--    cycles :: [[ModSummary]]-    cycles =-      [ c | CyclicSCC c <- topoSort ]--    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))-                        $$ pprCycle c $$ blankLine-                     | (n,c) <- [1..] `zip` cycles ]--pprCycle :: [ModSummary] -> SDoc--- Print a cycle, but show only the imports within the cycle-pprCycle summaries = pp_group (CyclicSCC summaries)-  where-    cycle_mods :: [ModuleName]  -- The modules in this cycle-    cycle_mods = map (moduleName . ms_mod) summaries--    pp_group (AcyclicSCC ms) = pp_ms ms-    pp_group (CyclicSCC mss)-        = ASSERT( not (null boot_only) )-                -- The boot-only list must be non-empty, else there would-                -- be an infinite chain of non-boot imports, and we've-                -- already checked for that in processModDeps-          pp_ms loop_breaker $$ vcat (map pp_group groups)-        where-          (boot_only, others) = partition is_boot_only mss-          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))-          in_group (L _ m) = m `elem` group_mods-          group_mods = map (moduleName . ms_mod) mss--          loop_breaker = head boot_only-          all_others   = tail boot_only ++ others-          groups = filterToposortToModules $-            GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing--    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))-                       <+> (pp_imps empty (map snd (ms_imps summary)) $$-                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))-        where-          mod_str = moduleNameString (moduleName (ms_mod summary))--    pp_imps :: SDoc -> [Located ModuleName] -> SDoc-    pp_imps _    [] = empty-    pp_imps what lms-        = case [m | L _ m <- lms, m `elem` cycle_mods] of-            [] -> empty-            ms -> what <+> text "imports" <+>-                                pprWithCommas ppr ms-------------------------------------------------------------------------              Flags-----------------------------------------------------------------------depStartMarker, depEndMarker :: String-depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"-depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"-

@@ -1,36 +0,0 @@-module GHC.Linker-   (-   )-where--import GHC.Prelude ()-   -- We need this dummy dependency for the make build system. Otherwise it-   -- tries to load GHC.Types which may not be built yet.---- Note [Linkers and loaders]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~------ Linkers are used to produce linked objects (.so, executables); loaders are--- used to link in memory (e.g., in GHCi) with the already loaded libraries--- (ghc-lib, rts, etc.).------ Linking can usually be done with an external linker program ("ld"), but--- loading is more tricky:------    * Fully dynamic:---       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)---       and the modules to load are also compiled for dynamic linking, a---       solution is to fully rely on external tools:------       1) link a .so with the external linker---       2) load the .so with POSIX's "dlopen"------    * When GHC is built as a static program or when libraries we want to load---    aren't compiled for dynamic linking, GHC uses its own loader ("runtime---    linker"). The runtime linker is part of the rts (rts/Linker.c).------ Note that within GHC's codebase we often use the word "linker" to refer to--- the static object loader in the runtime system.------ Loading can be delegated to an external interpreter ("iserv") when--- -fexternal-interpreter is used.

@@ -1,175 +0,0 @@-{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}---- | This module is not used by GHC itself.  Rather, it exports all of--- the functions and types you are likely to need when writing a--- plugin for GHC. So authors of plugins can probably get away simply--- with saying "import GHC.Plugins".------ Particularly interesting modules for plugin writers include--- "GHC.Core" and "GHC.Core.Opt.Monad".-module GHC.Plugins-   ( module GHC.Driver.Plugins-   , module GHC.Types.Name.Reader-   , module GHC.Types.Name.Occurrence-   , module GHC.Types.Name-   , module GHC.Types.Var-   , module GHC.Types.Id-   , module GHC.Types.Id.Info-   , module GHC.Core.Opt.Monad-   , module GHC.Core-   , module GHC.Types.Literal-   , module GHC.Core.DataCon-   , module GHC.Core.Utils-   , module GHC.Core.Make-   , module GHC.Core.FVs-   , module GHC.Core.Subst-   , module GHC.Core.Rules-   , module GHC.Types.Annotations-   , module GHC.Driver.Session-   , module GHC.Driver.Ppr-   , module GHC.Unit.State-   , module GHC.Unit.Module-   , module GHC.Core.Type-   , module GHC.Core.TyCon-   , module GHC.Core.Coercion-   , module GHC.Builtin.Types-   , module GHC.Driver.Env-   , module GHC.Types.Basic-   , module GHC.Types.Var.Set-   , module GHC.Types.Var.Env-   , module GHC.Types.Name.Set-   , module GHC.Types.Name.Env-   , module GHC.Types.Unique-   , module GHC.Types.Unique.Set-   , module GHC.Types.Unique.FM-   , module GHC.Data.FiniteMap-   , module GHC.Utils.Misc-   , module GHC.Serialized-   , module GHC.Types.SrcLoc-   , module GHC.Utils.Outputable-   , module GHC.Utils.Panic-   , module GHC.Types.Unique.Supply-   , module GHC.Data.FastString-   , module GHC.Tc.Errors.Hole.FitTypes   -- for hole-fit plugins-   , module GHC.Unit.Module.ModGuts-   , module GHC.Unit.Module.ModSummary-   , module GHC.Unit.Module.ModIface-   , module GHC.Types.Meta-   , module GHC.Types.SourceError-   , -- * Getting 'Name's-     thNameToGhcName-   )-where---- Plugin stuff itself-import GHC.Driver.Plugins---- Variable naming-import GHC.Types.TyThing-import GHC.Types.SourceError-import GHC.Types.Name.Reader-import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} )-import GHC.Types.Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )-import GHC.Types.Var-import GHC.Types.Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )-import GHC.Types.Id.Info---- Core-import GHC.Core.Opt.Monad-import GHC.Core-import GHC.Types.Literal-import GHC.Core.DataCon-import GHC.Core.Utils-import GHC.Core.Make-import GHC.Core.FVs-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )-       -- These names are also exported by Type--import GHC.Core.Rules-import GHC.Types.Annotations-import GHC.Types.Meta--import GHC.Driver.Session-import GHC.Unit.State--import GHC.Unit.Module-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}-                ( substTy, extendTvSubst, extendTvSubstList, isInScope )-import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}-                ( substCo )-import GHC.Core.TyCon-import GHC.Builtin.Types-import GHC.Driver.Env-import GHC.Types.Basic---- Collections and maps-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Name.Set-import GHC.Types.Name.Env-import GHC.Types.Unique.Set-import GHC.Types.Unique.FM--- Conflicts with UniqFM:---import LazyUniqFM-import GHC.Data.FiniteMap---- Common utilities-import GHC.Utils.Misc-import GHC.Serialized-import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Driver.Ppr-import GHC.Types.Unique.Supply-import GHC.Types.Unique ( Unique, Uniquable(..) )-import GHC.Data.FastString-import Data.Maybe--import GHC.Iface.Env    ( lookupOrigIO )-import GHC.Prelude-import GHC.Utils.Monad  ( mapMaybeM )-import GHC.ThToHs       ( thRdrNameGuesses )-import GHC.Tc.Utils.Env ( lookupGlobal )--import GHC.Tc.Errors.Hole.FitTypes--import qualified Language.Haskell.TH as TH--{- This instance is defined outside GHC.Core.Opt.Monad so that-   GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}-instance MonadThings CoreM where-    lookupThing name = do { hsc_env <- getHscEnv-                          ; liftIO $ lookupGlobal hsc_env name }--{--************************************************************************-*                                                                      *-               Template Haskell interoperability-*                                                                      *-************************************************************************--}---- | Attempt to convert a Template Haskell name to one that GHC can--- understand. Original TH names such as those you get when you use--- the @'foo@ syntax will be translated to their equivalent GHC name--- exactly. Qualified or unqualified TH names will be dynamically bound--- to names in the module being compiled, if possible. Exact TH names--- will be bound to the name they represent, exactly.-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)-thNameToGhcName th_name-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)-          -- Pick the first that works-          -- E.g. reify (mkName "A") will pick the class A in preference-          -- to the data constructor A-        ; return (listToMaybe names) }-  where-    lookup rdr_name-      | Just n <- isExact_maybe rdr_name   -- This happens in derived code-      = return $ if isExternalName n then Just n else Nothing-      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name-      = do { hsc_env <- getHscEnv-           ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }-      | otherwise = return Nothing

@@ -1,250 +0,0 @@------------------------------------------------------------------------------------ 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 GHC.Prelude--import GHC--import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Monad-import GHC.Driver.Env--import GHC.Linker.Loader--import GHC.Runtime.Heap.Inspect-import GHC.Runtime.Interpreter-import GHC.Runtime.Context--import GHC.Iface.Syntax ( showToHeader )-import GHC.Iface.Env    ( newInteractiveBinder )-import GHC.Core.Type--import GHC.Utils.Outputable-import GHC.Utils.Error-import GHC.Utils.Monad-import GHC.Utils.Exception-import GHC.Utils.Logger--import GHC.Types.Id-import GHC.Types.Name-import GHC.Types.Var hiding ( varName )-import GHC.Types.Var.Set-import GHC.Types.Unique.Set-import GHC.Types.TyThing.Ppr-import GHC.Types.TyThing--import Control.Monad-import Control.Monad.Catch as MC-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-  logger <- getLogger-  liftIO $ (printOutputForUser logger 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' = updateIdTypeAndMult (substTy subst) id-           id_ty' = idType id'-       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-                           ; logger <- getLogger-                           ; liftIO $-                               dumpIfSet_dyn logger 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-          interp = hscInterp hsc_env-      liftIO $ extendLoadedEnv interp (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-        let set_session = do-                hsc_env <- getSession-                (new_env, bname) <- bindToFreshName hsc_env ty "showme"-                setSession new_env--                -- this disables logging of errors-                let noop_log _ _ _ _ _ = return ()-                pushLogHookM (const noop_log)--                return (hsc_env, bname)--            reset_session (old_env,_) = setSession old_env--        MC.bracket set_session reset_session $ \(_,bname) -> do-           hsc_env <- getSession-           dflags  <- GHC.getSessionDynFlags-           let expr = "Prelude.return (Prelude.show " ++-                         showPpr dflags bname ++-                      ") :: Prelude.IO Prelude.String"-               interp = hscInterp hsc_env-           txt_ <- withExtendedLoadedEnv interp-                                       [(bname, fhv)]-                                       (GHC.compileExprRemote expr)-           let myprec = 10 -- application precedence. TODO Infix constructors-           txt <- liftIO $ evalString interp txt_-           if not (null txt) then-             return $ Just $ cparen (prec >= myprec && needsParens txt)-                                    (text txt)-            else return Nothing--  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 <- MC.try $ 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

@@ -1,190 +0,0 @@-{-# LANGUAGE CPP #-}--- | This module provides an interface for typechecker plugins to--- access select functions of the 'TcM', principally those to do with--- reading parts of the state.-module GHC.Tc.Plugin (-        -- * Basic TcPluginM functionality-        TcPluginM,-        tcPluginIO,-        tcPluginTrace,-        unsafeTcPluginTcM,--        -- * Finding Modules and Names-        Finder.FindResult(..),-        findImportedModule,-        lookupOrig,--        -- * Looking up Names in the typechecking environment-        tcLookupGlobal,-        tcLookupTyCon,-        tcLookupDataCon,-        tcLookupClass,-        tcLookup,-        tcLookupId,--        -- * Getting the TcM state-        getTopEnv,-        getEnvs,-        getInstEnvs,-        getFamInstEnvs,-        matchFam,--        -- * Type variables-        newUnique,-        newFlexiTyVar,-        isTouchableTcPluginM,--        -- * Zonking-        zonkTcType,-        zonkCt,--        -- * Creating constraints-        newWanted,-        newDerived,-        newGiven,-        newCoercionHole,--        -- * Manipulating evidence bindings-        newEvVar,-        setEvBind,-        getEvBindsTcPluginM-    ) where--import GHC.Prelude--import qualified GHC.Tc.Utils.Monad     as TcM-import qualified GHC.Tc.Solver.Monad    as TcS-import qualified GHC.Tc.Utils.Env       as TcM-import qualified GHC.Tc.Utils.TcMType   as TcM-import qualified GHC.Tc.Instance.Family as TcM-import qualified GHC.Iface.Env          as IfaceEnv-import qualified GHC.Unit.Finder        as Finder--import GHC.Core.FamInstEnv     ( FamInstEnv )-import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM-                               , unsafeTcPluginTcM, getEvBindsTcPluginM-                               , liftIO, traceTc )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin )-import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )-import GHC.Tc.Utils.Env        ( TcTyThing )-import GHC.Tc.Types.Evidence   ( TcCoercion, CoercionHole, EvTerm(..)-                               , EvExpr, EvBind, mkGivenEvBind )-import GHC.Types.Var           ( EvVar )--import GHC.Unit.Module-import GHC.Types.Name-import GHC.Types.TyThing-import GHC.Core.TyCon-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Driver.Env-import GHC.Utils.Outputable-import GHC.Core.Type-import GHC.Types.Id-import GHC.Core.InstEnv-import GHC.Data.FastString-import GHC.Types.Unique----- | Perform some IO, typically to interact with an external tool.-tcPluginIO :: IO a -> TcPluginM a-tcPluginIO a = unsafeTcPluginTcM (liftIO a)---- | Output useful for debugging the compiler.-tcPluginTrace :: String -> SDoc -> TcPluginM ()-tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)---findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult-findImportedModule mod_name mb_pkg = do-    hsc_env <- getTopEnv-    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg--lookupOrig :: Module -> OccName -> TcPluginM Name-lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod---tcLookupGlobal :: Name -> TcPluginM TyThing-tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal--tcLookupTyCon :: Name -> TcPluginM TyCon-tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon--tcLookupDataCon :: Name -> TcPluginM DataCon-tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon--tcLookupClass :: Name -> TcPluginM Class-tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass--tcLookup :: Name -> TcPluginM TcTyThing-tcLookup = unsafeTcPluginTcM . TcM.tcLookup--tcLookupId :: Name -> TcPluginM Id-tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId---getTopEnv :: TcPluginM HscEnv-getTopEnv = unsafeTcPluginTcM TcM.getTopEnv--getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)-getEnvs = unsafeTcPluginTcM TcM.getEnvs--getInstEnvs :: TcPluginM InstEnvs-getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs--getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)-getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs--matchFam :: TyCon -> [Type]-         -> TcPluginM (Maybe (TcCoercion, TcType))-matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args--newUnique :: TcPluginM Unique-newUnique = unsafeTcPluginTcM TcM.newUnique--newFlexiTyVar :: Kind -> TcPluginM TcTyVar-newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar--isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool-isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM---- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.-zonkTcType :: TcType -> TcPluginM TcType-zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType--zonkCt :: Ct -> TcPluginM Ct-zonkCt = unsafeTcPluginTcM . TcM.zonkCt----- | Create a new wanted constraint.-newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence-newWanted loc pty-  = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty)---- | Create a new derived constraint.-newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence-newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }---- | Create a new given constraint, with the supplied evidence.  This--- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it--- will panic.-newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence-newGiven loc pty evtm = do-   new_ev <- newEvVar pty-   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)-   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }---- | Create a fresh evidence variable.-newEvVar :: PredType -> TcPluginM EvVar-newEvVar = unsafeTcPluginTcM . TcM.newEvVar---- | Create a fresh coercion hole.-newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole---- | Bind an evidence variable.  This must not be invoked from--- 'tcPluginInit' or 'tcPluginStop', or it will panic.-setEvBind :: EvBind -> TcPluginM ()-setEvBind ev_bind = do-    tc_evbinds <- getEvBindsTcPluginM-    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind

@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 9.2.7.20230228+version: 9.2.8.20230729 license: BSD3 license-file: LICENSE category: Development@@ -82,11 +82,11 @@         array >= 0.1 && < 0.6,         deepseq >= 1.4 && < 1.5,         pretty == 1.1.*,-        transformers == 0.5.*,+        transformers >= 0.5 && < 0.7,         process >= 1 && < 1.7,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 9.2.7.20230228+        ghc-lib-parser == 9.2.8.20230729     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:         BangPatterns@@ -127,9 +127,7 @@         NoImplicitPrelude         ScopedTypeVariables     hs-source-dirs:-        ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build-        libraries/template-haskell         libraries/ghc-boot         libraries/ghci         compiler@@ -495,14 +493,11 @@         GHC.CmmToAsm.PPC.Regs         GHC.CmmToAsm.Ppr         GHC.CmmToAsm.Reg.Graph-        GHC.CmmToAsm.Reg.Graph.Base-        GHC.CmmToAsm.Reg.Graph.Coalesce         GHC.CmmToAsm.Reg.Graph.Spill         GHC.CmmToAsm.Reg.Graph.SpillClean         GHC.CmmToAsm.Reg.Graph.SpillCost         GHC.CmmToAsm.Reg.Graph.Stats         GHC.CmmToAsm.Reg.Graph.TrivColorable-        GHC.CmmToAsm.Reg.Graph.X86         GHC.CmmToAsm.Reg.Linear         GHC.CmmToAsm.Reg.Linear.AArch64         GHC.CmmToAsm.Reg.Linear.Base@@ -585,13 +580,10 @@         GHC.Data.Graph.Ppr         GHC.Data.Graph.UnVar         GHC.Data.UnionFind-        GHC.Driver.Backpack         GHC.Driver.CodeOutput         GHC.Driver.Main         GHC.Driver.Make-        GHC.Driver.MakeFile         GHC.Driver.Pipeline-        GHC.HandleEncoding         GHC.Hs.Stats         GHC.HsToCore         GHC.HsToCore.Arrows@@ -634,7 +626,6 @@         GHC.Iface.Tidy         GHC.Iface.Tidy.StaticPtrTable         GHC.IfaceToCore-        GHC.Linker         GHC.Linker.Dynamic         GHC.Linker.ExtraObj         GHC.Linker.Loader@@ -648,8 +639,6 @@         GHC.Llvm.Syntax         GHC.Llvm.Types         GHC.Parser.Utils-        GHC.Platform.Host-        GHC.Plugins         GHC.Rename.Bind         GHC.Rename.Env         GHC.Rename.Expr@@ -661,7 +650,6 @@         GHC.Rename.Splice         GHC.Rename.Unbound         GHC.Rename.Utils-        GHC.Runtime.Debugger         GHC.Runtime.Eval         GHC.Runtime.Heap.Inspect         GHC.Runtime.Interpreter@@ -734,7 +722,6 @@         GHC.Tc.Instance.FunDeps         GHC.Tc.Instance.Typeable         GHC.Tc.Module-        GHC.Tc.Plugin         GHC.Tc.Solver         GHC.Tc.Solver.Canonical         GHC.Tc.Solver.Interact@@ -763,13 +750,4 @@         GHC.Utils.Asm         GHC.Utils.Monad.State         GHCi.BinaryArray-        GHCi.CreateBCO-        GHCi.InfoTable-        GHCi.ObjLink         GHCi.ResolvedBCO-        GHCi.Run-        GHCi.Signals-        GHCi.StaticPtrTable-        GHCi.TH-        Language.Haskell.TH.CodeDo-        Language.Haskell.TH.Quote

@@ -1,12 +0,0 @@-module GHC.Platform.Host where--import GHC.Platform.ArchOS--hostPlatformArch :: Arch-hostPlatformArch = ArchX86_64--hostPlatformOS   :: OS-hostPlatformOS   = OSDarwin--hostPlatformArchOS :: ArchOS-hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS

@@ -1,32 +0,0 @@--- | See GHC #10762 and #15021.-module GHC.HandleEncoding (configureHandleEncoding) where--import Prelude -- See note [Why do we import Prelude here?]-import GHC.IO.Encoding (textEncodingName)-import System.Environment-import System.IO---- | Handle GHC-specific character encoding flags, allowing us to control how--- GHC produces output regardless of OS.-configureHandleEncoding :: IO ()-configureHandleEncoding = do-   env <- getEnvironment-   case lookup "GHC_CHARENC" env of-    Just "UTF-8" -> do-     hSetEncoding stdout utf8-     hSetEncoding stderr utf8-    _ -> do-     -- Avoid GHC erroring out when trying to display unhandled characters-     hSetTranslit stdout-     hSetTranslit stderr---- | Change the character encoding of the given Handle to transliterate--- on unsupported characters instead of throwing an exception-hSetTranslit :: Handle -> IO ()-hSetTranslit h = do-    menc <- hGetEncoding h-    case fmap textEncodingName menc of-        Just name | '/' `notElem` name -> do-            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"-            hSetEncoding h enc'-        _ -> return ()

@@ -1,205 +0,0 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-------  (c) The University of Glasgow 2002-2006------- | Create real byte-code objects from 'ResolvedBCO's.-module GHCi.CreateBCO (createBCOs) where--import Prelude -- See note [Why do we import Prelude here?]-import GHCi.ResolvedBCO-import GHCi.RemoteTypes-import GHCi.BreakArray-import GHC.Data.SizedSeq--import System.IO (fixIO)-import Control.Monad-import Data.Array.Base-import Foreign hiding (newArray)-import Unsafe.Coerce (unsafeCoerce)-import GHC.Arr          ( Array(..) )-import GHC.Exts-import GHC.IO-import Control.Exception ( ErrorCall(..) )--createBCOs :: [ResolvedBCO] -> IO [HValueRef]-createBCOs bcos = do-  let n_bcos = length bcos-  hvals <- fixIO $ \hvs -> do-     let arr = listArray (0, n_bcos-1) hvs-     mapM (createBCO arr) bcos-  mapM mkRemoteRef hvals--createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue-createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian-  = throwIO (ErrorCall $-        unlines [ "The endianness of the ResolvedBCO does not match"-                , "the systems endianness. Using ghc and iserv in a"-                , "mixed endianness setup is not supported!"-                ])-createBCO arr bco-   = -#if MIN_VERSION_ghc_prim(0, 7, 0)-     do linked_bco <- linkBCO' arr bco-#else-     do BCO bco# <- linkBCO' arr bco-#endif--        -- Note [Updatable CAF BCOs]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~-        -- Why do we need mkApUpd0 here?  Otherwise top-level-        -- interpreted CAFs don't get updated after evaluation.  A-        -- top-level BCO will evaluate itself and return its value-        -- when entered, but it won't update itself.  Wrapping the BCO-        -- in an AP_UPD thunk will take care of the update for us.-        ---        -- Furthermore:-        --   (a) An AP thunk *must* point directly to a BCO-        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk-        --   (c) An AP is always fully saturated, so we *can't* wrap-        --       non-zero arity BCOs in an AP thunk.-        ---        -- See #17424.-        if (resolvedBCOArity bco > 0)-           -#if MIN_VERSION_ghc_prim(0, 7, 0)-           then return (HValue (unsafeCoerce linked_bco))-           else case mkApUpd0# linked_bco of { (# final_bco #) ->-#else-           then return (HValue (unsafeCoerce# bco#))-           else case mkApUpd0# bco# of { (# final_bco #) ->-#endif--                  return (HValue final_bco) }---toWordArray :: UArray Int Word64 -> UArray Int Word-toWordArray = amap fromIntegral--linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO-linkBCO' arr ResolvedBCO{..} = do-  let-      ptrs   = ssElts resolvedBCOPtrs-      n_ptrs = sizeSS resolvedBCOPtrs--      !(I# arity#)  = resolvedBCOArity--      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]--      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b-      insns_barr = barr resolvedBCOInstrs-      bitmap_barr = barr (toWordArray resolvedBCOBitmap)-      literals_barr = barr (toWordArray resolvedBCOLits)--  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs-  IO $ \s ->-    case unsafeFreezeArray# marr s of { (# s, arr #) ->-    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->-    io s-    }}----- we recursively link any sub-BCOs while making the ptrs array-mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr-mkPtrsArray arr n_ptrs ptrs = do-  marr <- newPtrsArray (fromIntegral n_ptrs)-  let-    fill (ResolvedBCORef n) i =-      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!-    fill (ResolvedBCOPtr r) i = do-      hv <- localRef r-      writePtrsArrayHValue i hv marr-    fill (ResolvedBCOStaticPtr r) i = do-      writePtrsArrayPtr i (fromRemotePtr r)  marr-    fill (ResolvedBCOPtrBCO bco) i = do-      -#if MIN_VERSION_ghc_prim(0, 7, 0)-      bco <- linkBCO' arr bco-      writePtrsArrayBCO i bco marr-#else-      BCO bco# <- linkBCO' arr bco-      writePtrsArrayBCO i bco# marr-#endif--    fill (ResolvedBCOPtrBreakArray r) i = do-      BA mba <- localRef r-      writePtrsArrayMBA i mba marr-  zipWithM_ fill ptrs [0..]-  return marr--data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)--newPtrsArray :: Int -> IO PtrsArr-newPtrsArray (I# i) = IO $ \s ->-  case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)--writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()-writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->-  case writeArray# arr i hv s of s' -> (# s', () #)--writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()-writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->-  case writeArrayAddr# arr i a# s of s' -> (# s', () #)---- This is rather delicate: convincing GHC to pass an Addr# as an Any but--- without making a thunk turns out to be surprisingly tricky.-{-# NOINLINE writeArrayAddr# #-}-writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s-writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s---#if MIN_VERSION_ghc_prim(0, 7, 0)-writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()-#else-writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()-#endif--writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->-  case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)---#if MIN_VERSION_ghc_prim(0, 7, 0)-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()-#else-data BCO = BCO BCO#-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()-#endif--writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->-  case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)--newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO-newBCO instrs lits ptrs arity bitmap = IO $ \s ->-  -#if MIN_VERSION_ghc_prim(0, 7, 0)-  newBCO# instrs lits ptrs arity bitmap s-#else-  case newBCO# instrs lits ptrs arity bitmap s of-    (# s1, bco #) -> (# s1, BCO bco #)-#endif---{- Note [BCO empty array]-   ~~~~~~~~~~~~~~~~~~~~~~-Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:-they are 2-word heap objects.  So let's make a single empty array and-share it between all BCOs.--}--data EmptyArr = EmptyArr ByteArray#--{-# NOINLINE emptyArr #-}-emptyArr :: EmptyArr-emptyArr = unsafeDupablePerformIO $ IO $ \s ->-  case newByteArray# 0# s of { (# s, arr #) ->-  case unsafeFreezeByteArray# arr s of { (# s, farr #) ->-  (# s, EmptyArr farr #)-  }}

@@ -1,432 +0,0 @@-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}---- Get definitions for the structs, constants & config etc.-#include "Rts.h"---- |--- Run-time info table support.  This module provides support for--- creating and reading info tables /in the running program/.--- We use the RTS data structures directly via hsc2hs.----module GHCi.InfoTable-  (-    mkConInfoTable-  ) where--import Prelude hiding (fail) -- See note [Why do we import Prelude here?]--import Foreign-import Foreign.C-import GHC.Ptr-import GHC.Exts-import GHC.Exts.Heap-import Data.ByteString (ByteString)-import Control.Monad.Fail-import qualified Data.ByteString as BS-import GHC.Platform.Host (hostPlatformArch)-import GHC.Platform.ArchOS---- NOTE: Must return a pointer acceptable for use in the header of a closure.--- If tables_next_to_code is enabled, then it must point the 'code' field.--- Otherwise, it should point to the start of the StgInfoTable.-mkConInfoTable-   :: Bool    -- TABLES_NEXT_TO_CODE-   -> Int     -- ptr words-   -> Int     -- non-ptr words-   -> Int     -- constr tag-   -> Int     -- pointer tag-   -> ByteString  -- con desc-   -> IO (Ptr StgInfoTable)-      -- resulting info table is allocated with allocateExecPage(), and-      -- should be freed with freeExecPage().--mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do-  let entry_addr = interpConstrEntry !! ptrtag-  code' <- if tables_next_to_code-    then Just <$> mkJumpToAddr entry_addr-    else pure Nothing-  let-     itbl  = StgInfoTable {-                 entry = if tables_next_to_code-                         then Nothing-                         else Just entry_addr,-                 ptrs  = fromIntegral ptr_words,-                 nptrs = fromIntegral nonptr_words,-                 tipe  = CONSTR,-                 srtlen = fromIntegral tag,-                 code  = code'-              }-  castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc----- -------------------------------------------------------------------------------- Building machine code fragments for a constructor's entry code--funPtrToInt :: FunPtr a -> Int-funPtrToInt (FunPtr a) = I## (addr2Int## a)--mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes-mkJumpToAddr a = case hostPlatformArch of-    ArchSPARC -> pure $-        -- After some consideration, we'll try this, where-        -- 0x55555555 stands in for the address to jump to.-        -- According to includes/rts/MachRegs.h, %g3 is very-        -- likely indeed to be baggable.-        ---        --   0000 07155555              sethi   %hi(0x55555555), %g3-        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3-        --   0008 81C0C000              jmp     %g3-        --   000c 01000000              nop--        let w32 = fromIntegral (funPtrToInt a)--            hi22, lo10 :: Word32 -> Word32-            lo10 x = x .&. 0x3FF-            hi22 x = (x `shiftR` 10) .&. 0x3FFFF--        in Right [ 0x07000000 .|. (hi22 w32),-                   0x8610E000 .|. (lo10 w32),-                   0x81C0C000,-                   0x01000000 ]--    ArchPPC -> pure $-        -- We'll use r12, for no particular reason.-        -- 0xDEADBEEF stands for the address:-        -- 3D80DEAD lis r12,0xDEAD-        -- 618CBEEF ori r12,r12,0xBEEF-        -- 7D8903A6 mtctr r12-        -- 4E800420 bctr--        let w32 = fromIntegral (funPtrToInt a)-            hi16 x = (x `shiftR` 16) .&. 0xFFFF-            lo16 x = x .&. 0xFFFF-        in Right [ 0x3D800000 .|. hi16 w32,-                   0x618C0000 .|. lo16 w32,-                   0x7D8903A6, 0x4E800420 ]--    ArchX86 -> pure $-        -- Let the address to jump to be 0xWWXXYYZZ.-        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax-        -- which is-        -- B8 ZZ YY XX WW FF E0--        let w32 = fromIntegral (funPtrToInt a) :: Word32-            insnBytes :: [Word8]-            insnBytes-               = [0xB8, byte0 w32, byte1 w32,-                        byte2 w32, byte3 w32,-                  0xFF, 0xE0]-        in-            Left insnBytes--    ArchX86_64 -> pure $-        -- Generates:-        --      jmpq *.L1(%rip)-        --      .align 8-        -- .L1:-        --      .quad <addr>-        ---        -- which looks like:-        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>-        -- with addr at 10.-        ---        -- We need a full 64-bit pointer (we can't assume the info table is-        -- allocated in low memory).  Assuming the info pointer is aligned to-        -- an 8-byte boundary, the addr will also be aligned.--        let w64 = fromIntegral (funPtrToInt a) :: Word64-            insnBytes :: [Word8]-            insnBytes-               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,-                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,-                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]-        in-            Left insnBytes--    ArchAlpha -> pure $-        let w64 = fromIntegral (funPtrToInt a) :: Word64-        in Right [ 0xc3800000      -- br   at, .+4-                 , 0xa79c000c      -- ldq  at, 12(at)-                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well-                 , 0x47ff041f      -- nop-                 , fromIntegral (w64 .&. 0x0000FFFF)-                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]--    ArchARM {} -> pure $-        -- Generates Arm sequence,-        --      ldr r1, [pc, #0]-        --      bx r1-        ---        -- which looks like:-        --     00000000 <.addr-0x8>:-        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>-        --     4:       11ff2fe1    bx     r1-        let w32 = fromIntegral (funPtrToInt a) :: Word32-        in Left [ 0x00, 0x10, 0x9f, 0xe5-                , 0x11, 0xff, 0x2f, 0xe1-                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]--    ArchAArch64 {} -> pure $-        -- Generates:-        ---        --      ldr     x1, label-        --      br      x1-        -- label:-        --      .quad <addr>-        ---        -- which looks like:-        --     0:       58000041        ldr     x1, <label>-        --     4:       d61f0020        br      x1-       let w64 = fromIntegral (funPtrToInt a) :: Word64-       in Right [ 0x58000041-                , 0xd61f0020-                , fromIntegral w64-                , fromIntegral (w64 `shiftR` 32) ]--    ArchPPC_64 ELF_V1 -> pure $-        -- We use the compiler's register r12 to read the function-        -- descriptor and the linker's register r11 as a temporary-        -- register to hold the function entry point.-        -- In the medium code model the function descriptor-        -- is located in the first two gigabytes, i.e. the address-        -- of the function pointer is a non-negative 32 bit number.-        -- 0x0EADBEEF stands for the address of the function pointer:-        --    0:   3d 80 0e ad     lis     r12,0x0EAD-        --    4:   61 8c be ef     ori     r12,r12,0xBEEF-        --    8:   e9 6c 00 00     ld      r11,0(r12)-        --    c:   e8 4c 00 08     ld      r2,8(r12)-        --   10:   7d 69 03 a6     mtctr   r11-        --   14:   e9 6c 00 10     ld      r11,16(r12)-        --   18:   4e 80 04 20     bctr-       let  w32 = fromIntegral (funPtrToInt a)-            hi16 x = (x `shiftR` 16) .&. 0xFFFF-            lo16 x = x .&. 0xFFFF-       in Right [ 0x3D800000 .|. hi16 w32,-                  0x618C0000 .|. lo16 w32,-                  0xE96C0000,-                  0xE84C0008,-                  0x7D6903A6,-                  0xE96C0010,-                  0x4E800420]--    ArchPPC_64 ELF_V2 -> pure $-        -- The ABI requires r12 to point to the function's entry point.-        -- We use the medium code model where code resides in the first-        -- two gigabytes, so loading a non-negative32 bit address-        -- with lis followed by ori is fine.-        -- 0x0EADBEEF stands for the address:-        -- 3D800EAD lis r12,0x0EAD-        -- 618CBEEF ori r12,r12,0xBEEF-        -- 7D8903A6 mtctr r12-        -- 4E800420 bctr--        let w32 = fromIntegral (funPtrToInt a)-            hi16 x = (x `shiftR` 16) .&. 0xFFFF-            lo16 x = x .&. 0xFFFF-        in Right [ 0x3D800000 .|. hi16 w32,-                   0x618C0000 .|. lo16 w32,-                   0x7D8903A6, 0x4E800420 ]--    ArchS390X -> pure $-        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.-        -- The following code loads the address into scratch-        -- register r1 and jumps to it.-        ---        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD-        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH-        --   12:   07 F1                   br      %r1--        let w64 = fromIntegral (funPtrToInt a) :: Word64-        in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,-                  0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,-                  0x07, 0xF1 ]--    arch ->-      -- The arch isn't supported. You either need to add your architecture as a-      -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.-      fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("-             ++ show arch ++ ")"--byte0 :: (Integral w) => w -> Word8-byte0 w = fromIntegral w--byte1, byte2, byte3, byte4, byte5, byte6, byte7-       :: (Integral w, Bits w) => w -> Word8-byte1 w = fromIntegral (w `shiftR` 8)-byte2 w = fromIntegral (w `shiftR` 16)-byte3 w = fromIntegral (w `shiftR` 24)-byte4 w = fromIntegral (w `shiftR` 32)-byte5 w = fromIntegral (w `shiftR` 40)-byte6 w = fromIntegral (w `shiftR` 48)-byte7 w = fromIntegral (w `shiftR` 56)----- -------------------------------------------------------------------------------- read & write intfo tables---- entry point for direct returns for created constr itbls-foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr--interpConstrEntry :: [EntryFunPtr]-interpConstrEntry = [ error "pointer tag 0"-                    , stg_interp_constr1_entry-                    , stg_interp_constr2_entry-                    , stg_interp_constr3_entry-                    , stg_interp_constr4_entry-                    , stg_interp_constr5_entry-                    , stg_interp_constr6_entry-                    , stg_interp_constr7_entry ]--data StgConInfoTable = StgConInfoTable {-   conDesc   :: Ptr Word8,-   infoTable :: StgInfoTable-}---pokeConItbl-  :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable-  -> IO ()-pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do-  if tables_next_to_code-    then do-      -- Write the offset to the con_desc from the end of the standard InfoTable-      -- at the first byte.-      let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)-      (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset-    else do-      -- Write the con_desc address after the end of the info table.-      -- Use itblSize because CPP will not pick up PROFILING when calculating-      -- the offset.-      pokeByteOff wr_ptr itblSize (conDesc itbl)-  pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)--sizeOfEntryCode :: MonadFail m => Bool -> m Int-sizeOfEntryCode tables_next_to_code-  | not tables_next_to_code = pure 0-  | otherwise = do-     code' <- mkJumpToAddr undefined-     pure $ case code' of-       Left  xs -> sizeOf (head xs) * length xs-       Right xs -> sizeOf (head xs) * length xs---- Note: Must return proper pointer for use in a closure-#if MIN_VERSION_rts(1,0,1)-newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())-newExecConItbl tables_next_to_code obj con_desc = do-    sz0 <- sizeOfEntryCode tables_next_to_code-    let lcon_desc = BS.length con_desc + 1{- null terminator -}-        -- SCARY-        -- This size represents the number of bytes in an StgConInfoTable.-        sz = fromIntegral $ conInfoTableSizeB + sz0-            -- Note: we need to allocate the conDesc string next to the info-            -- table, because on a 64-bit platform we reference this string-            -- with a 32-bit offset relative to the info table, so if we-            -- allocated the string separately it might be out of range.--    ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do-        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz-                                    , infoTable = obj }-        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo-        BS.useAsCStringLen con_desc $ \(src, len) ->-            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len-        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)-        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)--    pure $ if tables_next_to_code-      then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB-      else castPtrToFunPtr ex_ptr-#else-newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())-newExecConItbl tables_next_to_code obj con_desc-   = alloca $ \pcode -> do-        sz0 <- sizeOfEntryCode tables_next_to_code-        let lcon_desc = BS.length con_desc + 1{- null terminator -}-            -- SCARY-            -- This size represents the number of bytes in an StgConInfoTable.-            sz = fromIntegral $ conInfoTableSizeB + sz0-               -- Note: we need to allocate the conDesc string next to the info-               -- table, because on a 64-bit platform we reference this string-               -- with a 32-bit offset relative to the info table, so if we-               -- allocated the string separately it might be out of range.-        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode-        ex_ptr <- peek pcode-        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz-                                    , infoTable = obj }-        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo-        BS.useAsCStringLen con_desc $ \(src, len) ->-            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len-        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)-        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)-        _flushExec sz ex_ptr -- Cache flush (if needed)-        pure $ if tables_next_to_code-          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB-          else castPtrToFunPtr ex_ptr-#endif---- | Allocate a buffer of a given size, use the given action to fill it with--- data, and mark it as executable. The action is given a writable pointer and--- the executable pointer. Returns a pointer to the executable code.-#if MIN_VERSION_rts(1,0,1)-fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)-#endif--#if MIN_VERSION_rts(1,0,2)--data ExecPage--foreign import ccall unsafe "allocateExecPage"-  _allocateExecPage :: IO (Ptr ExecPage)--foreign import ccall unsafe "freezeExecPage"-  _freezeExecPage :: Ptr ExecPage -> IO ()--fillExecBuffer sz cont-    -- we can only allocate single pages. This assumes a 4k page size which-    -- isn't strictly correct but is a reasonable conservative lower bound.-  | sz > 4096 = fail "withExecBuffer: Too large"-  | otherwise = do-        pg <- _allocateExecPage-        cont (castPtr pg) (castPtr pg)-        _freezeExecPage pg-        return (castPtr pg)--#elif MIN_VERSION_rts(1,0,1)--foreign import ccall unsafe "allocateExec"-  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)--foreign import ccall unsafe "flushExec"-  _flushExec :: CUInt -> Ptr a -> IO ()--fillExecBuffer sz cont = alloca $ \pcode -> do-    wr_ptr <- _allocateExec (fromIntegral sz) pcode-    ex_ptr <- peek pcode-    cont wr_ptr ex_ptr-    _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed)-    return (ex_ptr)--#else--foreign import ccall unsafe "allocateExec"-  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)--foreign import ccall unsafe "flushExec"-  _flushExec :: CUInt -> Ptr a -> IO ()---#endif---- -------------------------------------------------------------------------------- Constants and config--wORD_SIZE :: Int-wORD_SIZE = (#const SIZEOF_HSINT)--conInfoTableSizeB :: Int-conInfoTableSizeB = wORD_SIZE + itblSize

@@ -1,195 +0,0 @@-{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}------  (c) The University of Glasgow 2002-2006------- ------------------------------------------------------------------------------      The dynamic linker for object code (.o .so .dll files)--- ------------------------------------------------------------------------------- | Primarily, this module consists of an interface to the C-land--- dynamic linker.-module GHCi.ObjLink-  ( initObjLinker, ShouldRetainCAFs(..)-  , loadDLL-  , loadArchive-  , loadObj-  , unloadObj-  , purgeObj-  , lookupSymbol-  , lookupClosure-  , resolveObjs-  , addLibrarySearchPath-  , removeLibrarySearchPath-  , findSystemLibrary-  )  where--import Prelude -- See note [Why do we import Prelude here?]-import GHCi.RemoteTypes-import Control.Exception (throwIO, ErrorCall(..))-import Control.Monad    ( when )-import Foreign.C-import Foreign.Marshal.Alloc ( free )-import Foreign          ( nullPtr )-import GHC.Exts-import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )-import System.FilePath  ( dropExtension, normalise )------- ------------------------------------------------------------------------------ RTS Linker Interface--- -----------------------------------------------------------------------------data ShouldRetainCAFs-  = RetainCAFs-    -- ^ Retain CAFs unconditionally in linked Haskell code.-    -- Note that this prevents any code from being unloaded.-    -- It should not be necessary unless you are GHCi or-    -- hs-plugins, which needs to be able call any function-    -- in the compiled code.-  | DontRetainCAFs-    -- ^ Do not retain CAFs.  Everything reachable from foreign-    -- exports will be retained, due to the StablePtrs-    -- created by the module initialisation code.  unloadObj-    -- frees these StablePtrs, which will allow the CAFs to-    -- be GC'd and the code to be removed.--initObjLinker :: ShouldRetainCAFs -> IO ()-initObjLinker RetainCAFs = c_initLinker_ 1-initObjLinker _ = c_initLinker_ 0--lookupSymbol :: String -> IO (Maybe (Ptr a))-lookupSymbol str_in = do-   let str = prefixUnderscore str_in-   withCAString str $ \c_str -> do-     addr <- c_lookupSymbol c_str-     if addr == nullPtr-        then return Nothing-        else return (Just addr)--lookupClosure :: String -> IO (Maybe HValueRef)-lookupClosure str = do-  m <- lookupSymbol str-  case m of-    Nothing -> return Nothing-    Just (Ptr addr) -> case addrToAny# addr of-      (# a #) -> Just <$> mkRemoteRef (HValue a)--prefixUnderscore :: String -> String-prefixUnderscore- | cLeadingUnderscore = ('_':)- | otherwise          = id---- | loadDLL loads a dynamic library using the OS's native linker--- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either--- an absolute pathname to the file, or a relative filename--- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL--- searches the standard locations for the appropriate library.----loadDLL :: String -> IO (Maybe String)--- Nothing      => success--- Just err_msg => failure-loadDLL str0 = do-  let-     -- On Windows, addDLL takes a filename without an extension, because-     -- it tries adding both .dll and .drv.  To keep things uniform in the-     -- layers above, loadDLL always takes a filename with an extension, and-     -- we drop it here on Windows only.-     str | isWindowsHost = dropExtension str0-         | otherwise     = str0-  ---  maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll-  if maybe_errmsg == nullPtr-        then return Nothing-        else do str <- peekCString maybe_errmsg-                free maybe_errmsg-                return (Just str)--loadArchive :: String -> IO ()-loadArchive str = do-   withFilePath str $ \c_str -> do-     r <- c_loadArchive c_str-     when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed")))--loadObj :: String -> IO ()-loadObj str = do-   withFilePath str $ \c_str -> do-     r <- c_loadObj c_str-     when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed")))---- | @unloadObj@ drops the given dynamic library from the symbol table--- as well as enables the library to be removed from memory during--- a future major GC.-unloadObj :: String -> IO ()-unloadObj str =-   withFilePath str $ \c_str -> do-     r <- c_unloadObj c_str-     when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed")))---- | @purgeObj@ drops the symbols for the dynamic library from the symbol--- table. Unlike 'unloadObj', the library will not be dropped memory during--- a future major GC.-purgeObj :: String -> IO ()-purgeObj str =-   withFilePath str $ \c_str -> do-     r <- c_purgeObj c_str-     when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed")))--addLibrarySearchPath :: String -> IO (Ptr ())-addLibrarySearchPath str =-   withFilePath str c_addLibrarySearchPath--removeLibrarySearchPath :: Ptr () -> IO Bool-removeLibrarySearchPath = c_removeLibrarySearchPath--findSystemLibrary :: String -> IO (Maybe String)-findSystemLibrary str = do-    result <- withFilePath str c_findSystemLibrary-    case result == nullPtr of-        True  -> return Nothing-        False -> do path <- peekFilePath result-                    free result-                    return $ Just path--resolveObjs :: IO Bool-resolveObjs = do-   r <- c_resolveObjs-   return (r /= 0)---- ------------------------------------------------------------------------------ Foreign declarations to RTS entry points which does the real work;--- -----------------------------------------------------------------------------foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString-foreign import ccall unsafe "initLinker_"             c_initLinker_             :: CInt -> IO ()-foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)-foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int-foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int-foreign import ccall unsafe "purgeObj"                c_purgeObj                :: CFilePath -> IO Int-foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int-foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int-foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())-foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath-foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool---- -------------------------------------------------------------------------------- Configuration--#include "ghcautoconf.h"--cLeadingUnderscore :: Bool-#if defined(LEADING_UNDERSCORE)-cLeadingUnderscore = True-#else-cLeadingUnderscore = False-#endif--isWindowsHost :: Bool-#if defined(mingw32_HOST_OS)-isWindowsHost = True-#else-isWindowsHost = False-#endif

@@ -1,398 +0,0 @@-{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,-    UnboxedTuples #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- |--- Execute GHCi messages.------ For details on Remote GHCi, see Note [Remote GHCi] in--- compiler/GHC/Runtime/Interpreter.hs.----module GHCi.Run-  ( run, redirectInterrupts-  ) where--import Prelude -- See note [Why do we import Prelude here?]-import GHCi.CreateBCO-import GHCi.InfoTable-import GHCi.FFI-import GHCi.Message-import GHCi.ObjLink-import GHCi.RemoteTypes-import GHCi.TH-import GHCi.BreakArray-import GHCi.StaticPtrTable--import Control.Concurrent-import Control.DeepSeq-import Control.Exception-import Control.Monad-import Data.Binary-import Data.Binary.Get-import Data.ByteString (ByteString)-import qualified Data.ByteString.Unsafe as B-import GHC.Exts-import qualified GHC.Exts.Heap as Heap-import GHC.Stack-import Foreign hiding (void)-import Foreign.C-import GHC.Conc.Sync-import GHC.IO hiding ( bracket )-import System.Mem.Weak  ( deRefWeak )-import Unsafe.Coerce---- -------------------------------------------------------------------------------- Implement messages--foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()-        -- Make it "safe", just in case--run :: Message a -> IO a-run m = case m of-  InitLinker -> initObjLinker RetainCAFs-  RtsRevertCAFs -> rts_revertCAFs-  LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str-  LookupClosure str -> lookupClosure str-  LoadDLL str -> loadDLL str-  LoadArchive str -> loadArchive str-  LoadObj str -> loadObj str-  UnloadObj str -> unloadObj str-  AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str-  RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)-  ResolveObjs -> resolveObjs-  FindSystemLibrary str -> findSystemLibrary str-  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)-  FreeHValueRefs rs -> mapM_ freeRemoteRef rs-  AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr-  EvalStmt opts r -> evalStmt opts r-  ResumeStmt opts r -> resumeStmt opts r-  AbandonStmt r -> abandonStmt r-  EvalString r -> evalString r-  EvalStringToString r s -> evalStringToString r s-  EvalIO r -> evalIO r-  MkCostCentres mod ccs -> mkCostCentres mod ccs-  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)-  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz-  SetupBreakpoint ref ix cnt -> do-    arr <- localRef ref;-    _ <- setupBreakpoint arr ix cnt-    return ()-  BreakpointStatus ref ix -> do-    arr <- localRef ref; r <- getBreak arr ix-    case r of-      Nothing -> return False-      Just w -> return (w == 0)-  GetBreakpointVar ref ix -> do-    aps <- localRef ref-    mapM mkRemoteRef =<< getIdValFromApStack aps ix-  MallocData bs -> mkString bs-  MallocStrings bss -> mapM mkString0 bss-  PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res-  FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)-  MkConInfoTable tc ptrs nptrs tag ptrtag desc ->-    toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc-  StartTH -> startTH-  GetClosure ref -> do-    clos <- Heap.getClosureData =<< localRef ref-    mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos-  Seq ref -> doSeq ref-  ResumeSeq ref -> resumeSeq ref-  _other -> error "GHCi.Run.run"--evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])-evalStmt opts expr = do-  io <- mkIO expr-  sandboxIO opts $ do-    rs <- unsafeCoerce io :: IO [HValue]-    mapM mkRemoteRef rs- where-  mkIO (EvalThis href) = localRef href-  mkIO (EvalApp l r) = do-    l' <- mkIO l-    r' <- mkIO r-    return ((unsafeCoerce l' :: HValue -> HValue) r')--evalIO :: HValueRef -> IO (EvalResult ())-evalIO r = do-  io <- localRef r-  tryEval (unsafeCoerce io :: IO ())--evalString :: HValueRef -> IO (EvalResult String)-evalString r = do-  io <- localRef r-  tryEval $ do-    r <- unsafeCoerce io :: IO String-    evaluate (force r)--evalStringToString :: HValueRef -> String -> IO (EvalResult String)-evalStringToString r str = do-  io <- localRef r-  tryEval $ do-    r <- (unsafeCoerce io :: String -> IO String) str-    evaluate (force r)---- | Process the Seq message to force a value.                       #2950--- If during this processing a breakpoint is hit, return--- an EvalBreak value in the EvalStatus to the UI process,--- otherwise return an EvalComplete.--- The UI process has more and therefore also can show more--- information about the breakpoint than the current iserv--- process.-doSeq :: RemoteRef a -> IO (EvalStatus ())-doSeq ref = do-    sandboxIO evalOptsSeq $ do-      _ <- (void $ evaluate =<< localRef ref)-      return ()---- | Process a ResumeSeq message. Continue the :force processing     #2950--- after a breakpoint.-resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())-resumeSeq hvref = do-    ResumeContext{..} <- localRef hvref-    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $-      mask_ $ do-        putMVar resumeBreakMVar () -- this awakens the stopped thread...-        redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar--evalOptsSeq :: EvalOpts-evalOptsSeq = EvalOpts-              { useSandboxThread = True-              , singleStep = False-              , breakOnException = False-              , breakOnError = False-              }---- When running a computation, we redirect ^C exceptions to the running--- thread.  ToDo: we might want a way to continue even if the target--- thread doesn't die when it receives the exception... "this thread--- is not responding".------ Careful here: there may be ^C exceptions flying around, so we start the new--- thread blocked (forkIO inherits mask from the parent, #1048), and unblock--- only while we execute the user's code.  We can't afford to lose the final--- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)--sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)-sandboxIO opts io = do-  -- We are running in uninterruptibleMask-  breakMVar <- newEmptyMVar-  statusMVar <- newEmptyMVar-  withBreakAction opts breakMVar statusMVar $ do-    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io-    if useSandboxThread opts-       then do-         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar-                                -- empty: can't block-         redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar-       else-          -- GLUT on OS X needs to run on the main thread. If you-          -- try to use it from another thread then you just get a-          -- white rectangle rendered. For this, or anything else-          -- with such restrictions, you can turn the GHCi sandbox off-          -- and things will be run in the main thread.-          ---          -- BUT, note that the debugging features (breakpoints,-          -- tracing, etc.) need the expression to be running in a-          -- separate thread, so debugging is only enabled when-          -- using the sandbox.-         runIt---- We want to turn ^C into a break when -fbreak-on-exception is on,--- but it's an async exception and we only break for sync exceptions.--- Idea: if we catch and re-throw it, then the re-throw will trigger--- a break.  Great - but we don't want to re-throw all exceptions, because--- then we'll get a double break for ordinary sync exceptions (you'd have--- to :continue twice, which looks strange).  So if the exception is--- not "Interrupted", we unset the exception flag before throwing.----rethrow :: EvalOpts -> IO a -> IO a-rethrow EvalOpts{..} io =-  catch io $ \se -> do-    -- If -fbreak-on-error, we break unconditionally,-    --  but with care of not breaking twice-    if breakOnError && not breakOnException-       then poke exceptionFlag 1-       else case fromException se of-               -- If it is a "UserInterrupt" exception, we allow-               --  a possible break by way of -fbreak-on-exception-               Just UserInterrupt -> return ()-               -- In any other case, we don't want to break-               _ -> poke exceptionFlag 0-    throwIO se------- While we're waiting for the sandbox thread to return a result, if--- the current thread receives an asynchronous exception we re-throw--- it at the sandbox thread and continue to wait.------ This is for two reasons:------  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the---    computation to run its exception handlers before returning the---    exception result to the caller of runStmt.------  * clients of the GHC API can terminate a runStmt in progress---    without knowing the ThreadId of the sandbox thread (#1381)------ NB. use a weak pointer to the thread, so that the thread can still--- be considered deadlocked by the RTS and sent a BlockedIndefinitely--- exception.  A symptom of getting this wrong is that conc033(ghci)--- will hang.----redirectInterrupts :: ThreadId -> IO a -> IO a-redirectInterrupts target wait = do-  wtid <- mkWeakThreadId target-  wait `catch` \e -> do-     m <- deRefWeak wtid-     case m of-       Nothing -> wait-       Just target -> do throwTo target (e :: SomeException); wait--measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)-measureAlloc io = do-  setAllocationCounter 0                                 -- #16012-  a <- io-  ctr <- getAllocationCounter-  let allocs = negate $ fromIntegral ctr-  return (EvalComplete allocs a)---- Exceptions can't be marshaled because they're dynamically typed, so--- everything becomes a String.-tryEval :: IO a -> IO (EvalResult a)-tryEval io = do-  e <- try io-  case e of-    Left ex -> return (EvalException (toSerializableException ex))-    Right a -> return (EvalSuccess a)---- This function sets up the interpreter for catching breakpoints, and--- resets everything when the computation has stopped running.  This--- is a not-very-good way to ensure that only the interactive--- evaluation should generate breakpoints.-withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a-withBreakAction opts breakMVar statusMVar act- = bracket setBreakAction resetBreakAction (\_ -> act)- where-   setBreakAction = do-     stablePtr <- newStablePtr onBreak-     poke breakPointIOAction stablePtr-     when (breakOnException opts) $ poke exceptionFlag 1-     when (singleStep opts) $ setStepFlag-     return stablePtr-        -- Breaking on exceptions is not enabled by default, since it-        -- might be a bit surprising.  The exception flag is turned off-        -- as soon as it is hit, or in resetBreakAction below.--   onBreak :: BreakpointCallback-   onBreak ix# uniq# is_exception apStack = do-     tid <- myThreadId-     let resume = ResumeContext-           { resumeBreakMVar = breakMVar-           , resumeStatusMVar = statusMVar-           , resumeThreadId = tid }-     resume_r <- mkRemoteRef resume-     apStack_r <- mkRemoteRef apStack-     ccs <- toRemotePtr <$> getCCSOf apStack-     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs-     takeMVar breakMVar--   resetBreakAction stablePtr = do-     poke breakPointIOAction noBreakStablePtr-     poke exceptionFlag 0-     resetStepFlag-     freeStablePtr stablePtr--resumeStmt-  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])-  -> IO (EvalStatus [HValueRef])-resumeStmt opts hvref = do-  ResumeContext{..} <- localRef hvref-  withBreakAction opts resumeBreakMVar resumeStatusMVar $-    mask_ $ do-      putMVar resumeBreakMVar () -- this awakens the stopped thread...-      redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar---- when abandoning a computation we have to---      (a) kill the thread with an async exception, so that the---          computation itself is stopped, and---      (b) fill in the MVar.  This step is necessary because any---          thunks that were under evaluation will now be updated---          with the partial computation, which still ends in takeMVar,---          so any attempt to evaluate one of these thunks will block---          unless we fill in the MVar.---      (c) wait for the thread to terminate by taking its status MVar.  This---          step is necessary to prevent race conditions with---          -fbreak-on-exception (see #5975).---  See test break010.-abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()-abandonStmt hvref = do-  ResumeContext{..} <- localRef hvref-  killThread resumeThreadId-  putMVar resumeBreakMVar ()-  _ <- takeMVar resumeStatusMVar-  return ()--foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt-foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt--setStepFlag :: IO ()-setStepFlag = poke stepFlag 1-resetStepFlag :: IO ()-resetStepFlag = poke stepFlag 0--type BreakpointCallback-     = Int#    -- the breakpoint index-    -> Int#    -- the module uniq-    -> Bool    -- exception?-    -> HValue  -- the AP_STACK, or exception-    -> IO ()--foreign import ccall "&rts_breakpoint_io_action"-   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)--noBreakStablePtr :: StablePtr BreakpointCallback-noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction--noBreakAction :: BreakpointCallback-noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"-noBreakAction _ _ True  _ = return () -- exception: just continue---- Malloc and copy the bytes.  We don't have any way to monitor the--- lifetime of this memory, so it just leaks.-mkString :: ByteString -> IO (RemotePtr ())-mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do-  ptr <- mallocBytes len-  copyBytes ptr cstr len-  return (castRemotePtr (toRemotePtr ptr))--mkString0 :: ByteString -> IO (RemotePtr ())-mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do-  ptr <- mallocBytes (len+1)-  copyBytes ptr cstr len-  pokeElemOff (ptr :: Ptr CChar) len 0-  return (castRemotePtr (toRemotePtr ptr))--mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]-#if defined(PROFILING)-mkCostCentres mod ccs = do-  c_module <- newCString mod-  mapM (mk_one c_module) ccs- where-  mk_one c_module (decl_path,srcspan) = do-    c_name <- newCString decl_path-    c_srcspan <- newCString srcspan-    toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan--foreign import ccall unsafe "mkCostCentre"-  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)-#else-mkCostCentres _ _ = return []-#endif--getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)-getIdValFromApStack apStack (I# stackDepth) = do-   case getApStackVal# apStack stackDepth of-        (# ok, result #) ->-            case ok of-              0# -> return Nothing -- AP_STACK not found-              _  -> return (Just (unsafeCoerce# result))

@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}-module GHCi.Signals (installSignalHandlers) where--import Prelude -- See note [Why do we import Prelude here?]-import Control.Concurrent-import Control.Exception-import System.Mem.Weak  ( deRefWeak )--#if !defined(mingw32_HOST_OS)-import System.Posix.Signals-#endif--#if defined(mingw32_HOST_OS)-import GHC.ConsoleHandler-#endif---- | Install standard signal handlers for catching ^C, which just throw an---   exception in the target thread.  The current target thread is the---   thread at the head of the list in the MVar passed to---   installSignalHandlers.-installSignalHandlers :: IO ()-installSignalHandlers = do-  main_thread <- myThreadId-  wtid <- mkWeakThreadId main_thread--  let interrupt = do-        r <- deRefWeak wtid-        case r of-          Nothing -> return ()-          Just t  -> throwTo t UserInterrupt--#if !defined(mingw32_HOST_OS)-  _ <- installHandler sigQUIT  (Catch interrupt) Nothing-  _ <- installHandler sigINT   (Catch interrupt) Nothing-#else-  -- GHC 6.3+ has support for console events on Windows-  -- NOTE: running GHCi under a bash shell for some reason requires-  -- you to press Ctrl-Break rather than Ctrl-C to provoke-  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know-  -- why --SDM 17/12/2004-  let sig_handler ControlC = interrupt-      sig_handler Break    = interrupt-      sig_handler _        = return ()--  _ <- installHandler (Catch sig_handler)-#endif-  return ()

@@ -1,25 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ForeignFunctionInterface #-}--module GHCi.StaticPtrTable ( sptAddEntry ) where--import Prelude -- See note [Why do we import Prelude here?]-import Data.Word-import Foreign-import GHC.Fingerprint-import GHCi.RemoteTypes---- | Used by GHCi to add an SPT entry for a set of interactive bindings.-sptAddEntry :: Fingerprint -> HValue -> IO ()-sptAddEntry (Fingerprint a b) (HValue x) = do-    -- We own the memory holding the key (fingerprint) which gets inserted into-    -- the static pointer table and can't free it until the SPT entry is removed-    -- (which is currently never).-    fpr_ptr <- newArray [a,b]-    sptr <- newStablePtr x-    ent_ptr <- malloc-    poke ent_ptr (castStablePtrToPtr sptr)-    spt_insert_stableptr fpr_ptr ent_ptr--foreign import ccall "hs_spt_insert_stableptr"-    spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO ()

@@ -1,272 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,-    TupleSections, RecordWildCards, InstanceSigs, CPP #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}---- |--- Running TH splices----module GHCi.TH-  ( startTH-  , runModFinalizerRefs-  , runTH-  , GHCiQException(..)-  ) where--{- Note [Remote Template Haskell]--Here is an overview of how TH works with -fexternal-interpreter.--Initialisation-~~~~~~~~~~~~~~--GHC sends a StartTH message to the server (see GHC.Tc.Gen.Splice.getTHState):--   StartTH :: Message (RemoteRef (IORef QState))--The server creates an initial QState object, makes an IORef to it, and-returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below).--This happens once per module, the first time we need to run a TH-splice.  The reference that GHC gets back is kept in-tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call-that follows.---For each splice-~~~~~~~~~~~~~~~--1. GHC compiles a splice to byte code, and sends it to the server: in-   a CreateBCOs message:--   CreateBCOs :: [LB.ByteString] -> Message [HValueRef]--2. The server creates the real byte-code objects in its heap, and-   returns HValueRefs to GHC.  HValueRef is the same as RemoteRef-   HValue.--3. GHC sends a RunTH message to the server:--  RunTH-   :: RemoteRef (IORef QState)-        -- The state returned by StartTH in step1-   -> HValueRef-        -- The HValueRef we got in step 4, points to the code for the splice-   -> THResultType-        -- Tells us what kind of splice this is (decl, expr, type, etc.)-   -> Maybe TH.Loc-        -- Source location-   -> Message (QResult ByteString)-        -- Eventually it will return a QResult back to GHC.  The-        -- ByteString here is the (encoded) result of the splice.--4. The server runs the splice code.--5. Each time the splice code calls a method of the Quasi class, such-   as qReify, a message is sent from the server to GHC.  These-   messages are defined by the THMessage type.  GHC responds with the-   result of the request, e.g. in the case of qReify it would be the-   TH.Info for the requested entity.--6. When the splice has been fully evaluated, the server sends-   RunTHDone back to GHC.  This tells GHC that the server has finished-   sending THMessages and will send the QResult next.--8. The server then sends a QResult back to GHC, which is notionally-   the response to the original RunTH message.  The QResult indicates-   whether the splice succeeded, failed, or threw an exception.---After typechecking-~~~~~~~~~~~~~~~~~~--GHC sends a FinishTH message to the server (see GHC.Tc.Gen.Splice.finishTH).-The server runs any finalizers that were added by addModuleFinalizer.---Other Notes on TH / Remote GHCi--  * Note [Remote GHCi] in compiler/GHC/Runtime/Interpreter.hs-  * Note [External GHCi pointers] in compiler/GHC/Runtime/Interpreter.hs-  * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice--}--import Prelude -- See note [Why do we import Prelude here?]-import GHCi.Message-import GHCi.RemoteTypes-import GHC.Serialized--import Control.Exception-import Control.Monad.IO.Class (MonadIO (..))-import Data.Binary-import Data.Binary.Put-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as LB-import Data.Data-import Data.Dynamic-import Data.Either-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as M-import Data.Maybe-import GHC.Desugar-import qualified Language.Haskell.TH        as TH-import qualified Language.Haskell.TH.Syntax as TH-import Unsafe.Coerce---- | Create a new instance of 'QState'-initQState :: Pipe -> QState-initQState p = QState M.empty Nothing p---- | The monad in which we run TH computations on the server-newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }---- | The exception thrown by "fail" in the GHCiQ monad-data GHCiQException = GHCiQException QState String-  deriving Show--instance Exception GHCiQException--instance Functor GHCiQ where-  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s--instance Applicative GHCiQ where-  f <*> a = GHCiQ $ \s ->-    do (f',s')  <- runGHCiQ f s-       (a',s'') <- runGHCiQ a s'-       return (f' a', s'')-  pure x = GHCiQ (\s -> return (x,s))--instance Monad GHCiQ where-  m >>= f = GHCiQ $ \s ->-    do (m', s')  <- runGHCiQ m s-       (a,  s'') <- runGHCiQ (f m') s'-       return (a, s'')--instance MonadFail GHCiQ where-  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)--getState :: GHCiQ QState-getState = GHCiQ $ \s -> return (s,s)--noLoc :: TH.Loc-noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)---- | Send a 'THMessage' to GHC and return the result.-ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a-ghcCmd m = GHCiQ $ \s -> do-  r <- remoteTHCall (qsPipe s) m-  case r of-    THException str -> throwIO (GHCiQException s str)-    THComplete res -> return (res, s)--instance MonadIO GHCiQ where-  liftIO m = GHCiQ $ \s -> fmap (,s) m--instance TH.Quasi GHCiQ where-  qNewName str = ghcCmd (NewName str)-  qReport isError msg = ghcCmd (Report isError msg)--  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice-  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do-    remoteTHCall (qsPipe s) StartRecover-    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s-    remoteTHCall (qsPipe s) (EndRecover (isLeft e))-    case e of-      Left GHCiQException{} -> h s-      Right r -> return r-  qLookupName isType occ = ghcCmd (LookupName isType occ)-  qReify name = ghcCmd (Reify name)-  qReifyFixity name = ghcCmd (ReifyFixity name)-  qReifyType name = ghcCmd (ReifyType name)-  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)-  qReifyRoles name = ghcCmd (ReifyRoles name)--  -- To reify annotations, we send GHC the AnnLookup and also the-  -- TypeRep of the thing we're looking for, to avoid needing to-  -- serialize irrelevant annotations.-  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]-  qReifyAnnotations lookup =-    map (deserializeWithData . B.unpack) <$>-      ghcCmd (ReifyAnnotations lookup typerep)-    where typerep = typeOf (undefined :: a)--  qReifyModule m = ghcCmd (ReifyModule m)-  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)-  qLocation = fromMaybe noLoc . qsLocation <$> getState-  qAddDependentFile file = ghcCmd (AddDependentFile file)-  qAddTempFile suffix = ghcCmd (AddTempFile suffix)-  qAddTopDecls decls = ghcCmd (AddTopDecls decls)-  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)-  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=-                         ghcCmd . AddModFinalizer-  qAddCorePlugin str = ghcCmd (AddCorePlugin str)-  qGetQ = GHCiQ $ \s ->-    let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a-        lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m-    in return (lookup (qsMap s), s)-  qPutQ k = GHCiQ $ \s ->-    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })-  qIsExtEnabled x = ghcCmd (IsExtEnabled x)-  qExtsEnabled = ghcCmd ExtsEnabled-  qPutDoc l s = ghcCmd (PutDoc l s)-  qGetDoc l = ghcCmd (GetDoc l)---- | The implementation of the 'StartTH' message: create--- a new IORef QState, and return a RemoteRef to it.-startTH :: IO (RemoteRef (IORef QState))-startTH = do-  r <- newIORef (initQState (error "startTH: no pipe"))-  mkRemoteRef r---- | Runs the mod finalizers.------ The references must be created on the caller process.-runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)-                    -> [RemoteRef (TH.Q ())]-                    -> IO ()-runModFinalizerRefs pipe rstate qrefs = do-  qs <- mapM localRef qrefs-  qstateref <- localRef rstate-  qstate <- readIORef qstateref-  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }-  return ()---- | The implementation of the 'RunTH' message-runTH-  :: Pipe-  -> RemoteRef (IORef QState)-      -- ^ The TH state, created by 'startTH'-  -> HValueRef-      -- ^ The splice to run-  -> THResultType-      -- ^ What kind of splice it is-  -> Maybe TH.Loc-      -- ^ The source location-  -> IO ByteString-      -- ^ Returns an (encoded) result that depends on the THResultType--runTH pipe rstate rhv ty mb_loc = do-  hv <- localRef rhv-  case ty of-    THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)-    THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)-    THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)-    THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])-    THAnnWrapper -> do-      hv <- unsafeCoerce <$> localRef rhv-      case hv :: AnnotationWrapper of-        AnnotationWrapper thing -> return $!-          LB.toStrict (runPut (put (toSerialized serializeWithData thing)))---- | Run a Q computation.-runTHQ-  :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a-  -> IO ByteString-runTHQ pipe rstate mb_loc ghciq = do-  qstateref <- localRef rstate-  qstate <- readIORef qstateref-  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }-  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st-  writeIORef qstateref new_state-  return $! LB.toStrict (runPut (put r))

@@ -1,20 +0,0 @@--- | This module exists to work nicely with the QualifiedDo--- extension.--- @--- import qualified Language.Haskell.TH.CodeDo as Code--- myExample :: Monad m => Code m a -> Code m a -> Code m a--- myExample opt1 opt2 =---   Code.do---    x <- someSideEffect               -- This one is of type `M Bool`---    if x then opt1 else opt2--- @-module Language.Haskell.TH.CodeDo((>>=), (>>)) where--import Language.Haskell.TH.Syntax-import Prelude(Monad)---- | Module over monad operator for 'Code'-(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b-(>>=) = bindCode-(>>) :: Monad m => m a -> Code m b -> Code m b-(>>)  = bindCode_

@@ -1,57 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-}-{- |-Module : Language.Haskell.TH.Quote-Description : Quasi-quoting support for Template Haskell--Template Haskell supports quasiquoting, which permits users to construct-program fragments by directly writing concrete syntax.  A quasiquoter is-essentially a function with takes a string to a Template Haskell AST.-This module defines the 'QuasiQuoter' datatype, which specifies a-quasiquoter @q@ which can be invoked using the syntax-@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language-extension is enabled, and some utility functions for manipulating-quasiquoters.  Nota bene: this package does not define any parsers,-that is up to you.--}-module Language.Haskell.TH.Quote(-        QuasiQuoter(..),-        quoteFile,-        -- * For backwards compatibility-        dataToQa, dataToExpQ, dataToPatQ-    ) where--import Language.Haskell.TH.Syntax-import Prelude---- | The 'QuasiQuoter' type, a value @q@ of this type can be used--- in the syntax @[q| ... string to parse ...|]@.  In fact, for--- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters--- to be used in different splice contexts; if you are only interested--- in defining a quasiquoter to be used for expressions, you would--- define a 'QuasiQuoter' with only 'quoteExp', and leave the other--- fields stubbed out with errors.-data QuasiQuoter = QuasiQuoter {-    -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@-    quoteExp  :: String -> Q Exp,-    -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@-    quotePat  :: String -> Q Pat,-    -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@-    quoteType :: String -> Q Type,-    -- | Quasi-quoter for declarations, invoked by top-level quotes-    quoteDec  :: String -> Q [Dec]-    }---- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read--- the data out of a file.  For example, suppose @asmq@ is an--- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]--- as an expression. Then if you define @asmq_f = quoteFile asmq@, then--- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead--- of the inline text-quoteFile :: QuasiQuoter -> QuasiQuoter-quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) -  = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }-  where-   get :: (String -> Q a) -> String -> Q a-   get old_quoter file_name = do { file_cts <- runIO (readFile file_name) -                                 ; addDependentFile file_name-                                 ; old_quoter file_cts }