diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Reducibility.hs
+++ /dev/null
@@ -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
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs
+++ /dev/null
@@ -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]
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
+++ /dev/null
@@ -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
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs
+++ /dev/null
@@ -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)
-
diff --git a/compiler/GHC/Data/Graph/Collapse.hs b/compiler/GHC/Data/Graph/Collapse.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Collapse.hs
+++ /dev/null
@@ -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"
diff --git a/compiler/GHC/Data/Graph/Inductive/Graph.hs b/compiler/GHC/Data/Graph/Inductive/Graph.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Inductive/Graph.hs
+++ /dev/null
@@ -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.
-
-----------------------------------------------------------------}
diff --git a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
+++ /dev/null
@@ -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.
-
-----------------------------------------------------------------}
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ /dev/null
@@ -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=]@ in a
--- unit file, return the 'Unit' corresponding to @p[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])
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ /dev/null
@@ -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"
diff --git a/compiler/GHC/Linker.hs b/compiler/GHC/Linker.hs
deleted file mode 100644
--- a/compiler/GHC/Linker.hs
+++ /dev/null
@@ -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.
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
deleted file mode 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ /dev/null
@@ -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
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ /dev/null
@@ -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
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
--- a/ghc-lib.cabal
+++ b/ghc-lib.cabal
@@ -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
diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs
deleted file mode 100644
--- a/libraries/ghc-boot/GHC/HandleEncoding.hs
+++ /dev/null
@@ -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 ()
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
deleted file mode 100644
--- a/libraries/ghci/GHCi/CreateBCO.hs
+++ /dev/null
@@ -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 #)
- }}
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
deleted file mode 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ /dev/null
@@ -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
- --
- -- which looks like:
- -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10
- -- 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
- --
- -- which looks like:
- -- 0: 58000041 ldr x1,