ghc-lib 9.6.2.20230523 → 9.6.2.20231121

raw patch · 23 files changed

+6/−5510 lines, 23 filesdep ~containersdep ~deepseqdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: containers, deepseq, ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC/Cmm/Reducibility.hs +0/−224
• 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/Data/Graph/Collapse.hs +0/−264
• compiler/GHC/Data/Graph/Inductive/Graph.hs +0/−643
• compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs +0/−346
• compiler/GHC/Driver/Backpack.hs +0/−944
• compiler/GHC/Driver/MakeFile.hs +0/−454
• compiler/GHC/Linker.hs +0/−36
• compiler/GHC/Runtime/Debugger.hs +0/−271
• compiler/GHC/Tc/Plugin.hs +0/−194
• ghc-lib.cabal +6/−31
• libraries/ghc-boot/GHC/HandleEncoding.hs +0/−32
• libraries/ghci/GHCi/CreateBCO.hs +0/−211
• libraries/ghci/GHCi/InfoTable.hsc +0/−419
• 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/−273
• libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +0/−22
• libraries/template-haskell/Language/Haskell/TH/Quote.hs +0/−57

@@ -1,224 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{-|-Module      : GHC.Cmm.Reducibility-Description : Tell if a `CmmGraph` is reducible, or make it so--Test a Cmm control-flow graph for reducibility.  And provide a-function that, when given an arbitrary control-flow graph, returns an-equivalent, reducible control-flow graph.  The equivalent graph is-obtained by "splitting" (copying) nodes of the original graph.-The resulting equivalent graph has the same dynamic behavior as the-original, but it is larger.--Documentation uses the language of control-flow analysis, in which a-basic block is called a "node."  These "nodes" are `CmmBlock`s or-equivalent; they have nothing to do with a `CmmNode`.--For more on reducibility and related analyses and algorithms, see-Note [Reducibility resources]--}--module GHC.Cmm.Reducibility-  ( Reducibility(..)-  , reducibility--  , asReducible-  )-where--import GHC.Prelude hiding (splitAt, succ)--import Control.Monad-import Data.List (nub)-import Data.Maybe-import Data.Semigroup-import qualified Data.Sequence as Seq--import GHC.Cmm-import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dominators-import GHC.Cmm.Dataflow.Graph hiding (addBlock)-import GHC.Cmm.Dataflow.Label-import GHC.Data.Graph.Collapse-import GHC.Data.Graph.Inductive.Graph-import GHC.Data.Graph.Inductive.PatriciaTree-import GHC.Types.Unique.Supply-import GHC.Utils.Panic---- | Represents the result of a reducibility analysis.-data Reducibility = Reducible | Irreducible-  deriving (Eq, Show)---- | Given a graph, say whether the graph is reducible.  The graph must--- be bundled with a dominator analysis and a reverse postorder--- numbering, as these results are needed to perform the test.--reducibility :: NonLocal node-             => GraphWithDominators node-             -> Reducibility-reducibility gwd =-    if all goodBlock blockmap then Reducible else Irreducible-  where goodBlock b = all (goodEdge (entryLabel b)) (successors b)-        goodEdge from to = rpnum to > rpnum from || to `dominates` from-        rpnum = gwdRPNumber gwd-        blockmap = graphMap $ gwd_graph gwd-        dominators = gwdDominatorsOf gwd-        dominates lbl blockname =-            lbl == blockname || dominatorsMember lbl (dominators blockname)---- | Given a graph, return an equivalent reducible graph, by--- "splitting" (copying) nodes if necessary.  The input--- graph must be bundled with a dominator analysis and a reverse--- postorder numbering.  The computation is monadic because when a--- node is split, the new copy needs a fresh label.------ Use this function whenever a downstream algorithm needs a reducible--- control-flow graph.--asReducible :: GraphWithDominators CmmNode-            -> UniqSM (GraphWithDominators CmmNode)-asReducible gwd = case reducibility gwd of-                    Reducible -> return gwd-                    Irreducible -> assertReducible <$> nodeSplit gwd--assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode-assertReducible gwd = case reducibility gwd of-                        Reducible -> gwd-                        Irreducible -> panic "result not reducible"---------------------------------------------------------------------- | Split one or more nodes of the given graph, which must be--- irreducible.--nodeSplit :: GraphWithDominators CmmNode-          -> UniqSM (GraphWithDominators CmmNode)-nodeSplit gwd =-    graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed-  where g = gwd_graph gwd-        collapsed :: NullCollapseViz (Gr CmmSuper ())-        collapsed = collapseInductiveGraph (cgraphOfCmm g)--type CGraph = Gr CmmSuper ()---- | Turn a collapsed supernode back into a control-flow graph-inflate :: Label -> CGraph -> CmmGraph-inflate entry cg = CmmGraph entry graph-  where graph = GMany NothingO body NothingO-        body :: LabelMap CmmBlock-        body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $-               blocks super-        super = case labNodes cg of-                  [(_, s)] -> s-                  _ -> panic "graph given to `inflate` is not singleton"----- | Convert a `CmmGraph` into an inductive graph.--- (The function coalesces duplicate edges into a single edge.)-cgraphOfCmm :: CmmGraph -> CGraph-cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks-   where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)-         cnodes = [(k, super block) | (k, block) <- blocks]-          where super block = Nodes (entryLabel block) (Seq.singleton block)-         labelNumber = \lbl -> fromJust $ mapLookup lbl numbers-             where numbers :: LabelMap Int-                   numbers = mapFromList $ map swap blocks-                   swap (k, block) = (entryLabel block, k)-         addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph-         addSuccEdges graph (k, block) =-             insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph-{--Note [Reducibility resources]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.-Available to borrow from archive.org.--Matthew S. Hecht and Jeffrey D. Ullman (1972).-Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.-https://doi.org/10.1137/0201014--Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with-controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),-1031–1052. DOI:https://doi.org/10.1145/267959.269971--Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:-optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July-2002), 299–333. https://doi.org/10.1145/567097.567098.  (This one-contains the most detailed account of how the Hecht/Ullman algorithm-is used to modify an actual control-flow graph.  But still not much detail.)--https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html- (Nice summary of useful facts)---}----type Seq = Seq.Seq---- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.--- The entry point is the given label, and the block with that label--- dominates all the other blocks in the supernode.  When an entire--- graph is collapsed into a single supernode, the graph is reducible.--- More detail can be found in "GHC.Data.Graph.Collapse".--data CmmSuper-    = Nodes { label :: Label-            , blocks :: Seq CmmBlock-            }--instance Semigroup CmmSuper where-  s <> s' = Nodes (label s) (blocks s <> blocks s')--instance PureSupernode CmmSuper where-  superLabel = label-  mapLabels = changeLabels--instance Supernode CmmSuper NullCollapseViz where-  freshen s = liftUniqSM $ relabel s----- | Return all labels defined within a supernode.-definedLabels :: CmmSuper -> Seq Label-definedLabels = fmap entryLabel . blocks------ | Map the given function over every use and definition of a label--- in the given supernode.-changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)-changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks)---- | Map the given function over every use and definition of a label--- in the given block.-changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock-changeBlockLabels f block = blockJoin entry' middle exit'-  where (entry, middle, exit) = blockSplit block-        entry' = let CmmEntry l scope = entry-                 in  CmmEntry (f l) scope-        exit' = case exit of-                  -- unclear why mapSuccessors doesn't touch these-                  CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) }-                  CmmForeignCall { succ = l } -> exit { succ = f l }-                  _ -> mapSuccessors f exit----- | Within the given supernode, replace every defined label (and all--- of its uses) with a fresh label.--relabel :: CmmSuper -> UniqSM CmmSuper-relabel node = do-     finite_map <- foldM addPair mapEmpty $ definedLabels node-     return $ changeLabels (labelChanger finite_map) node-  where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)-        addPair map old = do new <- newBlockId-                             return $ mapInsert old new map-        labelChanger :: LabelMap Label -> (Label -> Label)-        labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping

@@ -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 -> not (isEmptyUniqSet s)-                                     && sizeUniqSet s <= neighbors)-                        $ powersetLS regsC--        -- for each of the subsets of C, the regs which conflict-        -- with possibilities 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,264 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module GHC.Data.Graph.Collapse-  ( PureSupernode(..)-  , Supernode(..)-  , collapseInductiveGraph-  , VizCollapseMonad(..)-  , NullCollapseViz(..)-  , runNullCollapse-  , MonadUniqSM(..)-  )-where--import GHC.Prelude--import Control.Exception-import Control.Monad-import Data.List (delete, union, insert, intersect)-import Data.Semigroup--import GHC.Cmm.Dataflow.Label-import GHC.Data.Graph.Inductive.Graph-import GHC.Types.Unique.Supply-import GHC.Utils.Panic---{-|-Module      : GHC.Data.Graph.Collapse-Description : Implement the "collapsing" algorithm Hecht and Ullman--A control-flow graph is reducible if and only if it is collapsible-according to the definition of Hecht and Ullman (1972).   This module-implements the collapsing algorithm of Hecht and Ullman, and if it-encounters a graph that is not collapsible, it splits nodes until the-graph is fully collapsed.  It then reports what nodes (if any) had to-be split in order to collapse the graph.  The information is used-upstream to node-split Cmm graphs.--The module uses the inductive graph representation cloned from the-Functional Graph Library (Hackage package `fgl`, modules-`GHC.Data.Graph.Inductive.*`.)---}---- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman--- (1972).  Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.--- https://doi.org/10.1137/0201014--------------------- Graph-splitting monad --------------------------- | If you want to visualize the graph-collapsing algorithm, create--- an instance of monad `VizCollapseMonad`.  Each step in the--- algorithm is announced to the monad as a side effect.  If you don't--- care about visualization, you would use the `NullCollapseViz`--- monad, in which these operations are no-ops.--class (Monad m) => MonadUniqSM m where-  liftUniqSM :: UniqSM a -> m a--class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where-  consumeByInGraph :: Node -> Node -> gr s () -> m ()-  splitGraphAt :: gr s () -> LNode s -> m ()-  finalGraph :: gr s () -> m ()------ | The identity monad as a `VizCollapseMonad`.  Use this monad when--- you want efficiency in graph collapse.-newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqSM a }-  deriving (Functor, Applicative, Monad, MonadUnique)--instance MonadUniqSM NullCollapseViz where-  liftUniqSM = NullCollapseViz--instance (Graph gr, Supernode s NullCollapseViz) =>-    VizCollapseMonad NullCollapseViz gr s where-  consumeByInGraph _ _ _ = return ()-  splitGraphAt _ _ = return ()-  finalGraph _ = return ()--runNullCollapse :: NullCollapseViz a -> UniqSM a-runNullCollapse = unNCV--------------------- Utility functions on graphs ---------------------------- | Tell if a `Node` has a single predecessor.-singlePred :: Graph gr => gr a b -> Node -> Bool-singlePred gr n-    | ([_], _, _, _) <- context gr n = True-    | otherwise = False---- | Use this function to extract information about a `Node` that you--- know is in a `Graph`.  It's like `match` from `Graph`, but it must--- succeed.-forceMatch :: (Graph gr)-           => Node -> gr s b -> (Context s b, gr s b)-forceMatch node g = case match node g of (Just c, g') -> (c, g')-                                         _ -> panicDump node g- where panicDump :: Graph gr => Node -> gr s b -> any-       panicDump k _g =-         panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k---- | Rewrite the label of a given node.-updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b-updateNode relabel node g = (preds, n, relabel this, succs) & g'-    where ((preds, n, this, succs), g') = forceMatch node g----- | Test if a graph has but a single node.-singletonGraph :: Graph gr => gr a b -> Bool-singletonGraph g = case labNodes g of [_] -> True-                                      _ -> False-------------------  Supernodes ---------------------------------------- | A "supernode" stands for a collection of one or more nodes (basic--- blocks) that have been coalesced by the Hecht-Ullman algorithm.--- A collection in a supernode constitutes a /reducible/ subgraph of a--- control-flow graph.  (When an entire control-flow graph is collapsed--- to a single supernode, the flow graph is reducible.)------ The idea of node splitting is to collapse a control-flow graph down--- to a single supernode, then materialize (``inflate'') the reducible--- equivalent graph from that supernode.  The `Supernode` class--- defines only the methods needed to collapse; rematerialization is--- the responsiblity of the client.------ During the Hecht-Ullman algorithm, every supernode has a unique--- entry point, which is given by `superLabel`.  But this invariant is--- not guaranteed by the class methods and is not a law of the class.--- The `mapLabels` function rewrites all labels that appear in a--- supernode (both definitions and uses).  The `freshen` function--- replaces every appearance of a /defined/ label with a fresh label.--- (Appearances include both definitions and uses.)------ Laws:--- @---    superLabel (n <> n') == superLabel n---    blocks (n <> n') == blocks n `union` blocks n'---    mapLabels f (n <> n') = mapLabels f n <> mapLabels f n'---    mapLabels id == id---    mapLabels (f . g) == mapLabels f . mapLabels g--- @------ (We expect `freshen` to distribute over `<>`, but because of--- the fresh names involved, formulating a precise law is a bit--- challenging.)--class (Semigroup node) => PureSupernode node where-  superLabel :: node -> Label-  mapLabels :: (Label -> Label) -> (node -> node)--class (MonadUnique m, PureSupernode node) => Supernode node m where-  freshen :: node -> m node--  -- ghost method-  -- blocks :: node -> Set Block-------------------- Functions specific to the algorithm --------------------------- | Merge two nodes, return new graph plus list of nodes that newly have a single--- predecessor.  This function implements transformation $T_2$ from--- the Hecht and Ullman paper (merge the node into its unique--- predecessor).  It then also removes self-edges (transformation $T_1$ from--- the Hecht and Ullman paper).  There is no need for a separate--- implementation of $T_1$.------ `consumeBy v u g` returns the graph that results when node v is--- consumed by node u in graph g.  Both v and u are replaced with a new node u'--- with these properties:------    LABELS(u') = LABELS(u) `union` LABELS(v)---    SUCC(u') = SUCC(u) `union` SUCC(v) - { u }---    every node that previously points to u now points to u'------ It also returns a list of nodes in the result graph that--- are *newly* single-predecessor nodes.--consumeBy :: (DynGraph gr, PureSupernode s)-          => Node -> Node -> gr s () -> (gr s (), [Node])-consumeBy toNode fromNode g =-    assert (toPreds == [((), fromNode)]) $-    (newGraph, newCandidates)-  where ((toPreds,   _, to,   toSuccs),   g')  = forceMatch toNode   g-        ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g'-        context = ( fromPreds -- by construction, can't have `toNode`-                  , fromNode-                  , from <> to-                  , delete ((), fromNode) toSuccs `union` fromSuccs-                  )-        newGraph = context & g''-        newCandidates = filter (singlePred newGraph) changedNodes-        changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs)---- | Split a given node.  The node is replaced with a collection of replicas,--- one for each predecessor.  After the split, every predecessor--- points to a unique replica.-split :: forall gr s b m . (DynGraph gr, Supernode s m)-      => Node -> gr s b -> m (gr s b)-split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes-  where ((preds, _, this, succs), g') = forceMatch node g-        newNodes :: [((b, Node), Node)]-        newNodes = zip preds [maxNode+1..]-        (_, maxNode) = nodeRange g-        thisLabel = superLabel this-        addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)-        addReplica g ((b, pred), newNode) = do-            newSuper <- freshen this-            return $ add newSuper-          where add newSuper =-                  updateNode (thisLabel `replacedWith` superLabel newSuper) pred $-                  ([(b, pred)], newNode, newSuper, succs) & g--replacedWith :: PureSupernode s => Label -> Label -> s -> s-replacedWith old new = mapLabels (\l -> if l == old then new else l)----- | Does a list have more than one element? (in constant time).-isMultiple :: [a] -> Bool-isMultiple [] = False-isMultiple [_] = False-isMultiple (_:_:_) = True---- | Find a candidate for splitting by finding a node that has multiple predecessors.--anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a-anySplittable g = case splittable of-                    n : _ -> n-                    [] -> panic "anySplittable found no splittable nodes"-  where splittable = filter (isMultiple . pre g . fst) $ labNodes g-        splittable :: [LNode a]--------------------- The collapsing algorithm --------------------------- | Using the algorithm of Hecht and Ullman (1972), collapse a graph--- into a single node, splitting nodes as needed.  Record--- visualization events in monad `m`.-collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s)-                       => gr s () -> m (gr s ())-collapseInductiveGraph g = drain g worklist-  where worklist :: [[Node]] -- nodes with exactly one predecessor-        worklist = [filter (singlePred g) $ nodes g]--        drain g [] = if singletonGraph g then finalGraph g >> return g-                     else let (n, super) = anySplittable g-                          in  do splitGraphAt g (n, super)-                                 collapseInductiveGraph =<< split n g-        drain g ([]:nss) = drain g nss-        drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g-                               in  do consumeByInGraph n (theUniquePred n) g-                                      drain g' (ns':ns:nss)-         where theUniquePred n-                 | ([(_, p)], _, _, _) <- context g n = p-                 | otherwise =-                     panic "node claimed to have a unique predecessor; it doesn't"

