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 -> sizeUniqSet s >= 1
- && sizeUniqSet s <= neighbors)
- $ powersetLS regsC
-
- -- for each of the subsets of C, the regs which conflict
- -- with posiblities for N
- regsS_conflict
- = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
-
- in maximum $ map sizeUniqSet $ regsS_conflict
-
-
--- | For a node N of classN and neighbors of classesC
--- (bound classN classesC) is the maximum number of potential
--- colors for N that can be lost by coloring its neighbors.
-bound :: (RegClass -> UniqSet Reg)
- -> (Reg -> UniqSet Reg)
- -> RegClass -> [RegClass] -> Int
-
-bound regsOfClass regAlias classN classesC
- = let regAliasS regs = unionManyUniqSets
- $ map regAlias
- $ nonDetEltsUFM regs
- -- See Note [Unique Determinism and code generation]
-
- regsC_aliases
- = unionManyUniqSets
- $ map (regAliasS . getUniqSet . regsOfClass) classesC
-
- overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
-
- in sizeUniqSet overlap
-
-
--- | The total squeese on a particular node with a list of neighbors.
---
--- A version of this should be constructed for each particular architecture,
--- possibly including uses of bound, so that aliased registers don't get
--- counted twice, as per the paper.
-squeese :: (RegClass -> UniqSet Reg)
- -> (Reg -> UniqSet Reg)
- -> RegClass -> [(Int, RegClass)] -> Int
-
-squeese regsOfClass regAlias classN countCs
- = sum
- $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)
- $ countCs
-
-
--- | powerset (for lists)
-powersetL :: [a] -> [[a]]
-powersetL = concatMapM (\x -> [[],[x]])
-
-
--- | powersetLS (list of sets)
-powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
-powersetLS s = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
- -- See Note [Unique Determinism and code generation]
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/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ /dev/null
@@ -1,908 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-
-
--- | This is the driver for the 'ghc --backpack' mode, which
--- is a reimplementation of the "package manager" bits of
--- Backpack directly in GHC. The basic method of operation
--- is to compile packages and then directly insert them into
--- GHC's in memory database.
---
--- The compilation products of this mode aren't really suitable
--- for Cabal, because GHC makes up component IDs for the things
--- it builds and doesn't serialize out the database contents.
--- But it's still handy for constructing tests.
-
-module GHC.Driver.Backpack (doBackpack) where
-
-#include "GhclibHsVersions.h"
-
-import GHC.Prelude
-
--- In a separate module because it hooks into the parser.
-import GHC.Driver.Backpack.Syntax
-import GHC.Driver.Config
-import GHC.Driver.Monad
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Main
-import GHC.Driver.Make
-import GHC.Driver.Env
-import GHC.Driver.Errors
-
-import GHC.Parser
-import GHC.Parser.Header
-import GHC.Parser.Lexer
-import GHC.Parser.Annotation
-import GHC.Parser.Errors.Ppr
-
-import GHC hiding (Failed, Succeeded)
-import GHC.Tc.Utils.Monad
-import GHC.Iface.Recomp
-import GHC.Builtin.Names
-
-import GHC.Types.SrcLoc
-import GHC.Types.SourceError
-import GHC.Types.SourceText
-import GHC.Types.SourceFile
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DFM
-import GHC.Types.Unique.DSet
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Error
-import GHC.Utils.Logger
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.State
-import GHC.Unit.Finder
-import GHC.Unit.Module.Graph
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Home.ModInfo
-
-import GHC.Linker.Types
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.Maybe
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import qualified GHC.Data.EnumSet as EnumSet
-import qualified GHC.Data.ShortText as ST
-
-import Data.List ( partition )
-import System.Exit
-import Control.Monad
-import System.FilePath
-import Data.Version
-
--- for the unification
-import Data.IORef
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
--- | Entry point to compile a Backpack file.
-doBackpack :: [FilePath] -> Ghc ()
-doBackpack [src_filename] = do
- logger <- getLogger
-
- -- Apply options from file to dflags
- dflags0 <- getDynFlags
- let dflags1 = dflags0
- src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
- (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
- modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
- -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
- liftIO $ checkProcessArgsResult unhandled_flags
- liftIO $ handleFlagWarnings logger dflags warns
- -- TODO: Preprocessing not implemented
-
- buf <- liftIO $ hGetStringBuffer src_filename
- let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
- case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
- POk _ pkgname_bkp -> do
- -- OK, so we have an LHsUnit PackageName, but we want an
- -- LHsUnit HsComponentId. So let's rename it.
- hsc_env <- getSession
- let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp
- initBkpM src_filename bkp $
- forM_ (zip [1..] bkp) $ \(i, lunit) -> do
- let comp_name = unLoc (hsunitName (unLoc lunit))
- msgTopPackage (i,length bkp) comp_name
- innerBkpM $ do
- let (cid, insts) = computeUnitId lunit
- if null insts
- then if cid == Indefinite (UnitId (fsLit "main"))
- then compileExe lunit
- else compileUnit cid []
- else typecheckUnit cid insts
-doBackpack _ =
- throwGhcException (CmdLineError "--backpack can only process a single file")
-
-computeUnitId :: LHsUnit HsComponentId -> (IndefUnitId, [(ModuleName, Module)])
-computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
- where
- cid = hsComponentId (unLoc (hsunitName unit))
- reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
- get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
- get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
- get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
- get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
- unitFreeModuleHoles (convertHsComponentId hsuid)
-
--- | Tiny enum for all types of Backpack operations we may do.
-data SessionType
- -- | A compilation operation which will result in a
- -- runnable executable being produced.
- = ExeSession
- -- | A type-checking operation which produces only
- -- interface files, no object files.
- | TcSession
- -- | A compilation operation which produces both
- -- interface files and object files.
- | CompSession
- deriving (Eq)
-
--- | Create a temporary Session to do some sort of type checking or
--- compilation.
-withBkpSession :: IndefUnitId
- -> [(ModuleName, Module)]
- -> [(Unit, ModRenaming)]
- -> SessionType -- what kind of session are we doing
- -> BkpM a -- actual action to run
- -> BkpM a
-withBkpSession cid insts deps session_type do_this = do
- dflags <- getDynFlags
- let cid_fs = unitFS (indefUnit cid)
- is_primary = False
- uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
- cid_str = unpackFS cid_fs
- -- There are multiple units in a single Backpack file, so we
- -- need to separate out the results in those cases. Right now,
- -- we follow this hierarchy:
- -- $outputdir/$compid --> typecheck results
- -- $outputdir/$compid/$unitid --> compile results
- key_base p | Just f <- p dflags = f
- | otherwise = "."
- sub_comp p | is_primary = p
- | otherwise = p cid_str
- outdir p | CompSession <- session_type
- -- Special case when package is definite
- , not (null insts) = sub_comp (key_base p) uid_str
- | otherwise = sub_comp (key_base p)
-
- mk_temp_env hsc_env = hsc_env
- { hsc_dflags = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env)
- }
- mk_temp_dflags unit_state dflags = dflags
- { backend = case session_type of
- TcSession -> NoBackend
- _ -> backend dflags
- , homeUnitInstantiations_ = insts
- -- if we don't have any instantiation, don't
- -- fill `homeUnitInstanceOfId` as it makes no
- -- sense (we're not instantiating anything)
- , homeUnitInstanceOf_ = if null insts then Nothing else Just (indefUnit cid)
- , homeUnitId_ = case session_type of
- TcSession -> newUnitId cid Nothing
- -- No hash passed if no instances
- _ | null insts -> newUnitId cid Nothing
- | otherwise -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))
-
-
- -- If we're type-checking an indefinite package, we want to
- -- turn on interface writing. However, if the user also
- -- explicitly passed in `-fno-code`, we DON'T want to write
- -- interfaces unless the user also asked for `-fwrite-interface`.
- -- See Note [-fno-code mode]
- , generalFlags = case session_type of
- -- Make sure to write interfaces when we are type-checking
- -- indefinite packages.
- TcSession
- | backend dflags /= NoBackend
- -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)
- _ -> generalFlags dflags
-
- -- Setup all of the output directories according to our hierarchy
- , objectDir = Just (outdir objectDir)
- , hiDir = Just (outdir hiDir)
- , stubDir = Just (outdir stubDir)
- -- Unset output-file for non exe builds
- , outputFile_ = case session_type of
- ExeSession -> outputFile_ dflags
- _ -> Nothing
- , dynOutputFile_ = case session_type of
- ExeSession -> dynOutputFile_ dflags
- _ -> Nothing
- -- Clear the import path so we don't accidentally grab anything
- , importPaths = []
- -- Synthesize the flags
- , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
- let uid = unwireUnit unit_state
- $ improveUnit unit_state
- $ renameHoleUnit unit_state (listToUFM insts) uid0
- in ExposePackage
- (showSDoc dflags
- (text "-unit-id" <+> ppr uid <+> ppr rn))
- (UnitIdArg uid) rn) deps
- }
- withTempSession mk_temp_env $ do
- dflags <- getSessionDynFlags
- -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
- setSessionDynFlags dflags -- calls initUnits
- do_this
-
-withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
-withBkpExeSession deps do_this =
- withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this
-
-getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId)
-getSource cid = do
- bkp_env <- getBkpEnv
- case Map.lookup cid (bkp_table bkp_env) of
- Nothing -> pprPanic "missing needed dependency" (ppr cid)
- Just lunit -> return lunit
-
-typecheckUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()
-typecheckUnit cid insts = do
- lunit <- getSource cid
- buildUnit TcSession cid insts lunit
-
-compileUnit :: IndefUnitId -> [(ModuleName, Module)] -> BkpM ()
-compileUnit cid insts = do
- -- Let everyone know we're building this unit
- msgUnitId (mkVirtUnit cid insts)
- lunit <- getSource cid
- buildUnit CompSession cid insts lunit
-
--- | Compute the dependencies with instantiations of a syntactic
--- HsUnit; e.g., wherever you see @dependency p[A=]@ 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 -> IndefUnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
-buildUnit session cid insts lunit = do
- -- NB: include signature dependencies ONLY when typechecking.
- -- If we're compiling, it's not necessary to recursively
- -- compile a signature since it isn't going to produce
- -- any object files.
- let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
- raw_deps = map fst deps_w_rns
- hsc_env <- getSession
- -- The compilation dependencies are just the appropriately filled
- -- in unit IDs which must be compiled before we can compile.
- let hsubst = listToUFM insts
- deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps
-
- -- Build dependencies OR make sure they make sense. BUT NOTE,
- -- we can only check the ones that are fully filled; the rest
- -- we have to defer until we've typechecked our local signature.
- -- TODO: work this into GHC.Driver.Make!!
- forM_ (zip [1..] deps0) $ \(i, dep) ->
- case session of
- TcSession -> return ()
- _ -> compileInclude (length deps0) (i, dep)
-
- -- IMPROVE IT
- let deps = map (improveUnit (hsc_units hsc_env)) deps0
-
- mb_old_eps <- case session of
- TcSession -> fmap Just getEpsGhc
- _ -> return Nothing
-
- conf <- withBkpSession cid insts deps_w_rns session $ do
-
- dflags <- getDynFlags
- mod_graph <- hsunitModuleGraph (unLoc lunit)
-
- msg <- mkBackpackMsg
- ok <- load' LoadAllTargets (Just msg) mod_graph
- when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-
- let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
- export_mod ms = (ms_mod_name ms, ms_mod ms)
- -- Export everything!
- mods = [ export_mod ms | ms <- mgModSummaries mod_graph
- , ms_hsc_src ms == HsSrcFile ]
-
- -- Compile relevant only
- hsc_env <- getSession
- let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
- linkables = map (expectJust "bkp link" . hm_linkable)
- . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
- $ home_mod_infos
- getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
- obj_files = concatMap getOfiles linkables
- state = hsc_units hsc_env
-
- let compat_fs = unitIdFS (indefUnit cid)
- compat_pn = PackageName compat_fs
- unit_id = homeUnitId (hsc_home_unit hsc_env)
-
- return GenericUnitInfo {
- -- Stub data
- unitAbiHash = "",
- unitPackageId = PackageId compat_fs,
- unitPackageName = compat_pn,
- unitPackageVersion = makeVersion [],
- unitId = unit_id,
- unitComponentName = Nothing,
- unitInstanceOf = cid,
- unitInstantiations = insts,
- -- Slight inefficiency here haha
- unitExposedModules = map (\(m,n) -> (m,Just n)) mods,
- unitHiddenModules = [], -- TODO: doc only
- unitDepends = case session of
- -- Technically, we should state that we depend
- -- on all the indefinite libraries we used to
- -- typecheck this. However, this field isn't
- -- really used for anything, so we leave it
- -- blank for now.
- TcSession -> []
- _ -> map (toUnitId . unwireUnit state)
- $ deps ++ [ moduleUnit mod
- | (_, mod) <- insts
- , not (isHoleModule mod) ],
- unitAbiDepends = [],
- unitLinkerOptions = case session of
- TcSession -> []
- _ -> map ST.pack $ obj_files,
- unitImportDirs = [ ST.pack $ hi_dir ],
- unitIsExposed = False,
- unitIsIndefinite = case session of
- TcSession -> True
- _ -> False,
- -- nope
- unitLibraries = [],
- unitExtDepLibsSys = [],
- unitExtDepLibsGhc = [],
- unitLibraryDynDirs = [],
- unitLibraryDirs = [],
- unitExtDepFrameworks = [],
- unitExtDepFrameworkDirs = [],
- unitCcOptions = [],
- unitIncludes = [],
- unitIncludeDirs = [],
- unitHaddockInterfaces = [],
- unitHaddockHTMLs = [],
- unitIsTrusted = False
- }
-
-
- addUnit conf
- case mb_old_eps of
- Just old_eps -> updateEpsGhc_ (const old_eps)
- _ -> return ()
-
-compileExe :: LHsUnit HsComponentId -> BkpM ()
-compileExe lunit = do
- msgUnitId mainUnit
- let deps_w_rns = hsunitDeps False (unLoc lunit)
- deps = map fst deps_w_rns
- -- no renaming necessary
- forM_ (zip [1..] deps) $ \(i, dep) ->
- compileInclude (length deps) (i, dep)
- withBkpExeSession deps_w_rns $ do
- mod_graph <- hsunitModuleGraph (unLoc lunit)
- msg <- mkBackpackMsg
- ok <- load' LoadAllTargets (Just msg) mod_graph
- when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-
--- | Register a new virtual unit database containing a single unit
-addUnit :: GhcMonad m => UnitInfo -> m ()
-addUnit u = do
- hsc_env <- getSession
- logger <- getLogger
- let dflags0 = hsc_dflags hsc_env
- newdbs <- case hsc_unit_dbs hsc_env of
- Nothing -> panic "addUnit: called too early"
- Just dbs ->
- let newdb = UnitDatabase
- { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
- , unitDatabaseUnits = [u]
- }
- in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)
-
- -- update platform constants
- dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
-
- let unit_env = UnitEnv
- { ue_platform = targetPlatform dflags
- , ue_namever = ghcNameVersion dflags
- , ue_home_unit = home_unit
- , ue_units = unit_state
- }
- setSession $ hsc_env
- { hsc_unit_dbs = Just dbs
- , hsc_dflags = dflags
- , hsc_unit_env = unit_env
- }
-
-compileInclude :: Int -> (Int, Unit) -> BkpM ()
-compileInclude n (i, uid) = do
- hsc_env <- getSession
- let pkgs = hsc_units hsc_env
- msgInclude (i, n) uid
- -- Check if we've compiled it already
- case uid of
- HoleUnit -> return ()
- RealUnit _ -> return ()
- VirtUnit i -> case lookupUnit pkgs uid of
- Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)
- Just _ -> return ()
-
--- ----------------------------------------------------------------------------
--- Backpack monad
-
--- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
--- beyond the 'Session', c.f. 'BkpEnv'.
-type BkpM = IOEnv BkpEnv
-
--- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv',
--- because we are going to update the 'HscEnv' as we go.
-data BkpEnv
- = BkpEnv {
- -- | The session
- bkp_session :: Session,
- -- | The filename of the bkp file we're compiling
- bkp_filename :: FilePath,
- -- | Table of source units which we know how to compile
- bkp_table :: Map IndefUnitId (LHsUnit HsComponentId),
- -- | When a package we are compiling includes another package
- -- which has not been compiled, we bump the level and compile
- -- that.
- bkp_level :: Int
- }
-
--- Blah, to get rid of the default instance for IOEnv
--- TODO: just make a proper new monad for BkpM, rather than use IOEnv
-instance {-# OVERLAPPING #-} HasDynFlags BkpM where
- getDynFlags = fmap hsc_dflags getSession
-instance {-# OVERLAPPING #-} HasLogger BkpM where
- getLogger = fmap hsc_logger getSession
-
-
-instance GhcMonad BkpM where
- getSession = do
- Session s <- fmap bkp_session getEnv
- readMutVar s
- setSession hsc_env = do
- Session s <- fmap bkp_session getEnv
- writeMutVar s hsc_env
-
--- | Get the current 'BkpEnv'.
-getBkpEnv :: BkpM BkpEnv
-getBkpEnv = getEnv
-
--- | Get the nesting level, when recursively compiling modules.
-getBkpLevel :: BkpM Int
-getBkpLevel = bkp_level `fmap` getBkpEnv
-
--- | Run a 'BkpM' computation, with the nesting level bumped one.
-innerBkpM :: BkpM a -> BkpM a
-innerBkpM do_this =
- -- NB: withTempSession mutates, so we don't have to worry
- -- about bkp_session being stale.
- updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
-
--- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
-updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
-updateEpsGhc_ f = do
- hsc_env <- getSession
- liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
-
--- | Get the EPS from a 'GhcMonad'.
-getEpsGhc :: GhcMonad m => m ExternalPackageState
-getEpsGhc = do
- hsc_env <- getSession
- liftIO $ readIORef (hsc_EPS hsc_env)
-
--- | Run 'BkpM' in 'Ghc'.
-initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
-initBkpM file bkp m =
- reifyGhc $ \session -> do
- let env = BkpEnv {
- bkp_session = session,
- bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
- bkp_filename = file,
- bkp_level = 0
- }
- runIOEnv env m
-
--- ----------------------------------------------------------------------------
--- Messaging
-
--- | Print a compilation progress message, but with indentation according
--- to @level@ (for nested compilation).
-backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()
-backpackProgressMsg level logger dflags msg =
- compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
- <> msg
-
--- | Creates a 'Messager' for Backpack compilation; this is basically
--- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
--- handles indentation.
-mkBackpackMsg :: BkpM Messager
-mkBackpackMsg = do
- level <- getBkpLevel
- return $ \hsc_env mod_index recomp node ->
- let dflags = hsc_dflags hsc_env
- logger = hsc_logger hsc_env
- state = hsc_units hsc_env
- showMsg msg reason =
- backpackProgressMsg level logger dflags $ pprWithUnitState state $
- showModuleIndex mod_index <>
- msg <> showModMsg dflags (recompileRequired recomp) node
- <> reason
- in case node of
- InstantiationNode _ ->
- case recomp of
- MustCompile -> showMsg (text "Instantiating ") empty
- UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
- | otherwise -> return ()
- RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")
- ModuleNode _ ->
- case recomp of
- MustCompile -> showMsg (text "Compiling ") empty
- UpToDate
- | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty
- | otherwise -> return ()
- RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")
-
--- | 'PprStyle' for Backpack messages; here we usually want the module to
--- be qualified (so we can tell how it was instantiated.) But we try not
--- to qualify packages so we can use simple names for them.
-backpackStyle :: PprStyle
-backpackStyle =
- mkUserStyle
- (QueryQualify neverQualifyNames
- alwaysQualifyModules
- neverQualifyPackages) AllTheWay
-
--- | Message when we initially process a Backpack unit.
-msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
-msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
- dflags <- getDynFlags
- logger <- getLogger
- level <- getBkpLevel
- liftIO . backpackProgressMsg level logger dflags
- $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
-
--- | Message when we instantiate a Backpack unit.
-msgUnitId :: Unit -> BkpM ()
-msgUnitId pk = do
- dflags <- getDynFlags
- logger <- getLogger
- hsc_env <- getSession
- level <- getBkpLevel
- let state = hsc_units hsc_env
- liftIO . backpackProgressMsg level logger dflags
- $ pprWithUnitState state
- $ text "Instantiating "
- <> withPprStyle backpackStyle (ppr pk)
-
--- | Message when we include a Backpack unit.
-msgInclude :: (Int,Int) -> Unit -> BkpM ()
-msgInclude (i,n) uid = do
- dflags <- getDynFlags
- logger <- getLogger
- hsc_env <- getSession
- level <- getBkpLevel
- let state = hsc_units hsc_env
- liftIO . backpackProgressMsg level logger dflags
- $ pprWithUnitState state
- $ showModuleIndex (i, n) <> text "Including "
- <> withPprStyle backpackStyle (ppr uid)
-
--- ----------------------------------------------------------------------------
--- Conversion from PackageName to HsComponentId
-
-type PackageNameMap a = UniqFM PackageName a
-
--- For now, something really simple, since we're not actually going
--- to use this for anything
-unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
-unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
- = (pn, HsComponentId pn (Indefinite (UnitId fs)))
-
-bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
-bkpPackageNameMap units = listToUFM (map unitDefines units)
-
-renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
-renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
- where
-
- renamePackageName :: PackageName -> HsComponentId
- renamePackageName pn =
- case lookupUFM m pn of
- Nothing ->
- case lookupPackageName pkgstate pn of
- Nothing -> error "no package name"
- Just cid -> HsComponentId pn cid
- Just hscid -> hscid
-
- renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
- renameHsUnit u =
- HsUnit {
- hsunitName = fmap renamePackageName (hsunitName u),
- hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
- }
-
- renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
- renameHsUnitDecl (DeclD a b c) = DeclD a b c
- renameHsUnitDecl (IncludeD idecl) =
- IncludeD IncludeDecl {
- idUnitId = fmap renameHsUnitId (idUnitId idecl),
- idModRenaming = idModRenaming idecl,
- idSignatureInclude = idSignatureInclude idecl
- }
-
- renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
- renameHsUnitId (HsUnitId ln subst)
- = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
-
- renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
- renameHsModuleSubst (lk, lm)
- = (lk, fmap renameHsModuleId lm)
-
- renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
- renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
- renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
-
-convertHsComponentId :: HsUnitId HsComponentId -> Unit
-convertHsComponentId (HsUnitId (L _ hscid) subst)
- = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
-
-convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
-convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
-
-convertHsModuleId :: HsModuleId HsComponentId -> Module
-convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
-convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname
-
-
-
-{-
-************************************************************************
-* *
- Module graph construction
-* *
-************************************************************************
--}
-
--- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:
---
--- 1. Every module is required to be mentioned, so we don't do any funny
--- business with targets or recursively grabbing dependencies. (We
--- could support this in principle).
--- 2. We support inline modules, whose summary we have to synthesize ourself.
---
--- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
--- than it's worth for inline modules.
-hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
-hsunitModuleGraph unit = do
- hsc_env <- getSession
-
- let decls = hsunitBody unit
- pn = hsPackageName (unLoc (hsunitName unit))
- home_unit = hsc_home_unit hsc_env
-
- -- 1. Create a HsSrcFile/HsigFile summary for every
- -- explicitly mentioned module/signature.
- let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =
- Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
- get_decl _ = return Nothing
- nodes <- catMaybes `fmap` mapM get_decl decls
-
- -- 2. For each hole which does not already have an hsig file,
- -- create an "empty" hsig file to induce compilation for the
- -- requirement.
- let hsig_set = Set.fromList
- [ ms_mod_name ms
- | ExtendedModSummary { emsModSummary = ms } <- nodes
- , ms_hsc_src ms == HsigFile
- ]
- req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
- if Set.member mod_name hsig_set
- then return Nothing
- else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name
- -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
- -- representing a signature that can't depend on any other unit.
-
- -- 3. Return the kaboodle
- return $ mkModuleGraph' $
- (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)
-
-summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
-summariseRequirement pn mod_name = do
- hsc_env <- getSession
- let dflags = hsc_dflags hsc_env
-
- let PackageName pn_fs = pn
- location <- liftIO $ mkHomeModLocation2 dflags mod_name
- (unpackFS pn_fs moduleNameSlashes mod_name) "hsig"
-
- env <- getBkpEnv
- time <- liftIO $ getModificationUTCTime (bkp_filename env)
- hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
- hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
- let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
-
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
-
- extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
-
- return ModSummary {
- ms_mod = mod,
- ms_hsc_src = HsigFile,
- ms_location = location,
- ms_hs_date = time,
- ms_obj_date = Nothing,
- ms_iface_date = hi_timestamp,
- ms_hie_date = hie_timestamp,
- ms_srcimps = [],
- ms_textual_imps = extra_sig_imports,
- ms_parsed_mod = Just (HsParsedModule {
- hpm_module = L loc (HsModule {
- hsmodAnn = noAnn,
- hsmodLayout = NoLayoutInfo,
- hsmodName = Just (L (noAnnSrcSpan loc) mod_name),
- hsmodExports = Nothing,
- hsmodImports = [],
- hsmodDecls = [],
- hsmodDeprecMessage = Nothing,
- hsmodHaddockModHeader = Nothing
- }),
- hpm_src_files = []
- }),
- ms_hspp_file = "", -- none, it came inline
- ms_hspp_opts = dflags,
- ms_hspp_buf = Nothing
- }
-
-summariseDecl :: PackageName
- -> HscSource
- -> Located ModuleName
- -> Maybe (Located HsModule)
- -> BkpM ExtendedModSummary
-summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
-summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
- = do hsc_env <- getSession
- -- TODO: this looks for modules in the wrong place
- r <- liftIO $ summariseModule hsc_env
- emptyModNodeMap -- GHC API recomp not supported
- (hscSourceToIsBoot hsc_src)
- lmodname
- True -- Target lets you disallow, but not here
- Nothing -- GHC API buffer support not supported
- [] -- No exclusions
- case r of
- Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found"))
- Just (Left err) -> throwErrors err
- Just (Right summary) -> return summary
-
--- | Up until now, GHC has assumed a single compilation target per source file.
--- Backpack files with inline modules break this model, since a single file
--- may generate multiple output files. How do we decide to name these files?
--- Should there only be one output file? This function our current heuristic,
--- which is we make a "fake" module and use that.
-hsModuleToModSummary :: PackageName
- -> HscSource
- -> ModuleName
- -> Located HsModule
- -> BkpM ExtendedModSummary
-hsModuleToModSummary pn hsc_src modname
- hsmod = do
- let imps = hsmodImports (unLoc hsmod)
- loc = getLoc hsmod
- hsc_env <- getSession
- -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation
- -- Use the PACKAGE NAME to find the location
- let PackageName unit_fs = pn
- dflags = hsc_dflags hsc_env
- -- Unfortunately, we have to define a "fake" location in
- -- order to appease the various code which uses the file
- -- name to figure out where to put, e.g. object files.
- -- To add insult to injury, we don't even actually use
- -- these filenames to figure out where the hi files go.
- -- A travesty!
- location0 <- liftIO $ mkHomeModLocation2 dflags modname
- (unpackFS unit_fs
- moduleNameSlashes modname)
- (case hsc_src of
- HsigFile -> "hsig"
- HsBootFile -> "hs-boot"
- HsSrcFile -> "hs")
- -- DANGEROUS: bootifying can POISON the module finder cache
- let location = case hsc_src of
- HsBootFile -> addBootSuffixLocnOut location0
- _ -> location0
- -- This duplicates a pile of logic in GHC.Driver.Make
- env <- getBkpEnv
- time <- liftIO $ getModificationUTCTime (bkp_filename env)
- hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
- hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-
- -- Also copied from 'getImports'
- let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
-
- -- GHC.Prim doesn't exist physically, so don't go looking for it.
- ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
- ord_idecls
-
- implicit_prelude = xopt LangExt.ImplicitPrelude dflags
- implicit_imports = mkPrelImports modname loc
- implicit_prelude imps
- convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc $ ideclName i)
-
- extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
-
- let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
- (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports
-
- -- So that Finder can find it, even though it doesn't exist...
- this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
- return $ ExtendedModSummary
- { emsModSummary =
- ModSummary {
- ms_mod = this_mod,
- ms_hsc_src = hsc_src,
- ms_location = location,
- ms_hspp_file = (case hiDir dflags of
- Nothing -> ""
- Just d -> d) ".." moduleNameSlashes modname <.> "hi",
- ms_hspp_opts = dflags,
- ms_hspp_buf = Nothing,
- ms_srcimps = map convImport src_idecls,
- ms_textual_imps = normal_imports
- -- We have to do something special here:
- -- due to merging, requirements may end up with
- -- extra imports
- ++ extra_sig_imports
- ++ ((,) Nothing . noLoc <$> implicit_sigs),
- -- This is our hack to get the parse tree to the right spot
- ms_parsed_mod = Just (HsParsedModule {
- hpm_module = hsmod,
- hpm_src_files = [] -- TODO if we preprocessed it
- }),
- ms_hs_date = time,
- ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
- ms_iface_date = hi_timestamp,
- ms_hie_date = hie_timestamp
- }
- , emsInstantiatedUnits = inst_deps
- }
-
--- | Create a new, externally provided hashed unit id from
--- a hash.
-newUnitId :: IndefUnitId -> Maybe FastString -> UnitId
-newUnitId uid mhash = case mhash of
- Nothing -> indefUnit uid
- Just hash -> UnitId (unitIdFS (indefUnit uid) `appendFS` mkFastString "+" `appendFS` hash)
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 @@
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
---
--- Makefile Dependency Generation
---
--- (c) The University of Glasgow 2005
---
------------------------------------------------------------------------------
-
-module GHC.Driver.MakeFile
- ( doMkDependHS
- )
-where
-
-#include "GhclibHsVersions.h"
-
-import GHC.Prelude
-
-import qualified GHC
-import GHC.Driver.Monad
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Misc
-import GHC.Driver.Env
-import qualified GHC.SysTools as SysTools
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.SourceError
-import GHC.Types.SrcLoc
-import Data.List (partition)
-import GHC.Data.FastString
-import GHC.Utils.TmpFs
-
-import GHC.Iface.Load (cannotFindModule)
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Graph
-import GHC.Unit.Finder
-
-import GHC.Utils.Exception
-import GHC.Utils.Error
-import GHC.Utils.Logger
-
-import System.Directory
-import System.FilePath
-import System.IO
-import System.IO.Error ( isEOFError )
-import Control.Monad ( when, forM_ )
-import Data.Maybe ( isJust )
-import Data.IORef
-import qualified Data.Set as Set
-
------------------------------------------------------------------
---
--- The main function
---
------------------------------------------------------------------
-
-doMkDependHS :: GhcMonad m => [FilePath] -> m ()
-doMkDependHS srcs = do
- logger <- getLogger
-
- -- Initialisation
- dflags0 <- GHC.getSessionDynFlags
-
- -- We kludge things a bit for dependency generation. Rather than
- -- generating dependencies for each way separately, we generate
- -- them once and then duplicate them for each way's osuf/hisuf.
- -- We therefore do the initial dependency generation with an empty
- -- way and .o/.hi extensions, regardless of any flags that might
- -- be specified.
- let dflags = dflags0
- { targetWays_ = Set.empty
- , hiSuf_ = "hi"
- , objectSuf_ = "o"
- }
- GHC.setSessionDynFlags dflags
-
- when (null (depSuffixes dflags)) $ liftIO $
- throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
-
- tmpfs <- hsc_tmpfs <$> getSession
- files <- liftIO $ beginMkDependHS logger tmpfs dflags
-
- -- Do the downsweep to find all the modules
- targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
- GHC.setTargets targets
- let excl_mods = depExcludeMods dflags
- module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
-
- -- Sort into dependency order
- -- There should be no cycles
- let sorted = GHC.topSortModuleGraph False module_graph Nothing
-
- -- Print out the dependencies if wanted
- liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)
-
- -- Process them one by one, dumping results into makefile
- -- and complaining about cycles
- hsc_env <- getSession
- root <- liftIO getCurrentDirectory
- mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-
- -- If -ddump-mod-cycles, show cycles in the module graph
- liftIO $ dumpModCycles logger dflags module_graph
-
- -- Tidy up
- liftIO $ endMkDependHS logger dflags files
-
- -- Unconditional exiting is a bad idea. If an error occurs we'll get an
- --exception; if that is not caught it's fine, but at least we have a
- --chance to find out exactly what went wrong. Uncomment the following
- --line if you disagree.
-
- --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
-
------------------------------------------------------------------
---
--- beginMkDependHs
--- Create a temporary file,
--- find the Makefile,
--- slurp through it, etc
---
------------------------------------------------------------------
-
-data MkDepFiles
- = MkDep { mkd_make_file :: FilePath, -- Name of the makefile
- mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile
- mkd_tmp_file :: FilePath, -- Name of the temporary file
- mkd_tmp_hdl :: Handle } -- Handle of the open temporary file
-
-beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
-beginMkDependHS logger tmpfs dflags = do
- -- open a new temp file in which to stuff the dependency info
- -- as we go along.
- tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep"
- tmp_hdl <- openFile tmp_file WriteMode
-
- -- open the makefile
- let makefile = depMakefile dflags
- exists <- doesFileExist makefile
- mb_make_hdl <-
- if not exists
- then return Nothing
- else do
- makefile_hdl <- openFile makefile ReadMode
-
- -- slurp through until we get the magic start string,
- -- copying the contents into dep_makefile
- let slurp = do
- l <- hGetLine makefile_hdl
- if (l == depStartMarker)
- then return ()
- else do hPutStrLn tmp_hdl l; slurp
-
- -- slurp through until we get the magic end marker,
- -- throwing away the contents
- let chuck = do
- l <- hGetLine makefile_hdl
- if (l == depEndMarker)
- then return ()
- else chuck
-
- catchIO slurp
- (\e -> if isEOFError e then return () else ioError e)
- catchIO chuck
- (\e -> if isEOFError e then return () else ioError e)
-
- return (Just makefile_hdl)
-
-
- -- write the magic marker into the tmp file
- hPutStrLn tmp_hdl depStartMarker
-
- return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
- mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl})
-
-
------------------------------------------------------------------
---
--- processDeps
---
------------------------------------------------------------------
-
-processDeps :: DynFlags
- -> HscEnv
- -> [ModuleName]
- -> FilePath
- -> Handle -- Write dependencies to here
- -> SCC ModuleGraphNode
- -> IO ()
--- Write suitable dependencies to handle
--- Always:
--- this.o : this.hs
---
--- If the dependency is on something other than a .hi file:
--- this.o this.p_o ... : dep
--- otherwise
--- this.o ... : dep.hi
--- this.p_o ... : dep.p_hi
--- ...
--- (where .o is $osuf, and the other suffixes come from
--- the cmdline -s options).
---
--- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-
-processDeps dflags _ _ _ _ (CyclicSCC nodes)
- = -- There shouldn't be any cycles; report them
- throwGhcExceptionIO $ ProgramError $
- showSDoc dflags $ GHC.cyclicModuleErr nodes
-
-processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))
- = -- There shouldn't be any backpack instantiations; report them as well
- throwGhcExceptionIO $ ProgramError $
- showSDoc dflags $
- vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
- , nest 2 $ ppr node ]
-
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))
- = do { let extra_suffixes = depSuffixes dflags
- include_pkg_deps = depIncludePkgDeps dflags
- src_file = msHsFilePath node
- obj_file = msObjFilePath node
- obj_files = insertSuffixes obj_file extra_suffixes
-
- do_imp loc is_boot pkg_qual imp_mod
- = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
- is_boot include_pkg_deps
- ; case mb_hi of {
- Nothing -> return () ;
- Just hi_file -> do
- { let hi_files = insertSuffixes hi_file extra_suffixes
- write_dep (obj,hi) = writeDependency root hdl [obj] hi
-
- -- Add one dependency for each suffix;
- -- e.g. A.o : B.hi
- -- A.x_o : B.x_hi
- ; mapM_ write_dep (obj_files `zip` hi_files) }}}
-
-
- -- Emit std dependency of the object(s) on the source file
- -- Something like A.o : A.hs
- ; writeDependency root hdl obj_files src_file
-
- -- add dependency between objects and their corresponding .hi-boot
- -- files if the module has a corresponding .hs-boot file (#14482)
- ; when (isBootSummary node == IsBoot) $ do
- let hi_boot = msHiFilePath node
- let obj = removeBootSuffix (msObjFilePath node)
- forM_ extra_suffixes $ \suff -> do
- let way_obj = insertSuffixes obj [suff]
- let way_hi_boot = insertSuffixes hi_boot [suff]
- mapM_ (writeDependency root hdl way_obj) way_hi_boot
-
- -- Emit a dependency for each CPP import
- ; when (depIncludeCppDeps dflags) $ do
- -- CPP deps are descovered in the module parsing phase by parsing
- -- comment lines left by the preprocessor.
- -- Note that GHC.parseModule may throw an exception if the module
- -- fails to parse, which may not be desirable (see #16616).
- { session <- Session <$> newIORef hsc_env
- ; parsedMod <- reflectGhc (GHC.parseModule node) session
- ; mapM_ (writeDependency root hdl obj_files)
- (GHC.pm_extra_src_files parsedMod)
- }
-
- -- Emit a dependency for each import
-
- ; let do_imps is_boot idecls = sequence_
- [ do_imp loc is_boot mb_pkg mod
- | (mb_pkg, L loc mod) <- idecls,
- mod `notElem` excl_mods ]
-
- ; do_imps IsBoot (ms_srcimps node)
- ; do_imps NotBoot (ms_imps node)
- }
-
-
-findDependency :: HscEnv
- -> SrcSpan
- -> Maybe FastString -- package qualifier, if any
- -> ModuleName -- Imported module
- -> IsBootInterface -- Source import
- -> Bool -- Record dependency on package modules
- -> IO (Maybe FilePath) -- Interface file
-findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
- = do { -- Find the module; this will be fast because
- -- we've done it once during downsweep
- r <- findImportedModule hsc_env imp pkg
- ; case r of
- Found loc _
- -- Home package: just depend on the .hi or hi-boot file
- | isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
-
- -- Not in this package: we don't need a dependency
- | otherwise
- -> return Nothing
-
- fail ->
- throwOneError $ mkPlainMsgEnvelope srcloc $
- cannotFindModule hsc_env imp fail
- }
-
------------------------------
-writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
--- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
--- t1 t2 : dep
-writeDependency root hdl targets dep
- = do let -- We need to avoid making deps on
- -- c:/foo/...
- -- on cygwin as make gets confused by the :
- -- Making relative deps avoids some instances of this.
- dep' = makeRelative root dep
- forOutput = escapeSpaces . reslash Forwards . normalise
- output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
- hPutStrLn hdl output
-
------------------------------
-insertSuffixes
- :: FilePath -- Original filename; e.g. "foo.o"
- -> [String] -- Suffix prefixes e.g. ["x_", "y_"]
- -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"]
- -- Note that the extra bit gets inserted *before* the old suffix
- -- We assume the old suffix contains no dots, so we know where to
- -- split it
-insertSuffixes file_name extras
- = [ basename <.> (extra ++ suffix) | extra <- extras ]
- where
- (basename, suffix) = case splitExtension file_name of
- -- Drop the "." from the extension
- (b, s) -> (b, drop 1 s)
-
-
------------------------------------------------------------------
---
--- endMkDependHs
--- Complete the makefile, close the tmp file etc
---
------------------------------------------------------------------
-
-endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO ()
-
-endMkDependHS logger dflags
- (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl,
- mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl })
- = do
- -- write the magic marker into the tmp file
- hPutStrLn tmp_hdl depEndMarker
-
- case makefile_hdl of
- Nothing -> return ()
- Just hdl -> do
-
- -- slurp the rest of the original makefile and copy it into the output
- let slurp = do
- l <- hGetLine hdl
- hPutStrLn tmp_hdl l
- slurp
-
- catchIO slurp
- (\e -> if isEOFError e then return () else ioError e)
-
- hClose hdl
-
- hClose tmp_hdl -- make sure it's flushed
-
- -- Create a backup of the original makefile
- when (isJust makefile_hdl)
- (SysTools.copy logger dflags ("Backing up " ++ makefile)
- makefile (makefile++".bak"))
-
- -- Copy the new makefile in place
- SysTools.copy logger dflags "Installing new makefile" tmp_file makefile
-
-
------------------------------------------------------------------
--- Module cycles
------------------------------------------------------------------
-
-dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()
-dumpModCycles logger dflags module_graph
- | not (dopt Opt_D_dump_mod_cycles dflags)
- = return ()
-
- | null cycles
- = putMsg logger dflags (text "No module cycles")
-
- | otherwise
- = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)
- where
- topoSort = filterToposortToModules $
- GHC.topSortModuleGraph True module_graph Nothing
-
- cycles :: [[ModSummary]]
- cycles =
- [ c | CyclicSCC c <- topoSort ]
-
- pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
- $$ pprCycle c $$ blankLine
- | (n,c) <- [1..] `zip` cycles ]
-
-pprCycle :: [ModSummary] -> SDoc
--- Print a cycle, but show only the imports within the cycle
-pprCycle summaries = pp_group (CyclicSCC summaries)
- where
- cycle_mods :: [ModuleName] -- The modules in this cycle
- cycle_mods = map (moduleName . ms_mod) summaries
-
- pp_group (AcyclicSCC ms) = pp_ms ms
- pp_group (CyclicSCC mss)
- = ASSERT( not (null boot_only) )
- -- The boot-only list must be non-empty, else there would
- -- be an infinite chain of non-boot imports, and we've
- -- already checked for that in processModDeps
- pp_ms loop_breaker $$ vcat (map pp_group groups)
- where
- (boot_only, others) = partition is_boot_only mss
- is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
- in_group (L _ m) = m `elem` group_mods
- group_mods = map (moduleName . ms_mod) mss
-
- loop_breaker = head boot_only
- all_others = tail boot_only ++ others
- groups = filterToposortToModules $
- GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing
-
- pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
- <+> (pp_imps empty (map snd (ms_imps summary)) $$
- pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
- where
- mod_str = moduleNameString (moduleName (ms_mod summary))
-
- pp_imps :: SDoc -> [Located ModuleName] -> SDoc
- pp_imps _ [] = empty
- pp_imps what lms
- = case [m | L _ m <- lms, m `elem` cycle_mods] of
- [] -> empty
- ms -> what <+> text "imports" <+>
- pprWithCommas ppr ms
-
------------------------------------------------------------------
---
--- Flags
---
------------------------------------------------------------------
-
-depStartMarker, depEndMarker :: String
-depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
-depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
-
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/Plugins.hs b/compiler/GHC/Plugins.hs
deleted file mode 100644
--- a/compiler/GHC/Plugins.hs
+++ /dev/null
@@ -1,175 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
-
--- | This module is not used by GHC itself. Rather, it exports all of
--- the functions and types you are likely to need when writing a
--- plugin for GHC. So authors of plugins can probably get away simply
--- with saying "import GHC.Plugins".
---
--- Particularly interesting modules for plugin writers include
--- "GHC.Core" and "GHC.Core.Opt.Monad".
-module GHC.Plugins
- ( module GHC.Driver.Plugins
- , module GHC.Types.Name.Reader
- , module GHC.Types.Name.Occurrence
- , module GHC.Types.Name
- , module GHC.Types.Var
- , module GHC.Types.Id
- , module GHC.Types.Id.Info
- , module GHC.Core.Opt.Monad
- , module GHC.Core
- , module GHC.Types.Literal
- , module GHC.Core.DataCon
- , module GHC.Core.Utils
- , module GHC.Core.Make
- , module GHC.Core.FVs
- , module GHC.Core.Subst
- , module GHC.Core.Rules
- , module GHC.Types.Annotations
- , module GHC.Driver.Session
- , module GHC.Driver.Ppr
- , module GHC.Unit.State
- , module GHC.Unit.Module
- , module GHC.Core.Type
- , module GHC.Core.TyCon
- , module GHC.Core.Coercion
- , module GHC.Builtin.Types
- , module GHC.Driver.Env
- , module GHC.Types.Basic
- , module GHC.Types.Var.Set
- , module GHC.Types.Var.Env
- , module GHC.Types.Name.Set
- , module GHC.Types.Name.Env
- , module GHC.Types.Unique
- , module GHC.Types.Unique.Set
- , module GHC.Types.Unique.FM
- , module GHC.Data.FiniteMap
- , module GHC.Utils.Misc
- , module GHC.Serialized
- , module GHC.Types.SrcLoc
- , module GHC.Utils.Outputable
- , module GHC.Utils.Panic
- , module GHC.Types.Unique.Supply
- , module GHC.Data.FastString
- , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins
- , module GHC.Unit.Module.ModGuts
- , module GHC.Unit.Module.ModSummary
- , module GHC.Unit.Module.ModIface
- , module GHC.Types.Meta
- , module GHC.Types.SourceError
- , -- * Getting 'Name's
- thNameToGhcName
- )
-where
-
--- Plugin stuff itself
-import GHC.Driver.Plugins
-
--- Variable naming
-import GHC.Types.TyThing
-import GHC.Types.SourceError
-import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} )
-import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} )
-import GHC.Types.Var
-import GHC.Types.Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
-import GHC.Types.Id.Info
-
--- Core
-import GHC.Core.Opt.Monad
-import GHC.Core
-import GHC.Types.Literal
-import GHC.Core.DataCon
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.Core.FVs
-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
- -- These names are also exported by Type
-
-import GHC.Core.Rules
-import GHC.Types.Annotations
-import GHC.Types.Meta
-
-import GHC.Driver.Session
-import GHC.Unit.State
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.ModIface
-import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}
- ( substTy, extendTvSubst, extendTvSubstList, isInScope )
-import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}
- ( substCo )
-import GHC.Core.TyCon
-import GHC.Builtin.Types
-import GHC.Driver.Env
-import GHC.Types.Basic
-
--- Collections and maps
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
--- Conflicts with UniqFM:
---import LazyUniqFM
-import GHC.Data.FiniteMap
-
--- Common utilities
-import GHC.Utils.Misc
-import GHC.Serialized
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Driver.Ppr
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique ( Unique, Uniquable(..) )
-import GHC.Data.FastString
-import Data.Maybe
-
-import GHC.Iface.Env ( lookupOrigIO )
-import GHC.Prelude
-import GHC.Utils.Monad ( mapMaybeM )
-import GHC.ThToHs ( thRdrNameGuesses )
-import GHC.Tc.Utils.Env ( lookupGlobal )
-
-import GHC.Tc.Errors.Hole.FitTypes
-
-import qualified Language.Haskell.TH as TH
-
-{- This instance is defined outside GHC.Core.Opt.Monad so that
- GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}
-instance MonadThings CoreM where
- lookupThing name = do { hsc_env <- getHscEnv
- ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-* *
- Template Haskell interoperability
-* *
-************************************************************************
--}
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name
- = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
- -- Pick the first that works
- -- E.g. reify (mkName "A") will pick the class A in preference
- -- to the data constructor A
- ; return (listToMaybe names) }
- where
- lookup rdr_name
- | Just n <- isExact_maybe rdr_name -- This happens in derived code
- = return $ if isExternalName n then Just n else Nothing
- | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
- = do { hsc_env <- getHscEnv
- ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }
- | otherwise = return Nothing
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,250 +0,0 @@
------------------------------------------------------------------------------
---
--- GHCi Interactive debugging commands
---
--- Pepe Iborra (supported by Google SoC) 2006
---
--- ToDo: lots of violation of layering here. This module should
--- decide whether it is above the GHC API (import GHC and nothing
--- else) or below it.
---
------------------------------------------------------------------------------
-
-module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
-
-import GHC.Prelude
-
-import GHC
-
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Monad
-import GHC.Driver.Env
-
-import GHC.Linker.Loader
-
-import GHC.Runtime.Heap.Inspect
-import GHC.Runtime.Interpreter
-import GHC.Runtime.Context
-
-import GHC.Iface.Syntax ( showToHeader )
-import GHC.Iface.Env ( newInteractiveBinder )
-import GHC.Core.Type
-
-import GHC.Utils.Outputable
-import GHC.Utils.Error
-import GHC.Utils.Monad
-import GHC.Utils.Exception
-import GHC.Utils.Logger
-
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Var hiding ( varName )
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Set
-import GHC.Types.TyThing.Ppr
-import GHC.Types.TyThing
-
-import Control.Monad
-import Control.Monad.Catch as MC
-import Data.List ( (\\) )
-import Data.Maybe
-import Data.IORef
-
--------------------------------------
--- | The :print & friends commands
--------------------------------------
-pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
-pprintClosureCommand bindThings force str = do
- tythings <- (catMaybes . concat) `liftM`
- mapM (\w -> GHC.parseName w >>=
- mapM GHC.lookupName)
- (words str)
- let ids = [id | AnId id <- tythings]
-
- -- Obtain the terms and the recovered type information
- (subst, terms) <- mapAccumLM go emptyTCvSubst ids
-
- -- Apply the substitutions obtained after recovering the types
- modifySession $ \hsc_env ->
- hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
-
- -- Finally, print the Terms
- unqual <- GHC.getPrintUnqual
- docterms <- mapM showTerm terms
- dflags <- getDynFlags
- logger <- getLogger
- liftIO $ (printOutputForUser logger dflags unqual . vcat)
- (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
- ids
- docterms)
- where
- -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
- go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
- go subst id = do
- let id' = updateIdTypeAndMult (substTy subst) id
- id_ty' = idType id'
- term_ <- GHC.obtainTermFromId maxBound force id'
- term <- tidyTermTyVars term_
- term' <- if bindThings
- then bindSuspensions term
- else return term
- -- Before leaving, we compare the type obtained to see if it's more specific
- -- Then, we extract a substitution,
- -- mapping the old tyvars to the reconstructed types.
- let reconstructed_type = termType term
- hsc_env <- getSession
- case (improveRTTIType hsc_env id_ty' reconstructed_type) of
- Nothing -> return (subst, term')
- Just subst' -> do { dflags <- GHC.getSessionDynFlags
- ; logger <- getLogger
- ; liftIO $
- dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"
- FormatText
- (fsep $ [text "RTTI Improvement for", ppr id,
- text "old substitution:" , ppr subst,
- text "new substitution:" , ppr subst'])
- ; return (subst `unionTCvSubst` subst', term')}
-
- tidyTermTyVars :: GhcMonad m => Term -> m Term
- tidyTermTyVars t =
- withSession $ \hsc_env -> do
- let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
- my_tvs = termTyCoVars t
- tvs = env_tvs `minusVarSet` my_tvs
- tyvarOccName = nameOccName . tyVarName
- tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
- -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
- -- forgets the ordering immediately by creating an env
- , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
- return $ mapTermType (snd . tidyOpenType tidyEnv) t
-
--- | Give names, and bind in the interactive environment, to all the suspensions
--- included (inductively) in a term
-bindSuspensions :: GhcMonad m => Term -> m Term
-bindSuspensions t = do
- hsc_env <- getSession
- inScope <- GHC.getBindings
- let ictxt = hsc_IC hsc_env
- prefix = "_t"
- alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
- availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
- availNames_var <- liftIO $ newIORef availNames
- (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
- let (names, tys, fhvs) = unzip3 stuff
- let ids = [ mkVanillaGlobal name ty
- | (name,ty) <- zip names tys]
- new_ic = extendInteractiveContextWithIds ictxt ids
- interp = hscInterp hsc_env
- liftIO $ extendLoadedEnv interp (zip names fhvs)
- setSession hsc_env {hsc_IC = new_ic }
- return t'
- where
-
--- Processing suspensions. Give names and recopilate info
- nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
- -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
- nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
- {
- fSuspension = doSuspension hsc_env freeNames
- , fTerm = \ty dc v tt -> do
- tt' <- sequence tt
- let (terms,names) = unzip tt'
- return (Term ty dc v terms, concat names)
- , fPrim = \ty n ->return (Prim ty n,[])
- , fNewtypeWrap =
- \ty dc t -> do
- (term, names) <- t
- return (NewtypeWrap ty dc term, names)
- , fRefWrap = \ty t -> do
- (term, names) <- t
- return (RefWrap ty term, names)
- }
- doSuspension hsc_env freeNames ct ty hval _name = do
- name <- atomicModifyIORef' freeNames (\x->(tail x, head x))
- n <- newGrimName hsc_env name
- return (Suspension ct ty hval (Just n), [(n,ty,hval)])
-
-
--- A custom Term printer to enable the use of Show instances
-showTerm :: GhcMonad m => Term -> m SDoc
-showTerm term = do
- dflags <- GHC.getSessionDynFlags
- if gopt Opt_PrintEvldWithShow dflags
- then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
- else cPprTerm cPprTermBase term
- where
- cPprShowable prec t@Term{ty=ty, val=fhv} =
- if not (isFullyEvaluatedTerm t)
- then return Nothing
- else do
- let set_session = do
- hsc_env <- getSession
- (new_env, bname) <- bindToFreshName hsc_env ty "showme"
- setSession new_env
-
- -- this disables logging of errors
- let noop_log _ _ _ _ _ = return ()
- pushLogHookM (const noop_log)
-
- return (hsc_env, bname)
-
- reset_session (old_env,_) = setSession old_env
-
- MC.bracket set_session reset_session $ \(_,bname) -> do
- hsc_env <- getSession
- dflags <- GHC.getSessionDynFlags
- let expr = "Prelude.return (Prelude.show " ++
- showPpr dflags bname ++
- ") :: Prelude.IO Prelude.String"
- interp = hscInterp hsc_env
- txt_ <- withExtendedLoadedEnv interp
- [(bname, fhv)]
- (GHC.compileExprRemote expr)
- let myprec = 10 -- application precedence. TODO Infix constructors
- txt <- liftIO $ evalString interp txt_
- if not (null txt) then
- return $ Just $ cparen (prec >= myprec && needsParens txt)
- (text txt)
- else return Nothing
-
- cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
- cPprShowable prec t{ty=new_ty}
- cPprShowable _ _ = return Nothing
-
- needsParens ('"':_) = False -- some simple heuristics to see whether parens
- -- are redundant in an arbitrary Show output
- needsParens ('(':_) = False
- needsParens txt = ' ' `elem` txt
-
-
- bindToFreshName hsc_env ty userName = do
- name <- newGrimName hsc_env userName
- let id = mkVanillaGlobal name ty
- new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
- return (hsc_env {hsc_IC = new_ic }, name)
-
--- Create new uniques and give them sequentially numbered names
-newGrimName :: MonadIO m => HscEnv -> String -> m Name
-newGrimName hsc_env userName
- = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
- where
- occ = mkOccName varName userName
-
-pprTypeAndContents :: GhcMonad m => Id -> m SDoc
-pprTypeAndContents id = do
- dflags <- GHC.getSessionDynFlags
- let pcontents = gopt Opt_PrintBindContents dflags
- pprdId = (pprTyThing showToHeader . AnId) id
- if pcontents
- then do
- let depthBound = 100
- -- If the value is an exception, make sure we catch it and
- -- show the exception, rather than propagating the exception out.
- e_term <- MC.try $ GHC.obtainTermFromId depthBound False id
- docs_term <- case e_term of
- Right term -> showTerm term
- Left exn -> return (text "*** Exception:" <+>
- text (show (exn :: SomeException)))
- return $ pprdId <+> equals <+> docs_term
- else return pprdId
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,190 +0,0 @@
-{-# LANGUAGE CPP #-}
--- | This module provides an interface for typechecker plugins to
--- access select functions of the 'TcM', principally those to do with
--- reading parts of the state.
-module GHC.Tc.Plugin (
- -- * Basic TcPluginM functionality
- TcPluginM,
- tcPluginIO,
- tcPluginTrace,
- unsafeTcPluginTcM,
-
- -- * Finding Modules and Names
- Finder.FindResult(..),
- findImportedModule,
- lookupOrig,
-
- -- * Looking up Names in the typechecking environment
- tcLookupGlobal,
- tcLookupTyCon,
- tcLookupDataCon,
- tcLookupClass,
- tcLookup,
- tcLookupId,
-
- -- * Getting the TcM state
- getTopEnv,
- getEnvs,
- getInstEnvs,
- getFamInstEnvs,
- matchFam,
-
- -- * Type variables
- newUnique,
- newFlexiTyVar,
- isTouchableTcPluginM,
-
- -- * Zonking
- zonkTcType,
- zonkCt,
-
- -- * Creating constraints
- newWanted,
- newDerived,
- newGiven,
- newCoercionHole,
-
- -- * Manipulating evidence bindings
- newEvVar,
- setEvBind,
- getEvBindsTcPluginM
- ) where
-
-import GHC.Prelude
-
-import qualified GHC.Tc.Utils.Monad as TcM
-import qualified GHC.Tc.Solver.Monad as TcS
-import qualified GHC.Tc.Utils.Env as TcM
-import qualified GHC.Tc.Utils.TcMType as TcM
-import qualified GHC.Tc.Instance.Family as TcM
-import qualified GHC.Iface.Env as IfaceEnv
-import qualified GHC.Unit.Finder as Finder
-
-import GHC.Core.FamInstEnv ( FamInstEnv )
-import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM
- , unsafeTcPluginTcM, getEvBindsTcPluginM
- , liftIO, traceTc )
-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin )
-import GHC.Tc.Utils.TcMType ( TcTyVar, TcType )
-import GHC.Tc.Utils.Env ( TcTyThing )
-import GHC.Tc.Types.Evidence ( TcCoercion, CoercionHole, EvTerm(..)
- , EvExpr, EvBind, mkGivenEvBind )
-import GHC.Types.Var ( EvVar )
-
-import GHC.Unit.Module
-import GHC.Types.Name
-import GHC.Types.TyThing
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.Class
-import GHC.Driver.Env
-import GHC.Utils.Outputable
-import GHC.Core.Type
-import GHC.Types.Id
-import GHC.Core.InstEnv
-import GHC.Data.FastString
-import GHC.Types.Unique
-
-
--- | Perform some IO, typically to interact with an external tool.
-tcPluginIO :: IO a -> TcPluginM a
-tcPluginIO a = unsafeTcPluginTcM (liftIO a)
-
--- | Output useful for debugging the compiler.
-tcPluginTrace :: String -> SDoc -> TcPluginM ()
-tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
-
-
-findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult
-findImportedModule mod_name mb_pkg = do
- hsc_env <- getTopEnv
- tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
-
-lookupOrig :: Module -> OccName -> TcPluginM Name
-lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
-
-
-tcLookupGlobal :: Name -> TcPluginM TyThing
-tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
-
-tcLookupTyCon :: Name -> TcPluginM TyCon
-tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
-
-tcLookupDataCon :: Name -> TcPluginM DataCon
-tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
-
-tcLookupClass :: Name -> TcPluginM Class
-tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
-
-tcLookup :: Name -> TcPluginM TcTyThing
-tcLookup = unsafeTcPluginTcM . TcM.tcLookup
-
-tcLookupId :: Name -> TcPluginM Id
-tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
-
-
-getTopEnv :: TcPluginM HscEnv
-getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
-
-getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
-getEnvs = unsafeTcPluginTcM TcM.getEnvs
-
-getInstEnvs :: TcPluginM InstEnvs
-getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
-
-getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
-getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
-
-matchFam :: TyCon -> [Type]
- -> TcPluginM (Maybe (TcCoercion, TcType))
-matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
-
-newUnique :: TcPluginM Unique
-newUnique = unsafeTcPluginTcM TcM.newUnique
-
-newFlexiTyVar :: Kind -> TcPluginM TcTyVar
-newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
-
-isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
-isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
-
--- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
-zonkTcType :: TcType -> TcPluginM TcType
-zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
-
-zonkCt :: Ct -> TcPluginM Ct
-zonkCt = unsafeTcPluginTcM . TcM.zonkCt
-
-
--- | Create a new wanted constraint.
-newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence
-newWanted loc pty
- = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty)
-
--- | Create a new derived constraint.
-newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
-newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
-
--- | Create a new given constraint, with the supplied evidence. This
--- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
--- will panic.
-newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
-newGiven loc pty evtm = do
- new_ev <- newEvVar pty
- setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
- return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
-
--- | Create a fresh evidence variable.
-newEvVar :: PredType -> TcPluginM EvVar
-newEvVar = unsafeTcPluginTcM . TcM.newEvVar
-
--- | Create a fresh coercion hole.
-newCoercionHole :: PredType -> TcPluginM CoercionHole
-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
-
--- | Bind an evidence variable. This must not be invoked from
--- 'tcPluginInit' or 'tcPluginStop', or it will panic.
-setEvBind :: EvBind -> TcPluginM ()
-setEvBind ev_bind = do
- tc_evbinds <- getEvBindsTcPluginM
- unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
--- a/ghc-lib.cabal
+++ b/ghc-lib.cabal
@@ -1,7 +1,7 @@
cabal-version: 2.0
build-type: Simple
name: ghc-lib
-version: 9.2.7.20230228
+version: 9.2.8.20230729
license: BSD3
license-file: LICENSE
category: Development
@@ -82,11 +82,11 @@
array >= 0.1 && < 0.6,
deepseq >= 1.4 && < 1.5,
pretty == 1.1.*,
- transformers == 0.5.*,
+ transformers >= 0.5 && < 0.7,
process >= 1 && < 1.7,
rts,
hpc == 0.6.*,
- ghc-lib-parser == 9.2.7.20230228
+ ghc-lib-parser == 9.2.8.20230729
build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4
other-extensions:
BangPatterns
@@ -127,9 +127,7 @@
NoImplicitPrelude
ScopedTypeVariables
hs-source-dirs:
- ghc-lib/stage0/libraries/ghc-boot/build
ghc-lib/stage0/compiler/build
- libraries/template-haskell
libraries/ghc-boot
libraries/ghci
compiler
@@ -495,14 +493,11 @@
GHC.CmmToAsm.PPC.Regs
GHC.CmmToAsm.Ppr
GHC.CmmToAsm.Reg.Graph
- GHC.CmmToAsm.Reg.Graph.Base
- GHC.CmmToAsm.Reg.Graph.Coalesce
GHC.CmmToAsm.Reg.Graph.Spill
GHC.CmmToAsm.Reg.Graph.SpillClean
GHC.CmmToAsm.Reg.Graph.SpillCost
GHC.CmmToAsm.Reg.Graph.Stats
GHC.CmmToAsm.Reg.Graph.TrivColorable
- GHC.CmmToAsm.Reg.Graph.X86
GHC.CmmToAsm.Reg.Linear
GHC.CmmToAsm.Reg.Linear.AArch64
GHC.CmmToAsm.Reg.Linear.Base
@@ -585,13 +580,10 @@
GHC.Data.Graph.Ppr
GHC.Data.Graph.UnVar
GHC.Data.UnionFind
- GHC.Driver.Backpack
GHC.Driver.CodeOutput
GHC.Driver.Main
GHC.Driver.Make
- GHC.Driver.MakeFile
GHC.Driver.Pipeline
- GHC.HandleEncoding
GHC.Hs.Stats
GHC.HsToCore
GHC.HsToCore.Arrows
@@ -634,7 +626,6 @@
GHC.Iface.Tidy
GHC.Iface.Tidy.StaticPtrTable
GHC.IfaceToCore
- GHC.Linker
GHC.Linker.Dynamic
GHC.Linker.ExtraObj
GHC.Linker.Loader
@@ -648,8 +639,6 @@
GHC.Llvm.Syntax
GHC.Llvm.Types
GHC.Parser.Utils
- GHC.Platform.Host
- GHC.Plugins
GHC.Rename.Bind
GHC.Rename.Env
GHC.Rename.Expr
@@ -661,7 +650,6 @@
GHC.Rename.Splice
GHC.Rename.Unbound
GHC.Rename.Utils
- GHC.Runtime.Debugger
GHC.Runtime.Eval
GHC.Runtime.Heap.Inspect
GHC.Runtime.Interpreter
@@ -734,7 +722,6 @@
GHC.Tc.Instance.FunDeps
GHC.Tc.Instance.Typeable
GHC.Tc.Module
- GHC.Tc.Plugin
GHC.Tc.Solver
GHC.Tc.Solver.Canonical
GHC.Tc.Solver.Interact
@@ -763,13 +750,4 @@
GHC.Utils.Asm
GHC.Utils.Monad.State
GHCi.BinaryArray
- GHCi.CreateBCO
- GHCi.InfoTable
- GHCi.ObjLink
GHCi.ResolvedBCO
- GHCi.Run
- GHCi.Signals
- GHCi.StaticPtrTable
- GHCi.TH
- Language.Haskell.TH.CodeDo
- Language.Haskell.TH.Quote
diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs
deleted file mode 100644
--- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module GHC.Platform.Host where
-
-import GHC.Platform.ArchOS
-
-hostPlatformArch :: Arch
-hostPlatformArch = ArchX86_64
-
-hostPlatformOS :: OS
-hostPlatformOS = OSDarwin
-
-hostPlatformArchOS :: ArchOS
-hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS
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
- env <- getEnvironment
- case lookup "GHC_CHARENC" env of
- Just "UTF-8" -> do
- hSetEncoding stdout utf8
- hSetEncoding stderr utf8
- _ -> do
- -- Avoid GHC erroring out when trying to display unhandled characters
- hSetTranslit stdout
- hSetTranslit stderr
-
--- | Change the character encoding of the given Handle to transliterate
--- on unsupported characters instead of throwing an exception
-hSetTranslit :: Handle -> IO ()
-hSetTranslit h = do
- menc <- hGetEncoding h
- case fmap textEncodingName menc of
- Just name | '/' `notElem` name -> do
- enc' <- mkTextEncoding $ name ++ "//TRANSLIT"
- hSetEncoding h enc'
- _ -> return ()
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,205 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
-
---
--- (c) The University of Glasgow 2002-2006
---
-
--- | Create real byte-code objects from 'ResolvedBCO's.
-module GHCi.CreateBCO (createBCOs) where
-
-import Prelude -- See note [Why do we import Prelude here?]
-import GHCi.ResolvedBCO
-import GHCi.RemoteTypes
-import GHCi.BreakArray
-import GHC.Data.SizedSeq
-
-import System.IO (fixIO)
-import Control.Monad
-import Data.Array.Base
-import Foreign hiding (newArray)
-import Unsafe.Coerce (unsafeCoerce)
-import GHC.Arr ( Array(..) )
-import GHC.Exts
-import GHC.IO
-import Control.Exception ( ErrorCall(..) )
-
-createBCOs :: [ResolvedBCO] -> IO [HValueRef]
-createBCOs bcos = do
- let n_bcos = length bcos
- hvals <- fixIO $ \hvs -> do
- let arr = listArray (0, n_bcos-1) hvs
- mapM (createBCO arr) bcos
- mapM mkRemoteRef hvals
-
-createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
-createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian
- = throwIO (ErrorCall $
- unlines [ "The endianness of the ResolvedBCO does not match"
- , "the systems endianness. Using ghc and iserv in a"
- , "mixed endianness setup is not supported!"
- ])
-createBCO arr bco
- =
-#if MIN_VERSION_ghc_prim(0, 7, 0)
- do linked_bco <- linkBCO' arr bco
-#else
- do BCO bco# <- linkBCO' arr bco
-#endif
-
- -- Note [Updatable CAF BCOs]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~
- -- Why do we need mkApUpd0 here? Otherwise top-level
- -- interpreted CAFs don't get updated after evaluation. A
- -- top-level BCO will evaluate itself and return its value
- -- when entered, but it won't update itself. Wrapping the BCO
- -- in an AP_UPD thunk will take care of the update for us.
- --
- -- Furthermore:
- -- (a) An AP thunk *must* point directly to a BCO
- -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
- -- (c) An AP is always fully saturated, so we *can't* wrap
- -- non-zero arity BCOs in an AP thunk.
- --
- -- See #17424.
- if (resolvedBCOArity bco > 0)
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
- then return (HValue (unsafeCoerce linked_bco))
- else case mkApUpd0# linked_bco of { (# final_bco #) ->
-#else
- then return (HValue (unsafeCoerce# bco#))
- else case mkApUpd0# bco# of { (# final_bco #) ->
-#endif
-
- return (HValue final_bco) }
-
-
-toWordArray :: UArray Int Word64 -> UArray Int Word
-toWordArray = amap fromIntegral
-
-linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO
-linkBCO' arr ResolvedBCO{..} = do
- let
- ptrs = ssElts resolvedBCOPtrs
- n_ptrs = sizeSS resolvedBCOPtrs
-
- !(I# arity#) = resolvedBCOArity
-
- !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
-
- barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b
- insns_barr = barr resolvedBCOInstrs
- bitmap_barr = barr (toWordArray resolvedBCOBitmap)
- literals_barr = barr (toWordArray resolvedBCOLits)
-
- PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
- IO $ \s ->
- case unsafeFreezeArray# marr s of { (# s, arr #) ->
- case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->
- io s
- }}
-
-
--- we recursively link any sub-BCOs while making the ptrs array
-mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
-mkPtrsArray arr n_ptrs ptrs = do
- marr <- newPtrsArray (fromIntegral n_ptrs)
- let
- fill (ResolvedBCORef n) i =
- writePtrsArrayHValue i (arr ! n) marr -- must be lazy!
- fill (ResolvedBCOPtr r) i = do
- hv <- localRef r
- writePtrsArrayHValue i hv marr
- fill (ResolvedBCOStaticPtr r) i = do
- writePtrsArrayPtr i (fromRemotePtr r) marr
- fill (ResolvedBCOPtrBCO bco) i = do
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
- bco <- linkBCO' arr bco
- writePtrsArrayBCO i bco marr
-#else
- BCO bco# <- linkBCO' arr bco
- writePtrsArrayBCO i bco# marr
-#endif
-
- fill (ResolvedBCOPtrBreakArray r) i = do
- BA mba <- localRef r
- writePtrsArrayMBA i mba marr
- zipWithM_ fill ptrs [0..]
- return marr
-
-data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
-
-newPtrsArray :: Int -> IO PtrsArr
-newPtrsArray (I# i) = IO $ \s ->
- case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)
-
-writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()
-writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->
- case writeArray# arr i hv s of s' -> (# s', () #)
-
-writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()
-writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->
- case writeArrayAddr# arr i a# s of s' -> (# s', () #)
-
--- This is rather delicate: convincing GHC to pass an Addr# as an Any but
--- without making a thunk turns out to be surprisingly tricky.
-{-# NOINLINE writeArrayAddr# #-}
-writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
-writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
-
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
-#else
-writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
-#endif
-
-writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
- case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
-
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
-#else
-data BCO = BCO BCO#
-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
-#endif
-
-writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
- case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
-
-newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
-newBCO instrs lits ptrs arity bitmap = IO $ \s ->
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
- newBCO# instrs lits ptrs arity bitmap s
-#else
- case newBCO# instrs lits ptrs arity bitmap s of
- (# s1, bco #) -> (# s1, BCO bco #)
-#endif
-
-
-{- Note [BCO empty array]
- ~~~~~~~~~~~~~~~~~~~~~~
-Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
-they are 2-word heap objects. So let's make a single empty array and
-share it between all BCOs.
--}
-
-data EmptyArr = EmptyArr ByteArray#
-
-{-# NOINLINE emptyArr #-}
-emptyArr :: EmptyArr
-emptyArr = unsafeDupablePerformIO $ IO $ \s ->
- case newByteArray# 0# s of { (# s, arr #) ->
- case unsafeFreezeByteArray# arr s of { (# s, farr #) ->
- (# s, EmptyArr farr #)
- }}
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,432 +0,0 @@
-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
-
--- Get definitions for the structs, constants & config etc.
-#include "Rts.h"
-
--- |
--- Run-time info table support. This module provides support for
--- creating and reading info tables /in the running program/.
--- We use the RTS data structures directly via hsc2hs.
---
-module GHCi.InfoTable
- (
- mkConInfoTable
- ) where
-
-import Prelude hiding (fail) -- See note [Why do we import Prelude here?]
-
-import Foreign
-import Foreign.C
-import GHC.Ptr
-import GHC.Exts
-import GHC.Exts.Heap
-import Data.ByteString (ByteString)
-import Control.Monad.Fail
-import qualified Data.ByteString as BS
-import GHC.Platform.Host (hostPlatformArch)
-import GHC.Platform.ArchOS
-
--- NOTE: Must return a pointer acceptable for use in the header of a closure.
--- If tables_next_to_code is enabled, then it must point the 'code' field.
--- Otherwise, it should point to the start of the StgInfoTable.
-mkConInfoTable
- :: Bool -- TABLES_NEXT_TO_CODE
- -> Int -- ptr words
- -> Int -- non-ptr words
- -> Int -- constr tag
- -> Int -- pointer tag
- -> ByteString -- con desc
- -> IO (Ptr StgInfoTable)
- -- resulting info table is allocated with allocateExecPage(), and
- -- should be freed with freeExecPage().
-
-mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do
- let entry_addr = interpConstrEntry !! ptrtag
- code' <- if tables_next_to_code
- then Just <$> mkJumpToAddr entry_addr
- else pure Nothing
- let
- itbl = StgInfoTable {
- entry = if tables_next_to_code
- then Nothing
- else Just entry_addr,
- ptrs = fromIntegral ptr_words,
- nptrs = fromIntegral nonptr_words,
- tipe = CONSTR,
- srtlen = fromIntegral tag,
- code = code'
- }
- castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc
-
-
--- -----------------------------------------------------------------------------
--- Building machine code fragments for a constructor's entry code
-
-funPtrToInt :: FunPtr a -> Int
-funPtrToInt (FunPtr a) = I## (addr2Int## a)
-
-mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
-mkJumpToAddr a = case hostPlatformArch of
- ArchSPARC -> pure $
- -- After some consideration, we'll try this, where
- -- 0x55555555 stands in for the address to jump to.
- -- According to includes/rts/MachRegs.h, %g3 is very
- -- likely indeed to be baggable.
- --
- -- 0000 07155555 sethi %hi(0x55555555), %g3
- -- 0004 8610E155 or %g3, %lo(0x55555555), %g3
- -- 0008 81C0C000 jmp %g3
- -- 000c 01000000 nop
-
- let w32 = fromIntegral (funPtrToInt a)
-
- hi22, lo10 :: Word32 -> Word32
- lo10 x = x .&. 0x3FF
- hi22 x = (x `shiftR` 10) .&. 0x3FFFF
-
- in Right [ 0x07000000 .|. (hi22 w32),
- 0x8610E000 .|. (lo10 w32),
- 0x81C0C000,
- 0x01000000 ]
-
- ArchPPC -> pure $
- -- We'll use r12, for no particular reason.
- -- 0xDEADBEEF stands for the address:
- -- 3D80DEAD lis r12,0xDEAD
- -- 618CBEEF ori r12,r12,0xBEEF
- -- 7D8903A6 mtctr r12
- -- 4E800420 bctr
-
- let w32 = fromIntegral (funPtrToInt a)
- hi16 x = (x `shiftR` 16) .&. 0xFFFF
- lo16 x = x .&. 0xFFFF
- in Right [ 0x3D800000 .|. hi16 w32,
- 0x618C0000 .|. lo16 w32,
- 0x7D8903A6, 0x4E800420 ]
-
- ArchX86 -> pure $
- -- Let the address to jump to be 0xWWXXYYZZ.
- -- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
- -- which is
- -- B8 ZZ YY XX WW FF E0
-
- let w32 = fromIntegral (funPtrToInt a) :: Word32
- insnBytes :: [Word8]
- insnBytes
- = [0xB8, byte0 w32, byte1 w32,
- byte2 w32, byte3 w32,
- 0xFF, 0xE0]
- in
- Left insnBytes
-
- ArchX86_64 -> pure $
- -- Generates:
- -- jmpq *.L1(%rip)
- -- .align 8
- -- .L1:
- -- .quad
- --
- -- 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,