@@ -1,643 +0,0 @@--- (c) 1999-2005 by Martin Erwig (see copyright at bottom)--- | Static and Dynamic Inductive Graphs------ Code is from Hackage `fgl` package version 5.7.0.3----module GHC.Data.Graph.Inductive.Graph (-    -- * General Type Defintions-    -- ** Node and Edge Types-    Node,LNode,UNode,-    Edge,LEdge,UEdge,-    -- ** Types Supporting Inductive Graph View-    Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp,-    Path,LPath(..),UPath,-    -- * Graph Type Classes-    -- | We define two graph classes:-    ---    --   Graph: static, decomposable graphs.-    --    Static means that a graph itself cannot be changed-    ---    --   DynGraph: dynamic, extensible graphs.-    --             Dynamic graphs inherit all operations from static graphs-    --             but also offer operations to extend and change graphs.-    ---    -- Each class contains in addition to its essential operations those-    -- derived operations that might be overwritten by a more efficient-    -- implementation in an instance definition.-    ---    -- Note that labNodes is essentially needed because the default definition-    -- for matchAny is based on it: we need some node from the graph to define-    -- matchAny in terms of match. Alternatively, we could have made matchAny-    -- essential and have labNodes defined in terms of ufold and matchAny.-    -- However, in general, labNodes seems to be (at least) as easy to define-    -- as matchAny. We have chosen labNodes instead of the function nodes since-    -- nodes can be easily derived from labNodes, but not vice versa.-    Graph(..),-    DynGraph(..),-    -- * Operations-    order,-    size,-    -- ** Graph Folds and Maps-    ufold,gmap,nmap,emap,nemap,-    -- ** Graph Projection-    nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,-    -- ** Graph Construction and Destruction-    insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,-    insNodes,insEdges,delNodes,delEdges,-    buildGr,mkUGraph,-    -- ** Subgraphs-    gfiltermap,nfilter,labnfilter,labfilter,subgraph,-    -- ** Graph Inspection-    context,lab,neighbors,lneighbors,-    suc,pre,lsuc,lpre,-    out,inn,outdeg,indeg,deg,-    hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,-    equal,-    -- ** Context Inspection-    node',lab',labNode',neighbors',lneighbors',-    suc',pre',lpre',lsuc',-    out',inn',outdeg',indeg',deg',-    -- * Pretty-printing-    prettify,-    prettyPrint,-    -- * Ordering of Graphs-    OrdGr(..)-) where--import GHC.Prelude--import           Control.Arrow (first)-import           Data.Function (on)-import qualified Data.IntSet   as IntSet-import           Data.List     (delete, groupBy, sort, sortBy, (\\))-import           Data.Maybe    (fromMaybe, isJust)--import GHC.Utils.Panic---- | Unlabeled node-type  Node   = Int--- | Labeled node-type LNode a = (Node,a)--- | Quasi-unlabeled node-type UNode   = LNode ()---- | Unlabeled edge-type  Edge   = (Node,Node)--- | Labeled edge-type LEdge b = (Node,Node,b)--- | Quasi-unlabeled edge-type UEdge   = LEdge ()---- | Unlabeled path-type Path    = [Node]--- | Labeled path-newtype LPath a = LP { unLPath :: [LNode a] }--instance (Show a) => Show (LPath a) where-  show (LP xs) = show xs--instance (Eq a) => Eq (LPath a) where-  (LP [])        == (LP [])        = True-  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y-  (LP _)         == (LP _)         = False--instance (Ord a) => Ord (LPath a) where-  compare (LP [])        (LP [])        = EQ-  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y-  compare _ _ = panic "LPath: cannot compare two empty paths"---- | Quasi-unlabeled path-type UPath   = [UNode]---- | Labeled links to or from a 'Node'.-type Adj b        = [(b,Node)]--- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.------   In other words, this captures all information regarding the---   specified 'Node' within a graph.-type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node-type MContext a b = Maybe (Context a b)--- | 'Graph' decomposition - the context removed from a 'Graph', and the rest--- of the 'Graph'.-type Decomp g a b = (MContext a b,g a b)--- | The same as 'Decomp', only more sure of itself.-type GDecomp g a b  = (Context a b,g a b)---- | Unlabeled context.-type UContext     = ([Node],Node,[Node])--- | Unlabeled decomposition.-type UDecomp g    = (Maybe UContext,g)---- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'-class Graph gr where-  {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}--  -- | An empty 'Graph'.-  empty     :: gr a b--  -- | True if the given 'Graph' is empty.-  isEmpty   :: gr a b -> Bool--  -- | Decompose a 'Graph' into the 'MContext' found for the given node and the-  -- remaining 'Graph'.-  match     :: Node -> gr a b -> Decomp gr a b--  -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.-  ---  --   For graphs that are also instances of 'DynGraph', @mkGraph ns-  --   es@ should be equivalent to @('insEdges' es . 'insNodes' ns)-  --   'empty'@.-  mkGraph   :: [LNode a] -> [LEdge b] -> gr a b--  -- | A list of all 'LNode's in the 'Graph'.-  labNodes  :: gr a b -> [LNode a]--  -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'-  -- and the remaining 'Graph'.-  matchAny  :: gr a b -> GDecomp gr a b-  matchAny g = case labNodes g of-                 []      -> panic "Match Exception, Empty Graph"-                 (v,_):_ | (Just c,g') <- match v g -> (c,g')-                 _       -> panic "This can't happen: failed to match node in graph"---  -- | The number of 'Node's in a 'Graph'.-  noNodes   :: gr a b -> Int-  noNodes = length . labNodes--  -- | The minimum and maximum 'Node' in a 'Graph'.-  nodeRange :: gr a b -> (Node,Node)-  nodeRange g-    | isEmpty g = panic "nodeRange of empty graph"-    | otherwise = (minimum vs, maximum vs)-    where-      vs = nodes g--  -- | A list of all 'LEdge's in the 'Graph'.-  labEdges  :: gr a b -> [LEdge b]-  labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) []--class (Graph gr) => DynGraph gr where-  -- | Merge the 'Context' into the 'DynGraph'.-  ---  --   Context adjacencies should only refer to either a Node already-  --   in a graph or the node in the Context itself (for loops).-  ---  --   Behaviour is undefined if the specified 'Node' already exists-  --   in the graph.-  (&) :: Context a b -> gr a b -> gr a b----- | The number of nodes in the graph.  An alias for 'noNodes'.-order :: (Graph gr) => gr a b -> Int-order = noNodes---- | The number of edges in the graph.------   Note that this counts every edge found, so if you are---   representing an unordered graph by having each edge mirrored this---   will be incorrect.------   If you created an unordered graph by either mirroring every edge---   (including loops!) or using the @undir@ function in---   "Data.Graph.Inductive.Basic" then you can safely halve the value---   returned by this.-size :: (Graph gr) => gr a b -> Int-size = length . labEdges---- | Fold a function over the graph by recursively calling 'match'.-ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c-ufold f u g-  | isEmpty g = u-  | otherwise = f c (ufold f u g')-  where-    (c,g') = matchAny g---- | Map a function over the graph by recursively calling 'match'.-gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d-gmap f = ufold (\c->(f c&)) empty-{-# NOINLINE [0] gmap #-}---- | Map a function over the 'Node' labels in a graph.-nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b-nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))-{-# NOINLINE [0] nmap #-}---- | Map a function over the 'Edge' labels in a graph.-emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c-emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))-  where-    map1 g = map (first g)-{-# NOINLINE [0] emap #-}---- | Map functions over both the 'Node' and 'Edge' labels in a graph.-nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d-nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))-  where-    fe' = map (first fe)-{-# NOINLINE [0] nemap #-}---- | List all 'Node's in the 'Graph'.-nodes :: (Graph gr) => gr a b -> [Node]-nodes = map fst . labNodes---- | List all 'Edge's in the 'Graph'.-edges :: (Graph gr) => gr a b -> [Edge]-edges = map toEdge . labEdges---- | Drop the label component of an edge.-toEdge :: LEdge b -> Edge-toEdge (v,w,_) = (v,w)---- | Add a label to an edge.-toLEdge :: Edge -> b -> LEdge b-toLEdge (v,w) l = (v,w,l)---- | The label in an edge.-edgeLabel :: LEdge b -> b-edgeLabel (_,_,l) = l---- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.-newNodes :: (Graph gr) => Int -> gr a b -> [Node]-newNodes i g-  | isEmpty g = [0..i-1]-  | otherwise = [n+1..n+i]-  where-    (_,n) = nodeRange g---- | 'True' if the 'Node' is present in the 'Graph'.-gelem :: (Graph gr) => Node -> gr a b -> Bool-gelem v = isJust . fst . match v---- | Insert a 'LNode' into the 'Graph'.-insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b-insNode (v,l) = (([],v,l,[])&)-{-# NOINLINE [0] insNode #-}---- | Insert a 'LEdge' into the 'Graph'.-insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b-insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'-  where-    (mcxt,g') = match v g-    (pr,_,la,su) = fromMaybe-                     (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v))-                     mcxt-{-# NOINLINE [0] insEdge #-}---- | Remove a 'Node' from the 'Graph'.-delNode :: (Graph gr) => Node -> gr a b -> gr a b-delNode v = delNodes [v]---- | Remove an 'Edge' from the 'Graph'.------   NOTE: in the case of multiple edges, this will delete /all/ such---   edges from the graph as there is no way to distinguish between---   them.  If you need to delete only a single such edge, please use---   'delLEdge'.-delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b-delEdge (v,w) g = case match v g of-                    (Nothing,_)          -> g-                    (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'---- | Remove an 'LEdge' from the 'Graph'.------   NOTE: in the case of multiple edges with the same label, this---   will only delete the /first/ such edge.  To delete all such---   edges, please use 'delAllLedge'.-delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b-delLEdge = delLEdgeBy delete---- | Remove all edges equal to the one specified.-delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b-delAllLEdge = delLEdgeBy (filter . (/=))--delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)-              -> LEdge b -> gr a b -> gr a b-delLEdgeBy f (v,w,b) g = case match v g of-                           (Nothing,_)          -> g-                           (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'---- | Insert multiple 'LNode's into the 'Graph'.-insNodes   :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b-insNodes vs g = foldl' (flip insNode) g vs-{-# INLINABLE insNodes #-}---- | Insert multiple 'LEdge's into the 'Graph'.-insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b-insEdges es g = foldl' (flip insEdge) g es-{-# INLINABLE insEdges #-}---- | Remove multiple 'Node's from the 'Graph'.-delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b-delNodes vs g = foldl' (snd .: flip match) g vs---- | Remove multiple 'Edge's from the 'Graph'.-delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b-delEdges es g = foldl' (flip delEdge) g es---- | Build a 'Graph' from a list of 'Context's.------   The list should be in the order such that earlier 'Context's---   depend upon later ones (i.e. as produced by @'ufold' (:) []@).-buildGr :: (DynGraph gr) => [Context a b] -> gr a b-buildGr = foldr (&) empty---- | Build a quasi-unlabeled 'Graph'.-mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()-mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)-   where-     labUEdges = map (`toLEdge` ())-     labUNodes = map (flip (,) ())---- | Build a graph out of the contexts for which the predicate is--- satisfied by recursively calling 'match'.-gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d-gfiltermap f = ufold (maybe id (&) . f) empty---- | Returns the subgraph only containing the labelled nodes which--- satisfy the given predicate.-labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b-labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr---- | Returns the subgraph only containing the nodes which satisfy the--- given predicate.-nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b-nfilter f = labnfilter (f . fst)---- | Returns the subgraph only containing the nodes whose labels--- satisfy the given predicate.-labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b-labfilter f = labnfilter (f . snd)---- | Returns the subgraph induced by the supplied nodes.-subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b-subgraph vs = let vs' = IntSet.fromList vs-              in nfilter (`IntSet.member` vs')---- | Find the context for the given 'Node'.  Causes an error if the 'Node' is--- not present in the 'Graph'.-context :: (Graph gr) => gr a b -> Node -> Context a b-context g v = fromMaybe (panic ("Match Exception, Node: "++show v))-                        (fst (match v g))---- | Find the label for a 'Node'.-lab :: (Graph gr) => gr a b -> Node -> Maybe a-lab g v = fmap lab' . fst $ match v g---- | Find the neighbors for a 'Node'.-neighbors :: (Graph gr) => gr a b -> Node -> [Node]-neighbors = map snd .: lneighbors---- | Find the labelled links coming into or going from a 'Context'.-lneighbors :: (Graph gr) => gr a b -> Node -> Adj b-lneighbors = maybe [] lneighbors' .: mcontext---- | Find all 'Node's that have a link from the given 'Node'.-suc :: (Graph gr) => gr a b -> Node -> [Node]-suc = map snd .: context4l---- | Find all 'Node's that link to to the given 'Node'.-pre :: (Graph gr) => gr a b -> Node -> [Node]-pre = map snd .: context1l---- | Find all 'Node's that are linked from the given 'Node' and the label of--- each link.-lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)]-lsuc = map flip2 .: context4l---- | Find all 'Node's that link to the given 'Node' and the label of each link.-lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)]-lpre = map flip2 .: context1l---- | Find all outward-bound 'LEdge's for the given 'Node'.-out :: (Graph gr) => gr a b -> Node -> [LEdge b]-out g v = map (\(l,w)->(v,w,l)) (context4l g v)---- | Find all inward-bound 'LEdge's for the given 'Node'.-inn :: (Graph gr) => gr a b -> Node -> [LEdge b]-inn g v = map (\(l,w)->(w,v,l)) (context1l g v)---- | The outward-bound degree of the 'Node'.-outdeg :: (Graph gr) => gr a b -> Node -> Int-outdeg = length .: context4l---- | The inward-bound degree of the 'Node'.-indeg :: (Graph gr) => gr a b -> Node -> Int-indeg  = length .: context1l---- | The degree of the 'Node'.-deg :: (Graph gr) => gr a b -> Node -> Int-deg = deg' .: context---- | The 'Node' in a 'Context'.-node' :: Context a b -> Node-node' (_,v,_,_) = v---- | The label in a 'Context'.-lab' :: Context a b -> a-lab' (_,_,l,_) = l---- | The 'LNode' from a 'Context'.-labNode' :: Context a b -> LNode a-labNode' (_,v,l,_) = (v,l)---- | All 'Node's linked to or from in a 'Context'.-neighbors' :: Context a b -> [Node]-neighbors' (p,_,_,s) = map snd p++map snd s---- | All labelled links coming into or going from a 'Context'.-lneighbors' :: Context a b -> Adj b-lneighbors' (p,_,_,s) = p ++ s---- | All 'Node's linked to in a 'Context'.-suc' :: Context a b -> [Node]-suc' = map snd . context4l'---- | All 'Node's linked from in a 'Context'.-pre' :: Context a b -> [Node]-pre' = map snd . context1l'---- | All 'Node's linked from in a 'Context', and the label of the links.-lsuc' :: Context a b -> [(Node,b)]-lsuc' = map flip2 . context4l'---- | All 'Node's linked from in a 'Context', and the label of the links.-lpre' :: Context a b -> [(Node,b)]-lpre' = map flip2 . context1l'---- | All outward-directed 'LEdge's in a 'Context'.-out' :: Context a b -> [LEdge b]-out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c)---- | All inward-directed 'LEdge's in a 'Context'.-inn' :: Context a b -> [LEdge b]-inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c)---- | The outward degree of a 'Context'.-outdeg' :: Context a b -> Int-outdeg' = length . context4l'---- | The inward degree of a 'Context'.-indeg' :: Context a b -> Int-indeg' = length . context1l'---- | The degree of a 'Context'.-deg' :: Context a b -> Int-deg' (p,_,_,s) = length p+length s---- | Checks if there is a directed edge between two nodes.-hasEdge :: Graph gr => gr a b -> Edge -> Bool-hasEdge gr (v,w) = w `elem` suc gr v---- | Checks if there is an undirected edge between two nodes.-hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool-hasNeighbor gr v w = w `elem` neighbors gr v---- | Checks if there is a labelled edge between two nodes.-hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool-hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v---- | Checks if there is an undirected labelled edge between two nodes.-hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool-hasNeighborAdj gr v a = a `elem` lneighbors gr v--------------------------------------------------------------------------- GRAPH EQUALITY-------------------------------------------------------------------------slabNodes :: (Graph gr) => gr a b -> [LNode a]-slabNodes = sortBy (compare `on` fst) . labNodes--glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]-glabEdges = map (GEs . groupLabels)-            . groupBy ((==) `on` toEdge)-            . sortBy (compare `on` toEdge)-            . labEdges-  where-    groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)--equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool-equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'--- This assumes that nodes aren't repeated (which shouldn't happen for--- sane graph instances).  If node IDs are repeated, then the usage of--- slabNodes cannot guarantee stable ordering.---- Newtype wrapper just to test for equality of multiple edges.  This--- is needed because without an Ord constraint on `b' it is not--- possible to guarantee a stable ordering on edge labels.-newtype GroupEdges b = GEs (LEdge [b])-  deriving (Show, Read)--instance (Eq b) => Eq (GroupEdges b) where-  (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2-                                           && w1 == w2-                                           && eqLists bs1 bs2--eqLists :: (Eq a) => [a] -> [a] -> Bool-eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)--- OK to use \\ here as we want each value in xs to cancel a *single*--- value in ys.--------------------------------------------------------------------------- UTILITIES--------------------------------------------------------------------------- auxiliary functions used in the implementation of the--- derived class members----(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d--- f .: g = \x y->f (g x y)--- f .: g = (f .) . g--- (.:) f = ((f .) .)--- (.:) = (.) (.) (.)-(.:) = (.) . (.)--flip2 :: (a,b) -> (b,a)-flip2 (x,y) = (y,x)---- projecting on context elements----context1l :: (Graph gr) => gr a b -> Node -> Adj b-context1l = maybe [] context1l' .: mcontext--context4l :: (Graph gr) => gr a b -> Node -> Adj b-context4l = maybe [] context4l' .: mcontext--mcontext :: (Graph gr) => gr a b -> Node -> MContext a b-mcontext = fst .: flip match--context1l' :: Context a b -> Adj b-context1l' (p,v,_,s) = p++filter ((==v).snd) s--context4l' :: Context a b -> Adj b-context4l' (p,v,_,s) = s++filter ((==v).snd) p--------------------------------------------------------------------------- PRETTY PRINTING--------------------------------------------------------------------------- | Pretty-print the graph.  Note that this loses a lot of---   information, such as edge inverses, etc.-prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String-prettify g = foldr (showsContext . context g) id (nodes g) ""-  where-    showsContext (_,n,l,s) sg = shows n . (':':) . shows l-                                . showString "->" . shows s-                                . ('\n':) . sg---- | Pretty-print the graph to stdout.-prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO ()-prettyPrint = putStr . prettify--------------------------------------------------------------------------- Ordered Graph--------------------------------------------------------------------------- | OrdGr comes equipped with an Ord instance, so that graphs can be---   used as e.g. Map keys.-newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }-  deriving (Read,Show)--instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where-  g1 == g2 = compare g1 g2 == EQ--instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where-  compare (OrdGr g1) (OrdGr g2) =-    (compare `on` sort . labNodes) g1 g2-    `mappend` (compare `on` sort . labEdges) g1 g2---{-------------------------------------------------------------------Copyright (c) 1999-2008, Martin Erwig-              2010, Ivan Lazar Miljenovic-              2022, Norman Ramsey-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice,-   this list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of its contributors may be-   used to endorse or promote products derived from this software without-   specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.------------------------------------------------------------------}

@@ -1,346 +0,0 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}---- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph'--- using big-endian patricia tree (i.e. "Data.IntMap").------ This module provides the following specialised functions to gain--- more performance, using GHC's RULES pragma:------ * 'Data.Graph.Inductive.Graph.insNode'------ * 'Data.Graph.Inductive.Graph.insEdge'------ * 'Data.Graph.Inductive.Graph.gmap'------ * 'Data.Graph.Inductive.Graph.nmap'------ * 'Data.Graph.Inductive.Graph.emap'------ Code is from Hackage `fgl` package version 5.7.0.3---module GHC.Data.Graph.Inductive.PatriciaTree-    ( Gr-    , UGr-    )-    where--import GHC.Prelude--import GHC.Data.Graph.Inductive.Graph--import           Data.IntMap         (IntMap)-import qualified Data.IntMap         as IM-import           Data.List           (sort)-import           Data.Maybe          (fromMaybe)-import           Data.Tuple          (swap)--import qualified Data.IntMap.Strict as IMS--import GHC.Generics (Generic)--import Data.Bifunctor--------------------------------------------------------------------------- GRAPH REPRESENTATION-------------------------------------------------------------------------newtype Gr a b = Gr (GraphRep a b)-  deriving (Generic)--type GraphRep a b = IntMap (Context' a b)-type Context' a b = (IntMap [b], a, IntMap [b])--type UGr = Gr () ()--------------------------------------------------------------------------- CLASS INSTANCES-------------------------------------------------------------------------instance (Eq a, Ord b) => Eq (Gr a b) where-  (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2-    where-      sortAdj (p,n,s) = (fmap sort p,n,fmap sort s)--instance (Show a, Show b) => Show (Gr a b) where-  showsPrec d g = showParen (d > 10) $-                    showString "mkGraph "-                    . shows (labNodes g)-                    . showString " "-                    . shows (labEdges g)--instance (Read a, Read b) => Read (Gr a b) where-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("mkGraph", s) <- lex r-    (ns,t) <- reads s-    (es,u) <- reads t-    return (mkGraph ns es, u)--instance Graph Gr where-    empty           = Gr IM.empty--    isEmpty (Gr g)  = IM.null g--    match           = matchGr--    mkGraph vs es   = insEdges es-                      . Gr-                      . IM.fromList-                      . map (second (\l -> (IM.empty,l,IM.empty)))-                      $ vs--    labNodes (Gr g) = [ (node, label)-                            | (node, (_, label, _)) <- IM.toList g ]--    noNodes   (Gr g) = IM.size g--    nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph")-                       $ liftA2 (,) (ix (IM.minViewWithKey g))-                                    (ix (IM.maxViewWithKey g))-      where-        ix = fmap (fst . fst)--    labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g-                         (next, labels)    <- IM.toList s-                         label             <- labels-                         return (node, next, label)--instance DynGraph Gr where-    (p, v, l, s) & (Gr g)-        = let !g1 = IM.insert v (preds, l, succs) g-              !(np, preds) = fromAdjCounting p-              !(ns, succs) = fromAdjCounting s-              !g2 = addSucc g1 v np preds-              !g3 = addPred g2 v ns succs-          in Gr g3---instance Functor (Gr a) where-  fmap = fastEMap--instance Bifunctor Gr where-  bimap = fastNEMap--  first = fastNMap--  second = fastEMap---matchGr :: Node -> Gr a b -> Decomp Gr a b-matchGr node (Gr g)-    = case IM.lookup node g of-        Nothing-            -> (Nothing, Gr g)--        Just (p, label, s)-            -> let !g1 = IM.delete node g-                   !p' = IM.delete node p-                   !s' = IM.delete node s-                   !g2 = clearPred g1 node s'-                   !g3 = clearSucc g2 node p'-               in (Just (toAdj p', node, label, toAdj s), Gr g3)--------------------------------------------------------------------------- OVERRIDING FUNCTIONS-------------------------------------------------------------------------{---{- RULES-      "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode-  -}-fastInsNode :: LNode a -> Gr a b -> Gr a b-fastInsNode (v, l) (Gr g) = g' `seq` Gr g'-  where-    g' = IM.insert v (IM.empty, l, IM.empty) g---}-{-# RULES-      "insEdge/GHC.Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge-  #-}-fastInsEdge :: LEdge b -> Gr a b -> Gr a b-fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2-  where-    g1 = IM.adjust addS' v g-    g2 = IM.adjust addP' w g1--    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)-    addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)--{---{- RULES-      "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap-  -}-fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d-fastGMap f (Gr g) = Gr (IM.mapWithKey f' g)-  where-    f' :: Node -> Context' a b -> Context' c d-    f' = ((fromContext . f) .) . toContext--{- RULES-      "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap-  -}--}-fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b-fastNMap f (Gr g) = Gr (IM.map f' g)-  where-    f' :: Context' a b -> Context' c b-    f' (ps, a, ss) = (ps, f a, ss)-{---{- RULES-      "emap/GHC.Data.Graph.Inductive.PatriciaTree"  emap = fastEMap-   -}--}-fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c-fastEMap f (Gr g) = Gr (IM.map f' g)-  where-    f' :: Context' a b -> Context' a c-    f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss)--{-  RULES-      "nemap/GHC.Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap-   -}--fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d-fastNEMap fn fe (Gr g) = Gr (IM.map f g)-  where-    f :: Context' a b -> Context' c d-    f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss)----------------------------------------------------------------------------- UTILITIES-------------------------------------------------------------------------toAdj :: IntMap [b] -> Adj b-toAdj = concatMap expand . IM.toList-  where-    expand (n,ls) = map (flip (,) n) ls----fromAdj :: Adj b -> IntMap [b]---fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)--data FromListCounting a = FromListCounting !Int !(IntMap a)-  deriving (Eq, Show, Read)--getFromListCounting :: FromListCounting a -> (Int, IntMap a)-getFromListCounting (FromListCounting i m) = (i, m)-{-# INLINE getFromListCounting #-}--fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)-fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)-  where-    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)-{-# INLINE fromListWithKeyCounting #-}--fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)-fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)-{-# INLINE fromListWithCounting #-}--fromAdjCounting :: Adj b -> (Int, IntMap [b])-fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)---- We use differenceWith to modify a graph more than bulkThreshold times,--- and repeated insertWith otherwise.-bulkThreshold :: Int-bulkThreshold = 5----toContext :: Node -> Context' a b -> Context a b---toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)----fromContext :: Context a b -> Context' a b---fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)---- A version of @++@ where order isn't important, so @xs ++ [x]@--- becomes @x:xs@.  Used when we have to have a function of type @[a]--- -> [a] -> [a]@ but one of the lists is just going to be a single--- element (and it isn't possible to tell which).-addLists :: [a] -> [a] -> [a]-addLists [a] as  = a : as-addLists as  [a] = a : as-addLists xs  ys  = xs ++ ys--addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b-addSucc g0 v numAdd xs-  | numAdd < bulkThreshold = foldlWithKey' go g0 xs-  where-    go :: GraphRep a b -> Node -> [b] -> GraphRep a b-    go g p l = IMS.adjust f p g-      where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss-                             in (ps, l', ss')-addSucc g v _ xs = IMS.differenceWith go g xs-  where-    go :: Context' a b -> [b] -> Maybe (Context' a b)-    go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss-                        in Just (ps, l', ss')--foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a-foldlWithKey' =-  IM.foldlWithKey'--addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b-addPred g0 v numAdd xs-  | numAdd < bulkThreshold = foldlWithKey' go g0 xs-  where-    go :: GraphRep a b -> Node -> [b] -> GraphRep a b-    go g p l = IMS.adjust f p g-      where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps-                             in (ps', l', ss)-addPred g v _ xs = IMS.differenceWith go g xs-  where-    go :: Context' a b -> [b] -> Maybe (Context' a b)-    go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps-                        in Just (ps', l', ss)--clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b-clearSucc g v = IMS.differenceWith go g-  where-    go :: Context' a b -> x -> Maybe (Context' a b)-    go (ps, l, ss) _ = let !ss' = IM.delete v ss-                       in Just (ps, l, ss')--clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b-clearPred g v = IMS.differenceWith go g-  where-    go :: Context' a b -> x -> Maybe (Context' a b)-    go (ps, l, ss) _ = let !ps' = IM.delete v ps-                       in Just (ps', l, ss)--{-------------------------------------------------------------------Copyright (c) 1999-2008, Martin Erwig-              2010, Ivan Lazar Miljenovic-              2022, Norman Ramsey-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--1. Redistributions of source code must retain the above copyright notice,-   this list of conditions and the following disclaimer.--2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.--3. Neither the name of the author nor the names of its contributors may be-   used to endorse or promote products derived from this software without-   specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.------------------------------------------------------------------}

@@ -1,944 +0,0 @@--{-# 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--import GHC.Prelude--import GHC.Driver.Backend--- In a separate module because it hooks into the parser.-import GHC.Driver.Backpack.Syntax-import GHC.Driver.Config.Finder (initFinderOpts)-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.Diagnostic-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.Driver.Errors.Types--import GHC.Parser-import GHC.Parser.Header-import GHC.Parser.Lexer-import GHC.Parser.Annotation--import GHC.Rename.Names--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.SourceFile-import GHC.Types.Unique.FM-import GHC.Types.Unique.DFM-import GHC.Types.Unique.DSet--import GHC.Utils.Outputable-import GHC.Utils.Fingerprint-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.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-    -- Apply options from file to dflags-    dflags0 <- getDynFlags-    let dflags1 = dflags0-    let parser_opts1 = initParserOpts dflags1-    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename-    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts-    modifySession (hscSetFlags dflags)-    logger <- getLogger -- Get the logger after having set the session flags,-                        -- so that logger options are correctly set.-                        -- Not doing so caused #20396.-    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline-    liftIO $ checkProcessArgsResult unhandled_flags-    let print_config = initPrintConfig dflags-    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns)-    liftIO $ handleFlagWarnings logger print_config (initDiagOpts 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 (GhcPsMessage <$> getPsErrorMessages 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 == 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 -> (UnitId, [(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 :: UnitId-               -> [(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 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 =-          hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env-        mk_temp_dflags unit_state dflags = dflags-            { backend = case session_type of-                            TcSession -> noBackend-                            _         -> backend dflags-            , ghcLink = case session_type of-                            TcSession -> NoLink-                            _         -> ghcLink 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 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-                  | backendSupportsInterfaceWriting $ backend dflags-                  -> 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 (UnitId (fsLit "main")) [] deps ExeSession do_this--getSource :: UnitId -> 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 :: UnitId -> [(ModuleName, Module)] -> BkpM ()-typecheckUnit cid insts = do-    lunit <- getSource cid-    buildUnit TcSession cid insts lunit--compileUnit :: UnitId -> [(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 -> UnitId -> [(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 False (unLoc lunit)--        msg <- mkBackpackMsg-        ok <- load' noIfaceCache 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" . homeModInfoObject)-                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)-                      $ home_mod_infos-            getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables-            state     = hsc_units hsc_env--        let compat_fs = unitIdFS 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 True (unLoc lunit)-        msg <- mkBackpackMsg-        ok <- load' noIfaceCache 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-    let old_unit_env = hsc_unit_env hsc_env-    newdbs <- case ue_unit_dbs old_unit_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) (hsc_all_home_unit_ids hsc_env)--    -- update platform constants-    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants--    let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv-          { ue_platform  = targetPlatform dflags-          , ue_namever   = ghcNameVersion dflags-          , ue_current_unit = homeUnitId home_unit--          , ue_home_unit_graph =-                unitEnv_singleton-                    (homeUnitId home_unit)-                    (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))-          , ue_eps       = ue_eps old_unit_env-          }-    setSession $ hscSetFlags dflags $ hsc_env { 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 UnitId (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' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ()))---- | Get the EPS from a 'GhcMonad'.-getEpsGhc :: GhcMonad m => m ExternalPackageState-getEpsGhc = do-    hsc_env <- getSession-    liftIO $ hscEPS 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 -> SDoc -> IO ()-backpackProgressMsg level logger msg =-    compilationProgressMsg logger $ 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 $ pprWithUnitState state $-                showModuleIndex mod_index <>-                msg <> showModMsg dflags (recompileRequired recomp) node-                    <> reason-      in case node of-        InstantiationNode _ _ ->-          case recomp of-            UpToDate-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-              | otherwise -> return ()-            NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of-              MustCompile -> empty-              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"-        ModuleNode _ _ ->-          case recomp of-            UpToDate-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-              | otherwise -> return ()-            NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of-              MustCompile -> empty-              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"-        LinkNode _ _ -> showMsg (text "Linking ")  empty---- | '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-                      alwaysPrintPromTick)-        AllTheWay---- | Message when we initially process a Backpack unit.-msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()-msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do-    logger <- getLogger-    level <- getBkpLevel-    liftIO . backpackProgressMsg level logger-        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn---- | Message when we instantiate a Backpack unit.-msgUnitId :: Unit -> BkpM ()-msgUnitId pk = do-    logger <- getLogger-    hsc_env <- getSession-    level <- getBkpLevel-    let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger-        $ 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-    logger <- getLogger-    hsc_env <- getSession-    level <- getBkpLevel-    let state = hsc_units hsc_env-    liftIO . backpackProgressMsg level logger-        $ 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 (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 :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph do_link unit = do-    hsc_env <- getSession--    let decls = hsunitBody unit-        pn = hsPackageName (unLoc (hsunitName unit))-        home_unit = hsc_home_unit hsc_env--        sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit))-        keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ]--    --  1. Create a HsSrcFile/HsigFile summary for every-    --  explicitly mentioned module/signature.-    let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =-          Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys)-        get_decl _ = return Nothing-    nodes <- mapMaybeM 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-          | ModuleNode _ 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 $ summariseRequirement pn mod_name--    let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))-        key_nodes = map mkNodeKey graph_nodes-        all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link]-    -- This error message is not very good but .bkp mode is just for testing so-    -- better to be direct rather than pretty.-    when-      (length key_nodes /= length (ordNub key_nodes))-      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))--    -- 3. Return the kaboodle-    return $ mkModuleGraph $ all_nodes---summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode-summariseRequirement pn mod_name = do-    hsc_env <- getSession-    let dflags = hsc_dflags hsc_env-    let home_unit = hsc_home_unit hsc_env-    let fopts = initFinderOpts dflags--    let PackageName pn_fs = pn-    let location = mkHomeModLocation2 fopts mod_name-                    (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"--    env <- getBkpEnv-    src_hash <- liftIO $ getFileHash (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)--    let fc = hsc_FC hsc_env-    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location--    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name--    let ms = ModSummary {-        ms_mod = mod,-        ms_hsc_src = HsigFile,-        ms_location = location,-        ms_hs_hash = src_hash,-        ms_obj_date = Nothing,-        ms_dyn_obj_date = Nothing,-        ms_iface_date = hi_timestamp,-        ms_hie_date = hie_timestamp,-        ms_srcimps = [],-        ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,-        ms_ghc_prim_import = False,-        ms_parsed_mod = Just (HsParsedModule {-                hpm_module = L loc (HsModule {-                        hsmodExt = XModulePs {-                            hsmodAnn = noAnn,-                            hsmodLayout = NoLayoutInfo,-                            hsmodDeprecMessage = Nothing,-                            hsmodHaddockModHeader = Nothing-                                             },-                        hsmodName = Just (L (noAnnSrcSpan loc) mod_name),-                        hsmodExports = Nothing,-                        hsmodImports = [],-                        hsmodDecls = []-                    }),-                hpm_src_files = []-            }),-        ms_hspp_file = "", -- none, it came inline-        ms_hspp_opts = dflags,-        ms_hspp_buf = Nothing-        }-    let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]-    return (ModuleNode nodes ms)--summariseDecl :: PackageName-              -> HscSource-              -> Located ModuleName-              -> Located (HsModule GhcPs)-              -> [NodeKey]-              -> BkpM ModuleGraphNode-summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod---- | 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 :: [NodeKey]-                     -> PackageName-                     -> HscSource-                     -> ModuleName-                     -> Located (HsModule GhcPs)-                     -> BkpM ModuleGraphNode-hsModuleToModSummary home_keys 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-        fopts = initFinderOpts dflags-    -- 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!-    let location0 = mkHomeModLocation2 fopts 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-    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, ghc_prim_import)-          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)-              ord_idecls--        implicit_prelude = xopt LangExt.ImplicitPrelude dflags-        implicit_imports = mkPrelImports modname loc-                                         implicit_prelude imps--        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname-        convImport (L _ i) = (rn_pkg_qual (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 $ do-      let home_unit = hsc_home_unit hsc_env-      let fc        = hsc_FC hsc_env-      addHomeModuleToFinder fc home_unit modname location-    let ms = 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_ghc_prim_import = not (null ghc_prim_import),-            ms_textual_imps = normal_imports-                           -- We have to do something special here:-                           -- due to merging, requirements may end up with-                           -- extra imports-                           ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)-                           ++ ((,) NoPkgQual . 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-                }),-            -- Source hash = fingerprint0, so the recompilation tests do not recompile-            -- too much. In future, if necessary then could get the hash by just hashing the-            -- relevant part of the .bkp file.-            ms_hs_hash = fingerprint0,-            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS-            ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS-            ms_iface_date = hi_timestamp,-            ms_hie_date = hie_timestamp-          }--    -- Now, what are the dependencies.-    let inst_nodes = map NodeKey_Unit inst_deps-        mod_nodes  =-          -- hs-boot edge-          [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot)  (moduleUnitId this_mod))], NotBoot == isBootSummary ms,  k `elem` home_keys ] ++-          -- Normal edges-          [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]---    return (ModuleNode (mod_nodes ++ inst_nodes) ms)---- | Create a new, externally provided hashed unit id from--- a hash.-newUnitId :: UnitId -> Maybe FastString -> UnitId-newUnitId uid mhash = case mhash of-   Nothing   -> uid-   Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash])

@@ -1,454 +0,0 @@-------------------------------------------------------------------------------------- Makefile Dependency Generation------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module GHC.Driver.MakeFile-   ( doMkDependHS-   )-where--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 GHC.Driver.Errors.Types-import qualified GHC.SysTools as SysTools-import GHC.Data.Graph.Directed ( SCC(..) )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Types.Error (UnknownDiagnostic(..))-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.PkgQual-import Data.List (partition)-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 dflags1 = dflags0-            { targetWays_ = Set.empty-            , hiSuf_      = "hi"-            , objectSuf_  = "o"-            }-    GHC.setSessionDynFlags dflags1--    -- If no suffix is provided, use the default -- the empty one-    let dflags = if null (depSuffixes dflags1)-                 then dflags1 { depSuffixes = [""] }-                 else dflags1--    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 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 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 module_graph--    -- Tidy up-    liftIO $ endMkDependHS logger 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 (tmpDir 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 _uid 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 _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()--processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ 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 discovered 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-                -> PkgQual              -- 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 $-          mkPlainErrorMsgEnvelope srcloc $-          GhcDriverMessage $ DriverUnknownMessage $-             UnknownDiagnostic $ mkPlainError noHints $-             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 -> MkDepFiles -> IO ()--endMkDependHS logger-   (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-        SysTools.copyHandle hdl tmp_hdl-        hClose hdl--  hClose tmp_hdl  -- make sure it's flushed--        -- Create a backup of the original makefile-  when (isJust makefile_hdl) $ do-    showPass logger ("Backing up " ++ makefile)-    SysTools.copyFile makefile (makefile++".bak")--        -- Copy the new makefile in place-  showPass logger "Installing new makefile"-  SysTools.copyFile tmp_file makefile-----------------------------------------------------------------------              Module cycles--------------------------------------------------------------------dumpModCycles :: Logger -> ModuleGraph -> IO ()-dumpModCycles logger module_graph-  | not (logHasDumpFlag logger Opt_D_dump_mod_cycles)-  = return ()--  | null cycles-  = putMsg logger (text "No module cycles")--  | otherwise-  = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)-  where-    topoSort = GHC.topSortModuleGraph True module_graph Nothing--    cycles :: [[ModuleGraphNode]]-    cycles =-      [ c | CyclicSCC c <- topoSort ]--    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")-                        $$ pprCycle c $$ blankLine-                     | (n,c) <- [1..] `zip` cycles ]--pprCycle :: [ModuleGraphNode] -> 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) [ms | ModuleNode _ ms <- summaries]--    pp_group :: SCC ModuleGraphNode -> SDoc-    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms-    pp_group (AcyclicSCC _) = empty-    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 (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))-          is_boot_only  _ = False-          in_group (L _ m) = m `elem` group_mods-          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]--          loop_breaker = head ([ms | ModuleNode _ ms  <- boot_only])-          all_others   = tail boot_only ++ others-          groups =-            GHC.topSortModuleGraph True (mkModuleGraph 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,271 +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.Id.Make (ghcPrimIds)-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 ( (\\), partition )-import qualified Data.List.NonEmpty as NE-import Data.Maybe-import Data.IORef------------------------------------------ | The :print & friends commands---------------------------------------pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()-pprintClosureCommand bindThings force str = do-  tythings <- (catMaybes . concatMap NE.toList) `liftM`-                 mapM (\w -> GHC.parseName w >>=-                                mapM GHC.lookupName)-                      (words str)--  -- Sort out good and bad tythings for :print and friends-  let (pprintables, unpprintables) = partition can_pprint tythings--  -- Obtain the terms and the recovered type information-  let ids = [id | AnId id <- pprintables]-  (subst, terms) <- mapAccumLM go emptySubst 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 Results-  docterms <- mapM showTerm terms-  let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)-                          ids-                          docterms-  printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms- where-   -- Check whether a TyThing can be processed by :print and friends.-   -- Take only Ids, exclude pseudoops, they don't have any HValues.-   can_pprint :: TyThing -> Bool                              -- #19394-   can_pprint (AnId x)-       | x `notElem` ghcPrimIds = True-       | otherwise              = False-   can_pprint _                 = False--   -- Create a short message for a TyThing, that cannot processed by :print-   no_pprint :: TyThing -> SDoc-   no_pprint tything = ppr tything <+>-          text "is not eligible for the :print, :sprint or :force commands."--   -- Helper to print out the results of :print and friends-   printSDocs :: GhcMonad m => [SDoc] -> m ()-   printSDocs sdocs = do-      logger <- getLogger-      name_ppr_ctx <- GHC.getNamePprCtx-      liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs--   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance-   go :: GhcMonad m => Subst -> Id -> m (Subst, 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 { logger <- getLogger-                           ; liftIO $-                               putDumpFileMaybe logger 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 `unionSubst` 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 collect 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,194 +0,0 @@---- | 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,-        getTargetPlatform,-        getEnvs,-        getInstEnvs,-        getFamInstEnvs,-        matchFam,--        -- * Type variables-        newUnique,-        newFlexiTyVar,-        isTouchableTcPluginM,--        -- * Zonking-        zonkTcType,-        zonkCt,--        -- * Creating constraints-        newWanted,-        newGiven,-        newCoercionHole,--        -- * Manipulating evidence bindings-        newEvVar,-        setEvBind,-    ) where--import GHC.Prelude--import GHC.Platform (Platform)--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-                               , liftIO, traceTc )-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) )-import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )-import GHC.Tc.Utils.Env        ( TcTyThing )-import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)-                               , EvExpr, EvBindsVar, EvBind, mkGivenEvBind )-import GHC.Types.Var           ( EvVar )--import GHC.Unit.Module    ( ModuleName, Module )-import GHC.Types.Name     ( OccName, Name )-import GHC.Types.TyThing  ( TyThing )-import GHC.Core.Reduction ( Reduction )-import GHC.Core.TyCon     ( TyCon )-import GHC.Core.DataCon   ( DataCon )-import GHC.Core.Class     ( Class )-import GHC.Driver.Env       ( HscEnv(..) )-import GHC.Utils.Outputable ( SDoc )-import GHC.Core.Type        ( Kind, Type, PredType )-import GHC.Types.Id         ( Id )-import GHC.Core.InstEnv     ( InstEnvs )-import GHC.Types.Unique     ( Unique )-import GHC.Types.PkgQual    ( PkgQual )----- | 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 -> PkgQual -> 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--getTargetPlatform :: TcPluginM Platform-getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform---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 Reduction)-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 with the given 'CtLoc'.-newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence-newWanted loc pty-  = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty)---- | Create a new given constraint, with the supplied evidence.------ This should only be invoked within 'tcPluginSolve'.-newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence-newGiven tc_evbinds loc pty evtm = do-   new_ev <- newEvVar pty-   setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)-   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }---- | Create a fresh evidence variable.------ This should only be invoked within 'tcPluginSolve'.-newEvVar :: PredType -> TcPluginM EvVar-newEvVar = unsafeTcPluginTcM . TcM.newEvVar---- | Create a fresh coercion hole.--- This should only be invoked within 'tcPluginSolve'.-newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole---- | Bind an evidence variable.------ This should only be invoked within 'tcPluginSolve'.-setEvBind :: EvBindsVar -> EvBind -> TcPluginM ()-setEvBind tc_evbinds ev_bind = do-    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind

@@ -1,8 +1,8 @@-cabal-version: 2.0+cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.6.2.20230523-license: BSD3+version: 9.6.2.20231121+license: BSD-3-Clause license-file: LICENSE category: Development author: The GHC Team and Digital Asset@@ -74,23 +74,23 @@     build-depends:         base >= 4.16.1 && < 4.19,         ghc-prim > 0.2 && < 0.11,+        containers >= 0.6.2.1 && < 0.7,         bytestring >= 0.11.3 && < 0.12,         time >= 1.4 && < 1.13,         exceptions == 0.10.*,         parsec,-        containers >= 0.5 && < 0.7,         binary == 0.8.*,         filepath >= 1 && < 1.5,         directory >= 1 && < 1.4,         array >= 0.1 && < 0.6,-        deepseq >= 1.4 && < 1.5,+        deepseq >= 1.4 && < 1.6,         pretty == 1.1.*,         transformers >= 0.5 && < 0.7,         process >= 1 && < 1.7,         stm,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 9.6.2.20230523+        ghc-lib-parser == 9.6.2.20231121     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:         BangPatterns@@ -135,9 +135,6 @@     hs-source-dirs:         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build-        libraries/template-haskell-        libraries/ghc-boot-        libraries/ghci         compiler     autogen-modules:         Paths_ghc_lib@@ -543,7 +540,6 @@         GHC.Cmm.Parser.Monad         GHC.Cmm.Pipeline         GHC.Cmm.ProcPoint-        GHC.Cmm.Reducibility         GHC.Cmm.Sink         GHC.Cmm.Switch.Implement         GHC.Cmm.ThreadSanitizer@@ -577,14 +573,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@@ -642,14 +635,10 @@         GHC.CoreToStg.Prep         GHC.Data.Bitmap         GHC.Data.Graph.Base-        GHC.Data.Graph.Collapse         GHC.Data.Graph.Color-        GHC.Data.Graph.Inductive.Graph-        GHC.Data.Graph.Inductive.PatriciaTree         GHC.Data.Graph.Ops         GHC.Data.Graph.Ppr         GHC.Data.UnionFind-        GHC.Driver.Backpack         GHC.Driver.CodeOutput         GHC.Driver.Config.Cmm         GHC.Driver.Config.Cmm.Parser@@ -678,11 +667,9 @@         GHC.Driver.GenerateCgIPEStub         GHC.Driver.Main         GHC.Driver.Make-        GHC.Driver.MakeFile         GHC.Driver.Pipeline         GHC.Driver.Pipeline.Execute         GHC.Driver.Pipeline.LogQueue-        GHC.HandleEncoding         GHC.Hs.Stats         GHC.Hs.Syn.Type         GHC.HsToCore@@ -734,7 +721,6 @@         GHC.JS.Ppr         GHC.JS.Syntax         GHC.JS.Transform-        GHC.Linker         GHC.Linker.Config         GHC.Linker.Dynamic         GHC.Linker.ExtraObj@@ -763,7 +749,6 @@         GHC.Rename.Splice         GHC.Rename.Unbound         GHC.Rename.Utils-        GHC.Runtime.Debugger         GHC.Runtime.Eval         GHC.Runtime.Heap.Inspect         GHC.Runtime.Loader@@ -875,7 +860,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@@ -905,12 +889,3 @@         GHC.Utils.Asm         GHC.Wasm.ControlFlow         GHC.Wasm.ControlFlow.FromCmm-        GHCi.CreateBCO-        GHCi.InfoTable-        GHCi.ObjLink-        GHCi.Run-        GHCi.Signals-        GHCi.StaticPtrTable-        GHCi.TH-        Language.Haskell.TH.CodeDo-        Language.Haskell.TH.Quote

@@ -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-   mb_val <- lookupEnv "GHC_CHARENC"-   case mb_val 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,211 +0,0 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}-{-# 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-#if defined(javascript_HOST_ARCH)--- Addr# isn't coercible with Any with the JS backend.-writeArrayAddr# = error "writeArrayAddr#: currently unsupported with the JS backend"-#else-writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s-#endif---#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,419 +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-    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 ]--    ArchRISCV64 -> pure $-        let w64 = fromIntegral (funPtrToInt a) :: Word64-        in Right [ 0x00000297          -- auipc t0,0-                 , 0x01053283          -- ld    t0,16(t0)-                 , 0x00028067          -- jr    t0-                 , 0x00000013          -- nop-                 , fromIntegral w64-                 , fromIntegral (w64 `shiftR` 32) ]--    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 :: [Word8])  -> sizeOf (undefined :: Word8)  * length xs-       Right (xs :: [Word32]) -> sizeOf (undefined :: Word32) * 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,273 +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-  qGetPackageRoot        = ghcCmd GetPackageRoot-  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,22 +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 }