ghc-lib 0.20190806 → 0.20190903
raw patch · 75 files changed
+674/−934 lines, 75 filesdep ~ghc-lib-parserPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- Debug: dblIsEntry :: DebugBlock -> Bool
- Fingerprint: Fingerprint :: {-# UNPACK #-} !Word64 -> {-# UNPACK #-} !Word64 -> Fingerprint
- Fingerprint: data Fingerprint
- Fingerprint: fingerprint0 :: Fingerprint
- Fingerprint: fingerprintByteString :: ByteString -> Fingerprint
- Fingerprint: fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
- Fingerprint: fingerprintFingerprints :: [Fingerprint] -> Fingerprint
- Fingerprint: fingerprintString :: String -> Fingerprint
- Fingerprint: getFileHash :: FilePath -> IO Fingerprint
- Fingerprint: readHexFingerprint :: String -> Fingerprint
- HieAst: instance (a Data.Type.Equality.~ HsExtension.GhcPass p, HieAst.ToHie (HieAst.Context (SrcLoc.Located (HsExtension.IdP a))), HieAst.HasType (HsExpr.LHsExpr a), HieAst.ToHie (HieAst.PScoped (HsPat.LPat a)), HieAst.ToHie (HsExpr.MatchGroup a (HsExpr.LHsExpr a)), HieAst.ToHie (HsExpr.LGRHS a (HsExpr.LHsExpr a)), HieAst.ToHie (HieAst.RContext (HsExpr.HsRecordBinds a)), HieAst.ToHie (HieAst.RFContext (SrcLoc.Located (HsTypes.AmbiguousFieldOcc a))), HieAst.ToHie (HsExpr.ArithSeqInfo a), HieAst.ToHie (HsExpr.LHsCmdTop a), HieAst.ToHie (HieAst.RScoped (HsExpr.GuardLStmt a)), HieAst.ToHie (HieAst.RScoped (HsBinds.LHsLocalBinds a)), HieAst.ToHie (HieAst.TScoped (HsTypes.LHsWcType (HsExtension.NoGhcTc a))), HieAst.ToHie (HieAst.TScoped (HsTypes.LHsSigWcType (HsExtension.NoGhcTc a))), Data.Data.Data (HsExpr.HsExpr a), Data.Data.Data (HsExpr.HsSplice a), Data.Data.Data (HsExpr.HsTupArg a), Data.Data.Data (HsTypes.AmbiguousFieldOcc a)) => HieAst.ToHie (HsExpr.LHsExpr (HsExtension.GhcPass p))
- LlvmCodeGen: LlvmVersion :: Int -> LlvmVersion
- LlvmCodeGen: LlvmVersionOld :: Int -> Int -> LlvmVersion
- LlvmCodeGen.Base: LlvmVersion :: Int -> LlvmVersion
- LlvmCodeGen.Base: LlvmVersionOld :: Int -> Int -> LlvmVersion
- LlvmCodeGen.Base: instance GHC.Classes.Eq LlvmCodeGen.Base.LlvmVersion
- LlvmCodeGen.Base: instance GHC.Show.Show LlvmCodeGen.Base.LlvmVersion
- PprC: pprStringInCStyle :: ByteString -> SDoc
- PprC: writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
- SMRep: hALF_WORD_SIZE :: DynFlags -> ByteOff
- SMRep: hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
+ GHC: Opt_PrintAxiomIncomps :: GeneralFlag
+ GHC: modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
+ HieAst: instance (a Data.Type.Equality.~ HsExtension.GhcPass p, HieAst.ToHie (HieAst.Context (SrcLoc.Located (HsExtension.IdP a))), HieAst.HasType (HsExpr.LHsExpr a), HieAst.ToHie (HieAst.PScoped (HsPat.LPat a)), HieAst.ToHie (HsExpr.MatchGroup a (HsExpr.LHsExpr a)), HieAst.ToHie (HsExpr.LGRHS a (HsExpr.LHsExpr a)), HieAst.ToHie (HieAst.RContext (HsExpr.HsRecordBinds a)), HieAst.ToHie (HieAst.RFContext (SrcLoc.Located (HsTypes.AmbiguousFieldOcc a))), HieAst.ToHie (HsExpr.ArithSeqInfo a), HieAst.ToHie (HsExpr.LHsCmdTop a), HieAst.ToHie (HieAst.RScoped (HsExpr.GuardLStmt a)), HieAst.ToHie (HieAst.RScoped (HsBinds.LHsLocalBinds a)), HieAst.ToHie (HieAst.TScoped (HsTypes.LHsWcType (HsExtension.NoGhcTc a))), HieAst.ToHie (HieAst.TScoped (HsTypes.LHsSigWcType (HsExtension.NoGhcTc a))), Data.Data.Data (HsExpr.HsExpr a), Data.Data.Data (HsExpr.HsSplice a), Data.Data.Data (HsExpr.HsTupArg a), Data.Data.Data (HsTypes.AmbiguousFieldOcc a), HieAst.HasRealDataConName a) => HieAst.ToHie (HsExpr.LHsExpr (HsExtension.GhcPass p))
+ HieAst: instance HieAst.HasRealDataConName HsExtension.GhcRn
+ HieAst: instance HieAst.HasRealDataConName HsExtension.GhcTc
+ HieBin: hieNameOcc :: HieName -> OccName
+ LlvmCodeGen: llvmVersionList :: LlvmVersion -> [Int]
+ LlvmCodeGen.Base: llvmVersionList :: LlvmVersion -> [Int]
+ LlvmCodeGen.Base: llvmVersionSupported :: LlvmVersion -> Bool
+ LlvmCodeGen.Base: parseLlvmVersion :: String -> Maybe LlvmVersion
+ PprC: writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()
+ SMRep: halfWordSize :: DynFlags -> ByteOff
+ SMRep: halfWordSizeInBits :: DynFlags -> Int
+ Stream: collect_ :: Monad m => Stream m a r -> m ([a], r)
+ Stream: consume :: Monad m => Stream m a b -> (a -> m ()) -> m b
+ Stream: mapAccumL_ :: Monad m => (c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
- AsmCodeGen: nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply
+ AsmCodeGen: nativeCodeGen :: forall a. DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a
- CmmInfo: cmmToRawCmm :: DynFlags -> Stream IO CmmGroup () -> IO (Stream IO RawCmmGroup ())
+ CmmInfo: cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a -> IO (Stream IO RawCmmGroup a)
- CodeOutput: codeOutput :: DynFlags -> Module -> FilePath -> ModLocation -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> [InstalledUnitId] -> Stream IO RawCmmGroup () -> IO (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)])
+ CodeOutput: codeOutput :: DynFlags -> Module -> FilePath -> ModLocation -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> [InstalledUnitId] -> Stream IO RawCmmGroup a -> IO (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)
- DsMonad: foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
+ DsMonad: foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b
- DsMonad: foldrM :: Monad m => (b -> a -> m a) -> a -> [b] -> m a
+ DsMonad: foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
- HieDebug: diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
+ HieDebug: diffAst :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (HieAST a)
- HieDebug: diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (Map FastString (HieAST a))
+ HieDebug: diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (Map FastString (HieAST a))
- HieDebug: normalizeIdents :: NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
+ HieDebug: normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent, IdentifierDetails a)]
- HieDebug: validateScopes :: Map FastString (HieAST a) -> [SDoc]
+ HieDebug: validateScopes :: Module -> Map FastString (HieAST a) -> [SDoc]
- LlvmCodeGen: llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
+ LlvmCodeGen: llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a
- LlvmCodeGen.Base: runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
+ LlvmCodeGen.Base: runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM a -> IO a
Files
- compiler/cmm/CmmBuildInfoTables.hs +1/−3
- compiler/cmm/CmmCallConv.hs +1/−1
- compiler/cmm/CmmCommonBlockElim.hs +0/−1
- compiler/cmm/CmmInfo.hs +7/−6
- compiler/cmm/CmmLint.hs +1/−1
- compiler/cmm/CmmLive.hs +1/−1
- compiler/cmm/CmmProcPoint.hs +1/−1
- compiler/cmm/CmmSink.hs +0/−1
- compiler/cmm/CmmUtils.hs +2/−2
- compiler/cmm/Debug.hs +11/−15
- compiler/cmm/PprC.hs +4/−10
- compiler/cmm/PprCmm.hs +0/−2
- compiler/cmm/SMRep.hs +11/−11
- compiler/codeGen/StgCmmClosure.hs +10/−3
- compiler/codeGen/StgCmmPrim.hs +39/−11
- compiler/deSugar/Check.hs +20/−27
- compiler/deSugar/Coverage.hs +1/−1
- compiler/deSugar/DsArrows.hs +1/−2
- compiler/deSugar/DsBinds.hs +1/−1
- compiler/deSugar/DsExpr.hs +1/−1
- compiler/ghci/ByteCodeAsm.hs +5/−1
- compiler/ghci/ByteCodeGen.hs +104/−29
- compiler/ghci/ByteCodeInstr.hs +8/−2
- compiler/hieFile/HieAst.hs +24/−5
- compiler/hieFile/HieBin.hs +10/−1
- compiler/hieFile/HieDebug.hs +35/−10
- compiler/iface/FlagChecker.hs +0/−1
- compiler/iface/LoadIface.hs +2/−1
- compiler/iface/MkIface.hs +19/−21
- compiler/llvmGen/LlvmCodeGen.hs +22/−19
- compiler/llvmGen/LlvmCodeGen/Base.hs +31/−18
- compiler/main/CodeOutput.hs +23/−27
- compiler/main/DriverPipeline.hs +5/−5
- compiler/main/GHC.hs +4/−0
- compiler/main/HscMain.hs +8/−28
- compiler/main/StaticPtrTable.hs +4/−3
- compiler/main/SysTools/Tasks.hs +5/−13
- compiler/nativeGen/AsmCodeGen.hs +20/−20
- compiler/nativeGen/BlockLayout.hs +0/−4
- compiler/nativeGen/CFG.hs +1/−1
- compiler/nativeGen/Dwarf.hs +1/−1
- compiler/nativeGen/Dwarf/Types.hs +9/−12
- compiler/nativeGen/PPC/Instr.hs +1/−1
- compiler/nativeGen/PPC/Ppr.hs +1/−1
- compiler/nativeGen/RegAlloc/Graph/Main.hs +2/−2
- compiler/nativeGen/RegAlloc/Graph/Stats.hs +0/−1
- compiler/nativeGen/RegAlloc/Liveness.hs +0/−1
- compiler/nativeGen/SPARC/CodeGen.hs +0/−1
- compiler/nativeGen/SPARC/CodeGen/Base.hs +1/−1
- compiler/nativeGen/SPARC/CodeGen/Expand.hs +0/−1
- compiler/nativeGen/SPARC/CodeGen/Gen64.hs +1/−1
- compiler/nativeGen/SPARC/CodeGen/Sanity.hs +1/−1
- compiler/nativeGen/SPARC/Ppr.hs +1/−1
- compiler/nativeGen/X86/CodeGen.hs +0/−4
- compiler/rename/RnBinds.hs +2/−2
- compiler/rename/RnSource.hs +1/−1
- compiler/simplCore/FloatOut.hs +2/−2
- compiler/simplStg/UnariseStg.hs +2/−0
- compiler/specialise/Specialise.hs +8/−8
- compiler/stgSyn/CoreToStg.hs +13/−20
- compiler/stgSyn/StgSyn.hs +129/−156
- compiler/typecheck/TcClassDcl.hs +1/−1
- compiler/typecheck/TcFlatten.hs +4/−3
- compiler/typecheck/TcGenDeriv.hs +2/−2
- compiler/typecheck/TcHsSyn.hs +1/−1
- compiler/typecheck/TcInteract.hs +1/−1
- compiler/typecheck/TcRnDriver.hs +1/−1
- compiler/typecheck/TcSMonad.hs +4/−4
- compiler/typecheck/TcSigs.hs +1/−2
- compiler/typecheck/TcSimplify.hs +4/−5
- compiler/typecheck/TcTyClsDecls.hs +3/−2
- compiler/utils/Stream.hs +31/−2
- ghc-lib.cabal +2/−4
- ghc-lib/generated/ghcversion.h +1/−1
- ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs +0/−377
compiler/cmm/CmmBuildInfoTables.hs view
@@ -19,7 +19,6 @@ import GHC.Platform import Digraph import CLabel-import PprCmmDecl () import Cmm import CmmUtils import DynFlags@@ -30,7 +29,6 @@ import CostCentre import StgCmmHeap -import PprCmm() import Control.Monad import Data.Map (Map) import qualified Data.Map as Map@@ -729,7 +727,7 @@ -- important that we don't do this for static functions or CAFs, -- see Note [Invalid optimisation: shortcutting]. updateSRTMap srtEntry =- when (not isCAF && not isStaticFun) $ do+ when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls] put (Map.union newSRTMap srtMap)
compiler/cmm/CmmCallConv.hs view
@@ -10,7 +10,7 @@ import CmmExpr import SMRep import Cmm (Convention(..))-import PprCmm ()+import PprCmm () -- For Outputable instances import DynFlags import GHC.Platform
compiler/cmm/CmmCommonBlockElim.hs view
@@ -13,7 +13,6 @@ import CmmUtils import CmmSwitch (eqSwitchTargetWith) import CmmContFlowOpt--- import PprCmm () import Hoopl.Block import Hoopl.Graph
compiler/cmm/CmmInfo.hs view
@@ -67,16 +67,17 @@ , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()- -> IO (Stream IO RawCmmGroup ())+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a+ -> IO (Stream IO RawCmmGroup a) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i'- ; let do_one uniqs cmm =+ ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl])+ do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of (b,uniqs') -> return (uniqs',b)- ; return (Stream.mapAccumL do_one uniqs cmms >> return ())+ ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms) } where forceRes (uniqs, rawcmms) =@@ -577,7 +578,7 @@ stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize dflags stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word@@ -585,7 +586,7 @@ stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + halfWordSize dflags conInfoTableSizeB :: DynFlags -> Int conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
compiler/cmm/CmmLint.hs view
@@ -21,7 +21,7 @@ import CmmUtils import CmmLive import CmmSwitch (switchTargetsToList)-import PprCmm ()+import PprCmm () -- For Outputable instances import Outputable import DynFlags
compiler/cmm/CmmLive.hs view
@@ -17,7 +17,7 @@ import DynFlags import BlockId import Cmm-import PprCmmExpr ()+import PprCmmExpr () -- For Outputable instances import Hoopl.Block import Hoopl.Collections import Hoopl.Dataflow
compiler/cmm/CmmProcPoint.hs view
@@ -14,7 +14,7 @@ import BlockId import CLabel import Cmm-import PprCmm ()+import PprCmm () -- For Outputable instances import CmmUtils import CmmInfo import CmmLive
compiler/cmm/CmmSink.hs view
@@ -19,7 +19,6 @@ import DynFlags import Unique import UniqFM-import PprCmm () import qualified Data.IntSet as IntSet import Data.List (partition)
compiler/cmm/CmmUtils.hs view
@@ -227,8 +227,8 @@ -- but be careful: that's vulnerable when reversed packHalfWordsCLit dflags lower_half_word upper_half_word = if wORDS_BIGENDIAN dflags- then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)- else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))+ then mkWordCLit dflags ((l `shiftL` halfWordSizeInBits dflags) .|. u)+ else mkWordCLit dflags (l .|. (u `shiftL` halfWordSizeInBits dflags)) where l = fromStgHalfWord lower_half_word u = fromStgHalfWord upper_half_word
compiler/cmm/Debug.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- --@@ -11,7 +12,7 @@ module Debug ( - DebugBlock(..), dblIsEntry,+ DebugBlock(..), cmmDebugGen, cmmDebugLabels, cmmDebugLink,@@ -32,7 +33,6 @@ import FastString ( nilFS, mkFastString ) import Module import Outputable-import PprCore () import PprCmmExpr ( pprExpr ) import SrcLoc import Util ( seqList )@@ -59,8 +59,7 @@ , dblParent :: !(Maybe DebugBlock) -- ^ The parent of this proc. See Note [Splitting DebugBlocks] , dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block- , dblSourceTick- :: !(Maybe CmmTickish) -- ^ Best source tick covering block+ , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block , dblPosition :: !(Maybe Int) -- ^ Output position relative to -- other blocks. @Nothing@ means -- the block was optimized out@@ -68,22 +67,19 @@ , dblBlocks :: ![DebugBlock] -- ^ Nested blocks } --- | Is this the entry block?-dblIsEntry :: DebugBlock -> Bool-dblIsEntry blk = dblProcedure blk == dblLabel blk- instance Outputable DebugBlock where- ppr blk = (if dblProcedure blk == dblLabel blk- then text "proc "- else if dblHasInfoTbl blk- then text "pp-blk "- else text "blk ") <>+ ppr blk = (if | dblProcedure blk == dblLabel blk+ -> text "proc"+ | dblHasInfoTbl blk+ -> text "pp-blk"+ | otherwise+ -> text "blk") <+> ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+> (maybe empty ppr (dblSourceTick blk)) <+> (maybe (text "removed") ((text "pos " <>) . ppr) (dblPosition blk)) <+>- (ppr (dblUnwind blk)) <+>- (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))+ (ppr (dblUnwind blk)) $+$+ (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk))) -- | Intermediate data structure holding debug-relevant context information -- about a block.
compiler/cmm/PprC.hs view
@@ -19,8 +19,7 @@ ----------------------------------------------------------------------------- module PprC (- writeCs,- pprStringInCStyle+ writeC ) where #include "HsVersions.h"@@ -32,7 +31,7 @@ import CLabel import ForeignCall import Cmm hiding (pprBBlock)-import PprCmm ()+import PprCmm () -- For Outputable instances import Hoopl.Block import Hoopl.Collections import Hoopl.Graph@@ -68,13 +67,8 @@ -- -------------------------------------------------------------------------- -- Top level -pprCs :: [RawCmmGroup] -> SDoc-pprCs cmms- = pprCode CStyle (vcat $ map pprC cmms)--writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()-writeCs dflags handle cmms- = printForC dflags handle (pprCs cmms)+writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()+writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine) -- -------------------------------------------------------------------------- -- Now do some real work
compiler/cmm/PprCmm.hs view
@@ -41,7 +41,6 @@ import GhcPrelude hiding (succ) -import BlockId () import CLabel import Cmm import CmmUtils@@ -52,7 +51,6 @@ import PprCmmDecl import PprCmmExpr import Util-import PprCore () import BasicTypes import Hoopl.Block
compiler/cmm/SMRep.hs view
@@ -13,7 +13,7 @@ StgWord, fromStgWord, toStgWord, StgHalfWord, fromStgHalfWord, toStgHalfWord,- hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,+ halfWordSize, halfWordSizeInBits, -- * Closure repesentation SMRep(..), -- CmmInfo sees the rep; no one else does@@ -107,9 +107,8 @@ = case platformWordSize (targetPlatform dflags) of -- These conversions mean that things like toStgWord (-1) -- do the right thing- 4 -> StgWord (fromIntegral (fromInteger i :: Word32))- 8 -> StgWord (fromInteger i :: Word64)- w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)+ PW4 -> StgWord (fromIntegral (fromInteger i :: Word32))+ PW8 -> StgWord (fromInteger i) instance Outputable StgWord where ppr (StgWord i) = integer (toInteger i)@@ -129,17 +128,18 @@ = case platformWordSize (targetPlatform dflags) of -- These conversions mean that things like toStgHalfWord (-1) -- do the right thing- 4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))- 8 -> StgHalfWord (fromInteger i :: Word32)- w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)+ PW4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))+ PW8 -> StgHalfWord (fromInteger i :: Word32) instance Outputable StgHalfWord where ppr (StgHalfWord w) = integer (toInteger w) -hALF_WORD_SIZE :: DynFlags -> ByteOff-hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1-hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int-hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2+-- | Half word size in bytes+halfWordSize :: DynFlags -> ByteOff+halfWordSize dflags = platformWordSizeInBytes (targetPlatform dflags) `div` 2++halfWordSizeInBits :: DynFlags -> Int+halfWordSizeInBits dflags = platformWordSizeInBits (targetPlatform dflags) `div` 2 {- ************************************************************************
compiler/codeGen/StgCmmClosure.hs view
@@ -71,7 +71,7 @@ import StgSyn import SMRep import Cmm-import PprCmmExpr()+import PprCmmExpr() -- For Outputable instances import CostCentre import BlockId@@ -166,20 +166,27 @@ -- Why are these here? +-- | Assumes that there is precisely one 'PrimRep' of the type. This assumption+-- holds after unarise.+-- See Note [Post-unarisation invariants] idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep1 (idType id)- -- NB: typePrimRep1 fails on unboxed tuples,- -- but by StgCmm no Ids have unboxed tuple type -- See also Note [VoidRep] in RepType +-- | Assumes that Ids have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants] addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id in NonVoid (idPrimRep id', id')) +-- | Assumes that arguments have one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants] addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg in NonVoid (argPrimRep arg', arg')) +-- | Assumes that the argument has one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants] argPrimRep :: StgArg -> PrimRep argPrimRep arg = typePrimRep1 (stgArgType arg)
compiler/codeGen/StgCmmPrim.hs view
@@ -46,6 +46,7 @@ import FastString import Outputable import Util+import Data.Maybe import Data.Bits ((.&.), bit) import Control.Monad (liftM, when, unless)@@ -872,43 +873,65 @@ emit stmt emitPrimOp dflags results op args- = case callishPrimOpSupported dflags op of+ = case callishPrimOpSupported dflags op args of Left op -> emit $ mkUnsafeCall (PrimTarget op) results args Right gen -> gen results args +-- Note [QuotRem optimization]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+-- (shift, .&.).+--+-- Currently we only support optimization (performed in CmmOpt) when the+-- constant is a power of 2. #9041 tracks the implementation of the general+-- optimization.+--+-- `quotRem` can be optimized in the same way. However as it returns two values,+-- it is implemented as a "callish" primop which is harder to match and+-- to transform later on. For simplicity, the current implementation detects cases+-- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+-- primop into two CMM quot and rem primops.+ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () -callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp-callishPrimOpSupported dflags op+callishPrimOpSupported :: DynFlags -> PrimOp -> [CmmExpr] -> Either CallishMachOp GenericOp+callishPrimOpSupported dflags op args = case op of- IntQuotRemOp | ncg && (x86ish || ppc) ->- Left (MO_S_QuotRem (wordWidth dflags))- | otherwise ->- Right (genericIntQuotRemOp (wordWidth dflags))+ IntQuotRemOp | ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized+ -> Left (MO_S_QuotRem (wordWidth dflags))+ | otherwise+ -> Right (genericIntQuotRemOp (wordWidth dflags)) Int8QuotRemOp | ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized -> Left (MO_S_QuotRem W8) | otherwise -> Right (genericIntQuotRemOp W8) Int16QuotRemOp | ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized -> Left (MO_S_QuotRem W16) | otherwise -> Right (genericIntQuotRemOp W16) - WordQuotRemOp | ncg && (x86ish || ppc) ->- Left (MO_U_QuotRem (wordWidth dflags))- | otherwise ->- Right (genericWordQuotRemOp (wordWidth dflags))+ WordQuotRemOp | ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized+ -> Left (MO_U_QuotRem (wordWidth dflags))+ | otherwise+ -> Right (genericWordQuotRemOp (wordWidth dflags)) WordQuotRem2Op | (ncg && (x86ish || ppc)) || llvm -> Left (MO_U_QuotRem2 (wordWidth dflags)) | otherwise -> Right (genericWordQuotRem2Op dflags) Word8QuotRemOp | ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized -> Left (MO_U_QuotRem W8) | otherwise -> Right (genericWordQuotRemOp W8) Word16QuotRemOp| ncg && (x86ish || ppc)+ , not quotRemCanBeOptimized -> Left (MO_U_QuotRem W16) | otherwise -> Right (genericWordQuotRemOp W16) @@ -944,6 +967,11 @@ _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op) where+ -- See Note [QuotRem optimization]+ quotRemCanBeOptimized = case args of+ [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+ _ -> False+ ncg = case hscTarget dflags of HscAsm -> True _ -> False
compiler/deSugar/Check.hs view
@@ -56,7 +56,6 @@ import Type import UniqSupply import DsUtils (isTrueLHsExpr)-import Maybes (expectJust) import qualified GHC.LanguageExtensions as LangExt import Data.List (find)@@ -853,7 +852,7 @@ alts_to_check :: Type -> Type -> [DataCon] -> PmM (Either Type (TyCon, [InhabitationCandidate])) alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of- Just (tc, _)+ Just (tc, tc_args) | tc `elem` trivially_inhabited -> case dcs of [] -> return (Left src_ty)@@ -869,7 +868,7 @@ -- them extremely misleading. -> liftD $ do var <- mkPmId core_ty -- it would be wrong to unify x- alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)+ alts <- mapM (mkOneConFull var tc_args . RealDataCon) (tyConDataCons tc) return $ Right (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs} | alt <- alts ])@@ -1616,37 +1615,31 @@ -- | Generate an 'InhabitationCandidate' for a given conlike (generate -- fresh variables of the appropriate type for arguments)-mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate--- * x :: T tys, where T is an algebraic data type--- NB: in the case of a data family, T is the *representation* TyCon--- e.g. data instance T (a,b) = T1 a b--- leads to--- data TPair a b = T1 a b -- The "representation" type--- It is TPair, not T, that is given to mkOneConFull+mkOneConFull :: Id -> [Type] -> ConLike -> DsM InhabitationCandidate+-- * 'con' K is a conlike of algebraic data type 'T tys'++-- * 'tc_args' are the type arguments of the 'con's TyCon T ----- * 'con' K is a conlike of data type T+-- * 'x' is the variable for which we encode an equality constraint+-- in the term oracle ----- After instantiating the universal tyvars of K we get--- K tys :: forall bs. Q => s1 .. sn -> T tys+-- After instantiating the universal tyvars of K to tc_args we get+-- K @tys :: forall bs. Q => s1 .. sn -> T tys -- -- Suppose y1 is a strict field. Then we get -- Results: ic_val_abs: K (y1::s1) .. (yn::sn) -- ic_tm_ct: x ~ K y1..yn -- ic_ty_cs: Q -- ic_strict_arg_tys: [s1]-mkOneConFull x con = do- let res_ty = idType x- (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)+mkOneConFull x tc_args con = do+ let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _con_res_ty) = conLikeFullSig con arg_is_banged = map isBanged $ conLikeImplBangs con- tc_args = tyConAppArgs res_ty- subst1 = case con of- RealDataCon {} -> zipTvSubst univ_tvs tc_args- PatSynCon {} -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)- -- See Note [Pattern synonym result type] in PatSyn+ subst1 = zipTvSubst univ_tvs tc_args (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM + -- Field types let arg_tys' = substTys subst arg_tys -- Fresh term variables (VAs) as arguments to the constructor arguments <- mapM mkPmVar arg_tys'@@ -2094,7 +2087,7 @@ (PmVar x) (ValVec vva delta) = do (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys) - cons_cs <- mapM (liftD . mkOneConFull x) complete_match+ cons_cs <- mapM (liftD . mkOneConFull x tys) complete_match inst_vsa <- flip mapMaybeM cons_cs $ \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct@@ -2201,11 +2194,11 @@ u_1, ..., u_p are the universally quantified type variables. In the ConVar case, the coverage algorithm will have in hand the constructor-K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p-are some types that instantiate u_1, ... u_p. The idea is that we should-substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the-mkOneConFull function accomplishes this) and then hand this PmCon off to the-ConCon case.+K as well as a list of type arguments [t_1, ..., t_n] to substitute T's+universally quantified type variables u_1, ..., u_n for. It's crucial to take+these in as arguments, as it is non-trivial to derive them just from the result+type of a pattern synonym and the ambient type of the match (#11336, #17112).+The type checker already did the hard work, so we should just make use of it. The presence of existentially quantified type variables adds a significant wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,
compiler/deSugar/Coverage.hs view
@@ -121,7 +121,7 @@ guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead.- let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->+ let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of
compiler/deSugar/DsArrows.hs view
@@ -50,7 +50,6 @@ import BasicTypes import PrelNames import Outputable-import Bag import VarSet import SrcLoc import ListSetOps( assocMaybe )@@ -1251,7 +1250,7 @@ go p@(XPat {}) = pprPanic "collectl/go" (ppr p) collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs+collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" add_ev_bndr :: EvBind -> [Id] -> [Id]
compiler/deSugar/DsBinds.hs view
@@ -1164,7 +1164,7 @@ = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) where edges :: [ Node EvVar (EvVar,CoreExpr) ]- edges = foldrBag ((:) . mk_node) [] ds_binds+ edges = foldr ((:) . mk_node) [] ds_binds mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) mk_node b@(var, rhs)
compiler/deSugar/DsExpr.hs view
@@ -187,7 +187,7 @@ , abs_binds = lbinds }) body = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b- ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)+ ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) body1 lbinds ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) }
compiler/ghci/ByteCodeAsm.hs view
@@ -156,7 +156,11 @@ return ubco' assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO-assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do+assembleBCO dflags (ProtoBCO { protoBCOName = nm+ , protoBCOInstrs = instrs+ , protoBCOBitmap = bitmap+ , protoBCOBitmapSize = bsize+ , protoBCOArity = arity }) = do -- pass 1: collect up the offsets of the local labels. let asm = mapM_ (assembleI dflags) instrs
compiler/ghci/ByteCodeGen.hs view
@@ -27,6 +27,7 @@ import Name import MkId import Id+import Var ( updateVarType ) import ForeignCall import HscTypes import CoreUtils@@ -62,7 +63,6 @@ import UniqSupply import Module-import Control.Arrow ( second ) import Control.Exception import Data.Array@@ -91,7 +91,7 @@ (const ()) $ do -- Split top-level binds into strings and others. -- See Note [generating code for top-level string literal bindings].- let (strings, flatBinds) = partitionEithers $ do+ let (strings, flatBinds) = partitionEithers $ do -- list monad (bndr, rhs) <- flattenBinds binds return $ case exprIsTickedString_maybe rhs of Just str -> Left (bndr, str)@@ -182,29 +182,13 @@ where dflags = hsc_dflags hsc_env -- The regular freeVars function gives more information than is useful to--- us here. simpleFreeVars does the impedance matching.+-- us here. We need only the free variables, not everything in an FVAnn.+-- Historical note: At one point FVAnn was more sophisticated than just+-- a set. Now it isn't. So this function is much simpler. Keeping it around+-- so that if someone changes FVAnn, they will get a nice type error right+-- here. simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet-simpleFreeVars = go . freeVars- where- go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet- go (ann, e) = (freeVarsOfAnn ann, go' e)-- go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet- go' (AnnVar id) = AnnVar id- go' (AnnLit lit) = AnnLit lit- go' (AnnLam bndr body) = AnnLam bndr (go body)- go' (AnnApp fun arg) = AnnApp (go fun) (go arg)- go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)- go' (AnnLet bind body) = AnnLet (go_bind bind) (go body)- go' (AnnCast expr (ann, co)) = AnnCast (go expr) (freeVarsOfAnn ann, co)- go' (AnnTick tick body) = AnnTick tick (go body)- go' (AnnType ty) = AnnType ty- go' (AnnCoercion co) = AnnCoercion co-- go_alt (con, args, expr) = (con, args, go expr)-- go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)- go_bind (AnnRec pairs) = AnnRec (map (second go) pairs)+simpleFreeVars = freeVars -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator@@ -257,6 +241,7 @@ -> name -> BCInstrList -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)+ -- ^ original expression; for debugging only -> Int -> Word16 -> [StgWord]@@ -369,6 +354,9 @@ -} = schemeR_wrk fvs nm rhs (collect rhs) +-- If an expression is a lambda (after apply bcView), return the+-- list of arguments to the lambda (in R-to-L order) and the+-- underlying expression collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) collect (_, e) = go [] e where@@ -383,8 +371,8 @@ schemeR_wrk :: [Id] -> Id- -> AnnExpr Id DVarSet- -> ([Var], AnnExpr' Var DVarSet)+ -> AnnExpr Id DVarSet -- expression e, for debugging only+ -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = do@@ -509,6 +497,8 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V schemeE d s p e@(AnnVar v)+ -- See Note [Not-necessarily-lifted join points], step 3.+ | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId] | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) | otherwise = schemeT d s p e @@ -535,19 +525,22 @@ fvss = map (fvsToEnv p' . fst) rhss + -- See Note [Not-necessarily-lifted join points], step 2.+ (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss+ -- Sizes of free vars size_w = trunc16W . idSizeW dflags sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss -- the arity of each rhs- arities = map (genericLength . fst . collect) rhss+ arities = map (genericLength . fst . collect) rhss' -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1 word. d' and p' reflect the stack -- after the closures have been allocated in the heap (but not -- filled in), and pointers to them parked on the stack. offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))- p' = Map.insertList (zipE xs offsets) p+ p' = Map.insertList (zipE xs' offsets) p d' = d + wordsToBytes dflags n_binds zipE = zipEqual "schemeE" @@ -588,7 +581,7 @@ compile_binds = [ compile_bind d' fvs x rhs size arity (trunc16W n) | (fvs, x, rhs, size, arity, n) <-- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]+ zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1] ] body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds@@ -682,6 +675,30 @@ = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' expr)) +-- Is this Id a not-necessarily-lifted join point?+-- See Note [Not-necessarily-lifted join points], step 1+isNNLJoinPoint :: Id -> Bool+isNNLJoinPoint x = isJoinId x &&+ Just True /= isLiftedType_maybe (idType x)++-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.+-- See Note [Not-necessarily-lifted join points], step 2.+protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)+protectNNLJoinPointBind x rhs@(fvs, _)+ | isNNLJoinPoint x+ = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))++ | otherwise+ = (x, rhs)++-- Update an Id's type to take a Void# argument.+-- Precondition: the Id is a not-necessarily-lifted join point.+-- See Note [Not-necessarily-lifted join points]+protectNNLJoinPointId :: Id -> Id+protectNNLJoinPointId x+ = ASSERT( isNNLJoinPoint x )+ updateVarType (voidPrimTy `mkVisFunTy`) x+ {- Ticked Expressions ------------------@@ -689,6 +706,64 @@ The idea is that the "breakpoint<n,fvs> E" is really just an annotation on the code. When we find such a thing, we pull out the useful information, and then compile the code as if it was just the expression E.++Note [Not-necessarily-lifted join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point variable is essentially a goto-label: it is, for example,+never used as an argument to another function, and it is called only+in tail position. See Note [Join points] and Note [Invariants on join points],+both in CoreSyn. Because join points do not compile to true, red-blooded+variables (with, e.g., registers allocated to them), they are allowed+to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]+in CoreSyn.)++However, in this byte-code generator, join points *are* treated just as+ordinary variables. There is no check whether a binding is for a join point+or not; they are all treated uniformly. (Perhaps there is a missed optimization+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)++We thus must have *some* strategy for dealing with levity-polymorphic and+unlifted join points. Levity-polymorphic variables are generally not allowed+(though levity-polymorphic join points *are*; see Note [Invariants on join points]+in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly.+The questionable join points are *not-necessarily-lifted join points*+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:++1. Detect NNLJPs. This is done in isNNLJoinPoint.++2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the+ type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)+ Note that functions are never levity-polymorphic, so this transformation+ changes an NNLJP to a non-levity-polymorphic join point. This is done+ in protectNNLJoinPointBind, called from the AnnLet case of schemeE.++3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),+ being careful to note the new type of the NNLJP. This is done in the AnnVar+ case of schemeE, with help from protectNNLJoinPointId.++Here is an example. Suppose we have++ f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+ join j :: a+ j = error @r @a "bloop"+ in case x of+ A -> j+ B -> j+ C -> error @r @a "blurp"++Our plan is to behave is if the code was++ f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+ let j :: (Void# -> a)+ j = \ _ -> error @r @a "bloop"+ in case x of+ A -> j void#+ B -> j void#+ C -> error @r @a "blurp"++It's a bit hacky, but it works well in practice and is local. I suspect the+Right Fix is to take advantage of join points as goto-labels. -}
compiler/ghci/ByteCodeInstr.hs view
@@ -45,7 +45,7 @@ protoBCOBitmap :: [StgWord], protoBCOBitmapSize :: Word16, protoBCOArity :: Int,- -- what the BCO came from+ -- what the BCO came from, for debugging only protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet), -- malloc'd pointers protoBCOFFIs :: [FFIInfo]@@ -179,7 +179,13 @@ -- Printing bytecode instructions instance Outputable a => Outputable (ProtoBCO a) where- ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)+ ppr (ProtoBCO { protoBCOName = name+ , protoBCOInstrs = instrs+ , protoBCOBitmap = bitmap+ , protoBCOBitmapSize = bsize+ , protoBCOArity = arity+ , protoBCOExpr = origin+ , protoBCOFFIs = ffis }) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity <+> text (show ffis) <> colon) $$ nest 3 (case origin of
compiler/hieFile/HieAst.hs view
@@ -38,6 +38,7 @@ import Var ( Id, Var, setVarName, varName, varType ) import TcRnTypes import MkIface ( mkIfaceExports )+import Panic import HieTypes import HieUtils@@ -161,7 +162,7 @@ grhss_span :: GRHSs p body -> SrcSpan grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)-grhss_span (XGRHSs _) = error "XGRHS has no span"+grhss_span (XGRHSs _) = panic "XGRHS has no span" bindingsOnly :: [Context Name] -> [HieAST a] bindingsOnly [] = []@@ -245,7 +246,7 @@ -> [LPat (GhcPass p)] -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs =- map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $+ map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ listScopes patScope (map dL xs) -- | 'listScopes' specialised to 'TVScoped' things@@ -300,7 +301,8 @@ instance ProtectSig GhcRn where protectSig sc (HsWC a (HsIB b sig)) = HsWC a (HsIB b (SH sc sig))- protectSig _ _ = error "protectSig not given HsWC (HsIB)"+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec class HasLoc a where -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can@@ -351,6 +353,21 @@ instance HasLoc (Pat (GhcPass a)) where loc (dL -> L l _) = l +{- Note [Real DataCon Name]+The typechecker subtitutes the conLikeWrapId for the name, but we don't want+this showing up in the hieFile, so we replace the name in the Id with the+original datacon name+See also Note [Data Constructor Naming]+-}+class HasRealDataConName p where+ getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)++instance HasRealDataConName GhcRn where+ getRealDataCon _ n = n+instance HasRealDataConName GhcTc where+ getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =+ L sp (setVarName var (conLikeName con))+ -- | The main worker class class ToHie a where toHie :: a -> HieM [HieAST Type]@@ -737,6 +754,7 @@ , Data (HsSplice a) , Data (HsTupArg a) , Data (AmbiguousFieldOcc a)+ , (HasRealDataConName a) ) => ToHie (LHsExpr (GhcPass p)) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) ->@@ -817,8 +835,9 @@ ExplicitList _ _ exprs -> [ toHie exprs ]- RecordCon {rcon_con_name = name, rcon_flds = binds}->- [ toHie $ C Use name+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->+ [ toHie $ C Use (getRealDataCon @a mrealcon name)+ -- See Note [Real DataCon Name] , toHie $ RC RecFieldAssign $ binds ] RecordUpd {rupd_expr = expr, rupd_flds = upds}->
compiler/hieFile/HieBin.hs view
@@ -2,7 +2,7 @@ Binary serialization for .hie files. -} {-# LANGUAGE ScopedTypeVariables #-}-module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where import GHC.Settings ( maybeRead ) @@ -58,6 +58,15 @@ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+ case lookupKnownKeyName u of+ Just n -> nameOccName n+ Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+ (ppr (unpkUnique u)) data HieSymbolTable = HieSymbolTable
compiler/hieFile/HieDebug.hs view
@@ -16,6 +16,7 @@ import HieTypes import HieBin import HieUtils+import Name import qualified Data.Map as M import qualified Data.Set as S@@ -56,20 +57,30 @@ diffFile :: Diff HieFile diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) -diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) diffAsts f = diffList (diffAst f) `on` M.elems -diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)+diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 where spanDiff | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] | otherwise = []- infoDiff+ infoDiff' = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 ++ (diffList diffType `on` nodeType) info1 info2 ++ (diffIdents `on` nodeIdentifiers) info1 info2+ infoDiff = case infoDiff' of+ [] -> []+ xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)+ , "and", ppr (nodeIdentifiers info2,span2)+ , "While comparing"+ , ppr (normalizeIdents $ nodeIdentifiers info1), "and"+ , ppr (normalizeIdents $ nodeIdentifiers info2)+ ]+ ]+ diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b diffIdent (a,b) (c,d) = diffName a c ++ eqDiff b d@@ -81,10 +92,11 @@ type DiffIdent = Either ModuleName HieName -normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]-normalizeIdents = sortOn fst . map (first toHieName) . M.toList+normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn go . map (first toHieName) . M.toList where first f (a,b) = (fmap f a, b)+ go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) diffList :: Diff a -> Diff [a] diffList f xs ys@@ -122,10 +134,14 @@ -- | Look for any identifiers which occur outside of their supposed scopes. -- Returns a list of error messages.-validateScopes :: M.Map FastString (HieAST a) -> [SDoc]-validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]+validateScopes mod asts = validScopes where refMap = generateReferencesMap asts+ -- We use a refmap for most of the computation++ -- Check if all the names occur in their calculated scopes+ validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap valid (Left _) _ = [] valid (Right n) refs = concatMap inScope refs where@@ -134,13 +150,22 @@ Just xs -> xs Nothing -> [] inScope (sp, dets)- | definedInAsts asts n+ | (definedInAsts asts n) && any isOccurrence (identInfo dets)+ -- We validate scopes for names which are defined locally, and occur+ -- in this span = case scopes of- [] -> []+ [] | (nameIsLocalOrFrom mod n+ && not (isDerivedOccName $ nameOccName n))+ -- If we don't get any scopes for a local name then its an error.+ -- We can ignore derived names.+ -> return $ hsep $+ [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp+ , "Doesn't have a calculated scope: ", ppr scopes]+ | otherwise -> [] _ -> if any (`scopeContainsSpan` sp) scopes then [] else return $ hsep $- [ "Name", ppr n, "at position", ppr sp+ [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp , "doesn't occur in calculated scope", ppr scopes] | otherwise = []
compiler/iface/FlagChecker.hs view
@@ -11,7 +11,6 @@ import GhcPrelude import Binary-import BinIface () import DynFlags import HscTypes import Module
compiler/iface/LoadIface.hs view
@@ -399,7 +399,8 @@ -- Redo search for our local hole module loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from | otherwise- = do { -- Read the state+ = withTiming getDynFlags (text "loading interface") (pure ()) $+ do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv
compiler/iface/MkIface.hs view
@@ -1804,33 +1804,30 @@ where branch_list = fromBranches branches --- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches--- to incompatible indices+-- 2nd parameter is the list of branch LHSs, in case of a closed type family,+-- for conversion from incompatible branches to incompatible indices.+-- For an open type family the list should be empty. -- See Note [Storing compatibility] in CoAxiom coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch coAxBranchToIfaceBranch tc lhs_s- branch@(CoAxBranch { cab_incomps = incomps })- = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }+ (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+ , cab_eta_tvs = eta_tvs+ , cab_lhs = lhs, cab_roles = roles+ , cab_rhs = rhs, cab_incomps = incomps })++ = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs+ , ifaxbCoVars = map toIfaceIdBndr cvs+ , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+ , ifaxbLHS = toIfaceTcArgs tc lhs+ , ifaxbRoles = roles+ , ifaxbRHS = toIfaceType rhs+ , ifaxbIncomps = iface_incomps } where iface_incomps = map (expectJust "iface_incomps"- . (flip findIndex lhs_s- . eqTypes)+ . flip findIndex lhs_s+ . eqTypes . coAxBranchLHS) incomps --- use this one for standalone branches without incompatibles-coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch-coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs- , cab_eta_tvs = eta_tvs- , cab_lhs = lhs- , cab_roles = roles, cab_rhs = rhs })- = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs- , ifaxbCoVars = map toIfaceIdBndr cvs- , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs- , ifaxbLHS = toIfaceTcArgs tc lhs- , ifaxbRoles = roles- , ifaxbRHS = toIfaceType rhs- , ifaxbIncomps = [] }- ----------------- tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) -- We *do* tidy TyCons, because they are not (and cannot@@ -1911,7 +1908,8 @@ to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) where defs = fromBranches $ coAxiomBranches ax- ibr = map (coAxBranchToIfaceBranch' tycon) defs+ lhss = map coAxBranchLHS defs+ ibr = map (coAxBranchToIfaceBranch tycon lhss) defs axn = coAxiomName ax ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
compiler/llvmGen/LlvmCodeGen.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-} -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. ---module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where+module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" @@ -34,7 +34,7 @@ import SysTools ( figureLlvmVersion ) import qualified Stream -import Control.Monad ( when )+import Control.Monad ( when, forM_ ) import Data.Maybe ( fromMaybe, catMaybes ) import System.IO @@ -42,8 +42,8 @@ -- | Top-level of the LLVM Code generator -- llvmCodeGen :: DynFlags -> Handle -> UniqSupply- -> Stream.Stream IO RawCmmGroup ()- -> IO ()+ -> Stream.Stream IO RawCmmGroup a+ -> IO a llvmCodeGen dflags h us cmm_stream = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h@@ -52,26 +52,28 @@ showPass dflags "LLVM CodeGen" -- get llvm version, cache for later use- ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags+ mb_ver <- figureLlvmVersion dflags -- warn if unsupported- debugTraceMsg dflags 2- (text "Using LLVM version:" <+> text (show ver))- let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags- when (ver /= supportedLlvmVersion && doWarn) $- putMsg dflags (text "You are using an unsupported version of LLVM!"- $+$ text ("Currently only " ++- llvmVersionStr supportedLlvmVersion ++- " is supported.")- $+$ text "We will try though...")+ forM_ mb_ver $ \ver -> do+ debugTraceMsg dflags 2+ (text "Using LLVM version:" <+> text (llvmVersionStr ver))+ let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+ when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $+ "You are using an unsupported version of LLVM!" $$+ "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>+ "System LLVM version: " <> text (llvmVersionStr ver) $$+ "We will try though..." -- run code generation- runLlvm dflags ver bufh us $+ a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $ llvmCodeGen' (liftStream cmm_stream) bFlush bufh -llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()+ return a++llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a llvmCodeGen' cmm_stream = do -- Preamble renderLlvm header@@ -79,14 +81,15 @@ cmmMetaLlvmPrelude -- Procedures- let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream- _ <- Stream.collect llvmStream+ a <- Stream.consume cmm_stream llvmGroupLlvmGens -- Declare aliases for forward references renderLlvm . pprLlvmData =<< generateExternDecls -- Postamble cmmUsedLlvmGens++ return a where header :: SDoc header = sdocWithDynFlags $ \dflags ->
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -13,7 +13,8 @@ LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion (..), supportedLlvmVersion, llvmVersionStr,+ LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,+ llvmVersionStr, llvmVersionList, LlvmM, runLlvm, liftStream, withClearVars, varLookup, varInsert,@@ -60,6 +61,9 @@ import Data.Maybe (fromJust) import Control.Monad (ap)+import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE -- ---------------------------------------------------------------------------- -- * Some Data Types@@ -176,27 +180,36 @@ -- * Llvm Version -- --- | LLVM Version Number-data LlvmVersion- = LlvmVersion Int- | LlvmVersionOld Int Int- deriving Eq+-- Newtype to avoid using the Eq instance!+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } --- Custom show instance for backwards compatibility.-instance Show LlvmVersion where- show (LlvmVersion maj) = show maj- show (LlvmVersionOld maj min) = show maj ++ "." ++ show min+parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+ fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+ where+ go vs s+ | null ver_str+ = reverse vs+ | '.' : rest' <- rest+ = go (read ver_str : vs) rest'+ | otherwise+ = reverse (read ver_str : vs)+ where+ (ver_str, rest) = span isDigit s -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION+supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| []) +llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION+ llvmVersionStr :: LlvmVersion -> String-llvmVersionStr v =- case v of- LlvmVersion maj -> show maj- LlvmVersionOld maj min -> show maj ++ "." ++ show min+llvmVersionStr = intercalate "." . map show . llvmVersionList +llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE+ -- ---------------------------------------------------------------------------- -- * Environment Handling --@@ -253,10 +266,10 @@ return (x, env) -- | Get initial Llvm environment.-runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM a -> IO a runLlvm dflags ver out us m = do- _ <- runLlvmM m env- return ()+ (a, _) <- runLlvmM m env+ return a where env = LlvmEnv { envFunMap = emptyUFM , envVarMap = emptyUFM , envStackRegs = []
compiler/main/CodeOutput.hs view
@@ -12,19 +12,19 @@ import GhcPrelude -import AsmCodeGen ( nativeCodeGen )-import LlvmCodeGen ( llvmCodeGen )+import AsmCodeGen ( nativeCodeGen )+import LlvmCodeGen ( llvmCodeGen ) import UniqSupply ( mkSplitUniqSupply ) import Finder ( mkStubPaths )-import PprC ( writeCs )+import PprC ( writeC ) import CmmLint ( cmmLint ) import Packages import Cmm ( RawCmmGroup ) import HscTypes import DynFlags-import Stream (Stream)+import Stream ( Stream ) import qualified Stream import FileCleanup @@ -54,10 +54,11 @@ -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with with the C compiler -> [InstalledUnitId]- -> Stream IO RawCmmGroup () -- Compiled C--+ -> Stream IO RawCmmGroup a -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),- [(ForeignSrcLang, FilePath)]{-foreign_fps-})+ [(ForeignSrcLang, FilePath)]{-foreign_fps-},+ a) codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps cmm_stream@@ -87,15 +88,14 @@ } ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs- ; case hscTarget dflags of {- HscAsm -> outputAsm dflags this_mod location filenm- linted_cmm_stream;- HscC -> outputC dflags filenm linted_cmm_stream pkg_deps;- HscLlvm -> outputLlvm dflags filenm linted_cmm_stream;- HscInterpreted -> panic "codeOutput: HscInterpreted";- HscNothing -> panic "codeOutput: HscNothing"- }- ; return (filenm, stubs_exist, foreign_fps)+ ; a <- case hscTarget dflags of+ HscAsm -> outputAsm dflags this_mod location filenm+ linted_cmm_stream+ HscC -> outputC dflags filenm linted_cmm_stream pkg_deps+ HscLlvm -> outputLlvm dflags filenm linted_cmm_stream+ HscInterpreted -> panic "codeOutput: HscInterpreted"+ HscNothing -> panic "codeOutput: HscNothing"+ ; return (filenm, stubs_exist, foreign_fps, a) } doOutput :: String -> (Handle -> IO a) -> IO a@@ -111,16 +111,13 @@ outputC :: DynFlags -> FilePath- -> Stream IO RawCmmGroup ()+ -> Stream IO RawCmmGroup a -> [InstalledUnitId]- -> IO ()+ -> IO a outputC dflags filenm cmm_stream packages = do- -- ToDo: make the C backend consume the C-- incrementally, by- -- pushing the cmm_stream inside (c.f. nativeCodeGen)- rawcmms <- Stream.collect cmm_stream- withTiming (return dflags) (text "C codegen") id $ do+ withTiming (return dflags) (text "C codegen") (\a -> seq a () {- FIXME -}) $ do -- figure out which header files to #include in the generated .hc file: --@@ -142,7 +139,7 @@ doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects- writeCs dflags h rawcmms+ Stream.consume cmm_stream (writeC dflags h) {- ************************************************************************@@ -153,18 +150,17 @@ -} outputAsm :: DynFlags -> Module -> ModLocation -> FilePath- -> Stream IO RawCmmGroup ()- -> IO ()+ -> Stream IO RawCmmGroup a+ -> IO a outputAsm dflags this_mod location filenm cmm_stream | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags = do ncg_uniqs <- mkSplitUniqSupply 'n' debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) - _ <- {-# SCC "OutputAsm" #-} doOutput filenm $+ {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream- return () | otherwise = panic "This compiler was built without a native code generator"@@ -177,7 +173,7 @@ ************************************************************************ -} -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a outputLlvm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n'
compiler/main/DriverPipeline.hs view
@@ -56,7 +56,7 @@ import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc-import LlvmCodeGen ( LlvmVersion (..), llvmFixupAsm )+import LlvmCodeGen ( llvmFixupAsm, llvmVersionList ) import MonadUtils import GHC.Platform import TcRnTypes@@ -2039,10 +2039,10 @@ getBackendDefs :: DynFlags -> IO [String] getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags- return $ case llvmVer of- Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]- Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]- _ -> []+ return $ case fmap llvmVersionList llvmVer of+ Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+ Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+ _ -> [] where format (major, minor) | minor >= 100 = error "getBackendDefs: Unsupported minor version"
compiler/main/GHC.hs view
@@ -80,6 +80,7 @@ modInfoIsExportedName, modInfoLookupName, modInfoIface,+ modInfoRdrEnv, modInfoSafe, lookupGlobalName, findGlobalAnns,@@ -1220,6 +1221,9 @@ modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface++modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv+modInfoRdrEnv = minf_rdr_env -- | Retrieve module safe haskell mode modInfoSafe :: ModuleInfo -> SafeHaskellMode
compiler/main/HscMain.hs view
@@ -149,7 +149,6 @@ import DynFlags import ErrUtils-import GHC.Platform ( platformOS, osSubsectionsViaSymbols ) import Outputable import NameEnv@@ -175,7 +174,7 @@ import Data.Set (Set) import HieAst ( mkHieFile )-import HieTypes ( getAsts, hie_asts )+import HieTypes ( getAsts, hie_asts, hie_module ) import HieBin ( readHieFile, writeHieFile , hie_file_result) import HieDebug ( diffFile, validateScopes ) @@ -428,7 +427,8 @@ hs_env <- Hsc $ \e w -> return (e, w) liftIO $ do -- Validate Scopes- case validateScopes $ getAsts $ hie_asts hieFile of+ let mdl = hie_module hieFile+ case validateScopes mdl $ getAsts $ hie_asts hieFile of [] -> putMsg dflags $ text "Got valid scopes" xs -> do putMsg dflags $ text "Got invalid scopes"@@ -1426,7 +1426,7 @@ return a rawcmms1 = Stream.mapM dump rawcmms0 - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)+ (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, ()) <- {-# SCC "codeOutput" #-} codeOutput dflags this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1@@ -1522,31 +1522,11 @@ ppr_stream1 = Stream.mapM dump1 cmm_stream - -- We are building a single SRT for the entire module, so- -- we must thread it through all the procedures as we cps-convert them.- us <- mkSplitUniqSupply 'S'-- -- When splitting, we generate one SRT per split chunk, otherwise- -- we generate one SRT for the whole module.- let- pipeline_stream- | gopt Opt_SplitSections dflags ||- osSubsectionsViaSymbols (platformOS (targetPlatform dflags))- = {-# SCC "cmmPipeline" #-}- let run_pipeline us cmmgroup = do- (_topSRT, cmmgroup) <-- cmmPipeline hsc_env (emptySRT this_mod) cmmgroup- return (us, cmmgroup)-- in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1- return ()-- | otherwise- = {-# SCC "cmmPipeline" #-}- let run_pipeline = cmmPipeline hsc_env- in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1+ pipeline_stream+ = {-# SCC "cmmPipeline" #-}+ let run_pipeline = cmmPipeline hsc_env+ in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 - let dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr a) return a
compiler/main/StaticPtrTable.hs view
@@ -233,9 +233,10 @@ -- Choose either 'Word64#' or 'Word#' to represent the arguments of the -- 'Fingerprint' data constructor.- mkWord64LitWordRep dflags- | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64- | otherwise = mkWordLit dflags . toInteger+ mkWord64LitWordRep dflags =+ case platformWordSize (targetPlatform dflags) of+ PW4 -> mkWord64LitWord64+ PW8 -> mkWordLit dflags . toInteger lookupIdHscEnv :: Name -> IO Id lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
compiler/main/SysTools/Tasks.hs view
@@ -16,14 +16,13 @@ import GHC.Platform import Util -import Data.Char import Data.List import System.IO import System.Process import GhcPrelude -import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion)+import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) import SysTools.Process import SysTools.Info@@ -209,7 +208,7 @@ -- of the options they've specified. llc doesn't care what other -- options are specified when '-version' is used. args' = args ++ ["-version"]- ver <- catchIO (do+ catchIO (do (pin, pout, perr, _) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version@@ -219,18 +218,12 @@ -} hSetBinaryMode pout False _ <- hGetLine pout- vline <- dropWhile (not . isDigit) `fmap` hGetLine pout- v <- case span (/= '.') vline of- ("",_) -> fail "no digits!"- (x,"") -> return $ LlvmVersion (read x)- (x,y) -> return $ LlvmVersionOld- (read x)- (read $ takeWhile isDigit $ drop 1 y)-+ vline <- hGetLine pout+ let mb_ver = parseLlvmVersion vline hClose pin hClose pout hClose perr- return $ Just v+ return mb_ver ) (\err -> do debugTraceMsg dflags 2@@ -242,7 +235,6 @@ text ("Make sure you have installed LLVM " ++ llvmVersionStr supportedLlvmVersion) ] return Nothing)- return ver runLink :: DynFlags -> [Option] -> IO ()
compiler/nativeGen/AsmCodeGen.hs view
@@ -157,14 +157,14 @@ -} ---------------------nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply- -> Stream IO RawCmmGroup ()- -> IO UniqSupply+nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+ -> Stream IO RawCmmGroup a+ -> IO a nativeCodeGen dflags this_mod modLoc h us cmms = let platform = targetPlatform dflags nCG' :: ( Outputable statics, Outputable instr , Outputable jumpDest, Instruction instr)- => NcgImpl statics instr jumpDest -> IO UniqSupply+ => NcgImpl statics instr jumpDest -> IO a nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (x86NcgImpl dflags)@@ -314,8 +314,8 @@ -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply- -> Stream IO RawCmmGroup ()- -> IO UniqSupply+ -> Stream IO RawCmmGroup a+ -> IO a nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms = do -- BufHandle is a performance hack. We could hide it inside@@ -323,9 +323,10 @@ -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty- (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+ (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us cmms ngs0- finishNativeGen dflags modLoc bufh us' ngs+ _ <- finishNativeGen dflags modLoc bufh us' ngs+ return a finishNativeGen :: Instruction instr => DynFlags@@ -346,7 +347,7 @@ -- dump global NCG stats for graph coloring allocator let stats = concat (ngs_colorStats ngs)- when (not (null stats)) $ do+ unless (null stats) $ do -- build the global register conflict graph let graphGlobal@@ -369,7 +370,7 @@ -- dump global NCG stats for linear allocator let linearStats = concat (ngs_linearStats ngs)- when (not (null linearStats)) $+ unless (null linearStats) $ dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats) -- write out the imports@@ -386,20 +387,21 @@ -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply- -> Stream IO RawCmmGroup ()+ -> Stream IO RawCmmGroup a -> NativeGenAcc statics instr- -> IO (NativeGenAcc statics instr, UniqSupply)+ -> IO (NativeGenAcc statics instr, UniqSupply, a) cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs = do r <- Stream.runStream cmm_stream case r of- Left () ->+ Left a -> return (ngs { ngs_imports = reverse $ ngs_imports ngs , ngs_natives = reverse $ ngs_natives ngs , ngs_colorStats = reverse $ ngs_colorStats ngs , ngs_linearStats = reverse $ ngs_linearStats ngs },- us)+ us,+ a) Right (cmms, cmm_stream') -> do (us', ngs'') <- withTiming (return dflags)@@ -417,8 +419,9 @@ -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in Debug. let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs- dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"- (vcat $ map ppr ldbgs)+ unless (null ldbgs) $+ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+ (vcat $ map ppr ldbgs) -- Accumulate debug information for emission in finishNativeGen. let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }@@ -475,7 +478,7 @@ map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks- {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)+ {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) () let !labels' = if debugLevel dflags > 0 then cmmDebugLabels isMetaInstr native else []@@ -492,9 +495,6 @@ , ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds } go us' cmms ngs' (count + 1)-- seqString [] = ()- seqString (x:xs) = x `seq` seqString xs emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
compiler/nativeGen/BlockLayout.hs view
@@ -4,9 +4,6 @@ {-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-} -{-# OPTIONS_GHC -fprof-auto #-}---{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}- module BlockLayout ( sequenceTop ) where@@ -37,7 +34,6 @@ --import Debug --import Debug.Trace import ListSetOps (removeDups)-import PprCmm () import OrdList import Data.List
compiler/nativeGen/CFG.hs view
@@ -56,7 +56,7 @@ --import Debug --import OrdList --import Debug.Trace-import PprCmm ()+import PprCmm () -- For Outputable instances import qualified DynFlags as D import Data.List
compiler/nativeGen/Dwarf.hs view
@@ -116,7 +116,7 @@ , pprHalf 3 -- DWARF version , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) -- abbrevs offset- , text "\t.byte " <> ppr (platformWordSize plat) -- word size+ , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size ] -- | Compilation unit footer, mainly establishing size of debug sections
compiler/nativeGen/Dwarf/Types.hs view
@@ -224,7 +224,7 @@ -- address table entry. pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->- let wordSize = platformWordSize plat+ let wordSize = platformWordSizeInBytes plat paddingSize = 4 :: Int -- header is 12 bytes long. -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).@@ -293,7 +293,7 @@ length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel spReg = dwarfGlobalRegNo plat Sp retReg = dwarfReturnRegNo plat- wordSize = platformWordSize plat+ wordSize = platformWordSizeInBytes plat pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) @@ -454,9 +454,9 @@ pprSetUnwind _ Sp (_, Just uw) = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))- | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case+ | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$- pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))+ pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) | otherwise = pprByte dW_CFA_offset_extended_sf $$ pprLEBRegNo plat g $$@@ -517,10 +517,9 @@ wordAlign = sdocWithPlatform $ \plat -> text "\t.align " <> case platformOS plat of OSDarwin -> case platformWordSize plat of- 8 -> text "3"- 4 -> text "2"- _other -> error "wordAlign: Unsupported word size!"- _other -> ppr (platformWordSize plat)+ PW8 -> char '3'+ PW4 -> char '2'+ _other -> ppr (platformWordSizeInBytes plat) -- | Assembly for a single byte of constant DWARF data pprByte :: Word8 -> SDoc@@ -552,10 +551,8 @@ pprWord :: SDoc -> SDoc pprWord s = (<> s) . sdocWithPlatform $ \plat -> case platformWordSize plat of- 4 -> text "\t.long "- 8 -> text "\t.quad "- n -> panic $ "pprWord: Unsupported target platform word length " ++- show n ++ "!"+ PW4 -> text "\t.long "+ PW8 -> text "\t.quad " -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes
compiler/nativeGen/PPC/Instr.hs view
@@ -98,7 +98,7 @@ , STU fmt r0 (AddrRegReg sp tmp) ] where- fmt = intFormat $ widthFromBytes (platformWordSize platform)+ fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform) zero = ImmInt 0 tmp = tmpReg platform immAmount = ImmInt amount
compiler/nativeGen/PPC/Ppr.hs view
@@ -27,7 +27,7 @@ import BlockId import CLabel-import PprCmmExpr ()+import PprCmmExpr () -- For Outputable instances import Unique ( pprUniqueAlways, getUnique ) import GHC.Platform
compiler/nativeGen/RegAlloc/Graph/Main.hs view
@@ -310,7 +310,7 @@ -- Add the reg-reg conflicts to the graph. let conflictBag = unionManyBags conflictList let graph_conflict- = foldrBag graphAddConflictSet Color.initGraph conflictBag+ = foldr graphAddConflictSet Color.initGraph conflictBag -- Add the coalescences edges to the graph. let moveBag@@ -318,7 +318,7 @@ (unionManyBags moveList) let graph_coalesce- = foldrBag graphAddCoalesce graph_conflict moveBag+ = foldr graphAddCoalesce graph_conflict moveBag return graph_coalesce
compiler/nativeGen/RegAlloc/Graph/Stats.hs view
@@ -28,7 +28,6 @@ import Reg import TargetReg -import PprCmm() import Outputable import UniqFM import UniqSet
compiler/nativeGen/RegAlloc/Liveness.hs view
@@ -45,7 +45,6 @@ import Hoopl.Collections import Hoopl.Label import Cmm hiding (RegSet, emptyRegSet)-import PprCmm() import Digraph import DynFlags
compiler/nativeGen/SPARC/CodeGen.hs view
@@ -31,7 +31,6 @@ import SPARC.CodeGen.Gen64 import SPARC.CodeGen.Gen32 import SPARC.CodeGen.Base-import SPARC.Ppr () import SPARC.Instr import SPARC.Imm import SPARC.AddrMode
compiler/nativeGen/SPARC/CodeGen/Base.hs view
@@ -25,7 +25,7 @@ import CodeGen.Platform import DynFlags import Cmm-import PprCmmExpr ()+import PprCmmExpr () -- For Outputable instances import GHC.Platform import Outputable
compiler/nativeGen/SPARC/CodeGen/Expand.hs view
@@ -11,7 +11,6 @@ import SPARC.Imm import SPARC.AddrMode import SPARC.Regs-import SPARC.Ppr () import Instruction import Reg import Format
compiler/nativeGen/SPARC/CodeGen/Gen64.hs view
@@ -16,7 +16,7 @@ import SPARC.AddrMode import SPARC.Imm import SPARC.Instr-import SPARC.Ppr()+-- import SPARC.Ppr() import NCGMonad import Instruction import Format
compiler/nativeGen/SPARC/CodeGen/Sanity.hs view
@@ -9,7 +9,7 @@ import GhcPrelude import SPARC.Instr-import SPARC.Ppr ()+import SPARC.Ppr () -- For Outputable instances import Instruction import Cmm
compiler/nativeGen/SPARC/Ppr.hs view
@@ -39,7 +39,7 @@ import PprBase import Cmm hiding (topInfoTable)-import PprCmm()+import PprCmm() -- For Outputable instances import BlockId import CLabel import Hoopl.Label
compiler/nativeGen/X86/CodeGen.hs view
@@ -38,9 +38,6 @@ import X86.Regs import X86.RegInfo ---TODO: Remove - Just for development/debugging-import X86.Ppr()- import CodeGen.Platform import CPrim import Debug ( DebugBlock(..), UnwindPoint(..), UnwindTable@@ -60,7 +57,6 @@ import BasicTypes import BlockId import Module ( primUnitId )-import PprCmm () import CmmUtils import CmmSwitch import Cmm
compiler/rename/RnBinds.hs view
@@ -853,7 +853,7 @@ -- for instance decls too -- Rename the bindings LHSs- ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds+ ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds -- Rename the pragmas and signatures -- Annoyingly the type variables /are/ in scope for signatures, but@@ -875,7 +875,7 @@ ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'- ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)+ ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) emptyFVs binds_w_dus ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
compiler/rename/RnSource.hs view
@@ -2135,7 +2135,7 @@ ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]- new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds+ new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs
compiler/simplCore/FloatOut.hs view
@@ -629,7 +629,7 @@ addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] addTopFloatPairs float_bag prs- = foldrBag add prs float_bag+ = foldr add prs float_bag where add (NonRec b r) prs = (b,r):prs add (Rec prs1) prs2 = prs1 ++ prs2@@ -673,7 +673,7 @@ install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr- = foldrBag wrapFloat expr defn_groups+ = foldr wrapFloat expr defn_groups partitionByLevel :: Level -- Partitioning level
compiler/simplStg/UnariseStg.hs view
@@ -188,6 +188,8 @@ `StgCmmEnv.NonVoid`, for example. * Alt binders (binders in patterns) are always non-void.++ * Binders always have zero (for void arguments) or one PrimRep. -} {-# LANGUAGE CPP, TupleSections #-}
compiler/specialise/Specialise.hs view
@@ -2181,7 +2181,7 @@ callInfoFVs :: CallInfoSet -> VarSet callInfoFVs (CIS _ call_info) =- foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info+ foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info computeArity :: [SpecArg] -> Int computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg@@ -2350,7 +2350,7 @@ ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id]-_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs+_dictBindBndrs dbs = foldr ((++) . bindersOf . fst) [] dbs -- | Construct a 'DictBind' from a 'CoreBind' mkDB :: CoreBind -> DictBind@@ -2389,7 +2389,7 @@ recWithDumpedDicts pairs dbs = (Rec bindings, fvs) where- (bindings, fvs) = foldrBag add+ (bindings, fvs) = foldr add ([], emptyVarSet) (dbs `snocBag` mkDB (Rec pairs)) add (NonRec b r, fvs') (pairs, fvs) =@@ -2413,13 +2413,13 @@ wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] wrapDictBinds dbs binds- = foldrBag add binds dbs+ = foldr add binds dbs where add (bind,_) binds = bind : binds wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr wrapDictBindsE dbs expr- = foldrBag add expr dbs+ = foldr add expr dbs where add (bind,_) expr = Let bind expr @@ -2478,7 +2478,7 @@ filterCalls (CIS fn call_bag) dbs = filter ok_call (bagToList call_bag) where- dump_set = foldlBag go (unitVarSet fn) dbs+ dump_set = foldl' go (unitVarSet fn) dbs -- This dump-set could also be computed by splitDictBinds -- (_,_,dump_set) = splitDictBinds dbs {fn} -- But this variant is shorter@@ -2498,8 +2498,8 @@ -- * free_dbs does not depend on bndrs -- * dump_set = bndrs `union` bndrs(dump_dbs) splitDictBinds dbs bndr_set- = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs- -- Important that it's foldl not foldr;+ = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+ -- Important that it's foldl' not foldr; -- we're accumulating the set of dumped ids in dump_set where split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
compiler/stgSyn/CoreToStg.hs view
@@ -268,7 +268,7 @@ bind = StgTopLifted $ StgNonRec id stg_rhs in- assertConsistentCaInfo dflags id bind (ppr bind)+ assertConsistentCafInfo dflags id bind (ppr bind) -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole -- where printing the assertion error tripped the@@ -296,17 +296,17 @@ bind = StgTopLifted $ StgRec (zip binders stg_rhss) in- assertConsistentCaInfo dflags (head binders) bind (ppr binders)+ assertConsistentCafInfo dflags (head binders) bind (ppr binders) (env', ccs', bind) -- | CAF consistency issues will generally result in segfaults and are quite -- difficult to debug (see #16846). We enable checking of the -- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that -- we catch these issues.-assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a-assertConsistentCaInfo dflags id bind err_doc result+assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a+assertConsistentCafInfo dflags id bind err_doc result | gopt Opt_DoStgLinting dflags || debugIsOn- , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc+ , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc | otherwise = result -- Assertion helper: this checks that the CafInfo on the Id matches@@ -384,11 +384,11 @@ -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in -- a STG to Cmm pass. = coreToStgExpr (Var unitDataConId)-coreToStgExpr (Var v) = coreToStgApp Nothing v [] []-coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []+coreToStgExpr (Var v) = coreToStgApp v [] []+coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] [] coreToStgExpr expr@(App _ _)- = coreToStgApp Nothing f args ticks+ = coreToStgApp f args ticks where (f, args, ticks) = myCollectArgs expr @@ -502,18 +502,11 @@ -- Applications -- --------------------------------------------------------------------------- -coreToStgApp- :: Maybe UpdateFlag -- Just upd <=> this application is- -- the rhs of a thunk binding- -- x = [...] \upd [] -> the_app- -- with specified update flag- -> Id -- Function- -> [CoreArg] -- Arguments- -> [Tickish Id] -- Debug ticks- -> CtsM StgExpr---coreToStgApp _ f args ticks = do+coreToStgApp :: Id -- Function+ -> [CoreArg] -- Arguments+ -> [Tickish Id] -- Debug ticks+ -> CtsM StgExpr+coreToStgApp f args ticks = do (args', ticks') <- coreToStgArgs args how_bound <- lookupVarCts f
compiler/stgSyn/StgSyn.hs view
@@ -1,7 +1,8 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}+Shared term graph (STG) syntax for spineless-tagless code generation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This data type represents programs just before code generation (conversion to @Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style@@ -67,7 +68,6 @@ import Data.List ( intersperse ) import DataCon import DynFlags-import FastString import ForeignCall ( ForeignCall ) import Id import IdInfo ( mayHaveCafRefs )@@ -89,14 +89,13 @@ {- ************************************************************************ * *-\subsection{@GenStgBinding@}+GenStgBinding * * ************************************************************************ -As usual, expressions are interesting; other things are boring. Here-are the boring things [except note the @GenStgRhs@], parameterised-with respect to binder and occurrence information (just as in-@CoreSyn@):+As usual, expressions are interesting; other things are boring. Here are the+boring things (except note the @GenStgRhs@), parameterised with respect to+binder and occurrence information (just as in @CoreSyn@): -} -- | A top-level binding.@@ -112,7 +111,7 @@ {- ************************************************************************ * *-\subsection{@StgArg@}+StgArg * * ************************************************************************ -}@@ -121,8 +120,8 @@ = StgVarArg Id | StgLitArg Literal --- | Does this constructor application refer to--- anything in a different *Windows* DLL?+-- | Does this constructor application refer to anything in a different+-- *Windows* DLL? -- If so, we can't allocate it statically isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool isDllConApp dflags this_mod con args@@ -137,17 +136,22 @@ && isDllName dflags this_mod (idName v) is_dll_arg _ = False --- True of machine addresses; these are the things that don't--- work across DLLs. The key point here is that VoidRep comes--- out False, so that a top level nullary GADT constructor is--- False for isDllConApp+-- True of machine addresses; these are the things that don't work across DLLs.+-- The key point here is that VoidRep comes out False, so that a top level+-- nullary GADT constructor is False for isDllConApp+-- -- data T a where -- T1 :: T Int+-- -- gives+-- -- T1 :: forall a. (a~Int) -> T a+-- -- and hence the top-level binding+-- -- $WT1 :: T Int -- $WT1 = T1 Int (Coercion (Refl Int))+-- -- The coercion argument here gets VoidRep isAddrRep :: PrimRep -> Bool isAddrRep AddrRep = True@@ -191,26 +195,25 @@ {- ************************************************************************ * *-\subsection{STG expressions}+STG expressions * * ************************************************************************ -The @GenStgExpr@ data type is parameterised on binder and occurrence-info, as before.+The @GenStgExpr@ data type is parameterised on binder and occurrence info, as+before. ************************************************************************ * *-\subsubsection{@GenStgExpr@ application}+GenStgExpr * * ************************************************************************ -An application is of a function to a list of atoms [not expressions].-Operationally, we want to push the arguments on the stack and call the-function. (If the arguments were expressions, we would have to build-their closures first.)+An application is of a function to a list of atoms (not expressions).+Operationally, we want to push the arguments on the stack and call the function.+(If the arguments were expressions, we would have to build their closures+first.) -There is no constructor for a lone variable; it would appear as-@StgApp var []@.+There is no constructor for a lone variable; it would appear as @StgApp var []@. -} data GenStgExpr pass@@ -221,18 +224,18 @@ {- ************************************************************************ * *-\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}+StgConApp and StgPrimApp --- saturated applications * * ************************************************************************ -There are specialised forms of application, for constructors,-primitives, and literals.+There are specialised forms of application, for constructors, primitives, and+literals. -} | StgLit Literal -- StgConApp is vital for returning unboxed tuples or sums- -- which can't be let-bound first+ -- which can't be let-bound | StgConApp DataCon [StgArg] -- Saturated [Type] -- See Note [Types in StgConApp] in UnariseStg@@ -246,13 +249,13 @@ {- ************************************************************************ * *-\subsubsection{@StgLam@}+StgLam * * ************************************************************************ -StgLam is used *only* during CoreToStg's work. Before CoreToStg has-finished it encodes (\x -> e) as (let f = \x -> e in f)-TODO: Encode this via an extension to GenStgExpr à la TTG.+StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it+encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension+to GenStgExpr à la TTG. -} | StgLam@@ -262,7 +265,7 @@ {- ************************************************************************ * *-\subsubsection{@GenStgExpr@: case-expressions}+GenStgExpr: case-expressions * * ************************************************************************ @@ -280,94 +283,75 @@ {- ************************************************************************ * *-\subsubsection{@GenStgExpr@: @let(rec)@-expressions}+GenStgExpr: let(rec)-expressions * * ************************************************************************ -The various forms of let(rec)-expression encode most of the-interesting things we want to do.-\begin{enumerate}-\item-\begin{verbatim}-let-closure x = [free-vars] [args] expr-in e-\end{verbatim}-is equivalent to-\begin{verbatim}-let x = (\free-vars -> \args -> expr) free-vars-\end{verbatim}-\tr{args} may be empty (and is for most closures). It isn't under-circumstances like this:-\begin{verbatim}-let x = (\y -> y+z)-\end{verbatim}-This gets mangled to-\begin{verbatim}-let-closure x = [z] [y] (y+z)-\end{verbatim}-The idea is that we compile code for @(y+z)@ in an environment in which-@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an-offset from the stack pointer.+The various forms of let(rec)-expression encode most of the interesting things+we want to do. -(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)+- let-closure x = [free-vars] [args] expr in e -\item-\begin{verbatim}-let-constructor x = Constructor [args]-in e-\end{verbatim}+ is equivalent to -(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)+ let x = (\free-vars -> \args -> expr) free-vars -\item-Letrec-expressions are essentially the same deal as-let-closure/let-constructor, so we use a common structure and-distinguish between them with an @is_recursive@ boolean flag.+ @args@ may be empty (and is for most closures). It isn't under circumstances+ like this: -\item-\begin{verbatim}-let-unboxed u = an arbitrary arithmetic expression in unboxed values-in e-\end{verbatim}-All the stuff on the RHS must be fully evaluated.-No function calls either!+ let x = (\y -> y+z) -(We've backed away from this toward case-expressions with-suitably-magical alts ...)+ This gets mangled to -\item-~[Advanced stuff here! Not to start with, but makes pattern matching-generate more efficient code.]+ let-closure x = [z] [y] (y+z) -\begin{verbatim}-let-escapes-not fail = expr-in e'-\end{verbatim}-Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,-or pass it to another function. All @e'@ will ever do is tail-call @fail@.-Rather than build a closure for @fail@, all we need do is to record the stack-level at the moment of the @let-escapes-not@; then entering @fail@ is just-a matter of adjusting the stack pointer back down to that point and entering-the code for it.+ The idea is that we compile code for @(y+z)@ in an environment in which @z@ is+ bound to an offset from Node, and `y` is bound to an offset from the stack+ pointer. -Another example:-\begin{verbatim}-f x y = let z = huge-expression in- if y==1 then z else- if y==2 then z else- 1-\end{verbatim}+ (A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) -(A let-escapes-not is an @StgLetNoEscape@.)+- let-constructor x = Constructor [args] in e -\item-We may eventually want:-\begin{verbatim}-let-literal x = Literal-in e-\end{verbatim}-\end{enumerate}+ (A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) +- Letrec-expressions are essentially the same deal as let-closure/+ let-constructor, so we use a common structure and distinguish between them+ with an @is_recursive@ boolean flag.++- let-unboxed u = <an arbitrary arithmetic expression in unboxed values> in e++ All the stuff on the RHS must be fully evaluated. No function calls either!++ (We've backed away from this toward case-expressions with suitably-magical+ alts ...)++- Advanced stuff here! Not to start with, but makes pattern matching generate+ more efficient code.++ let-escapes-not fail = expr+ in e'++ Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,+ or pass it to another function. All @e'@ will ever do is tail-call @fail@.+ Rather than build a closure for @fail@, all we need do is to record the stack+ level at the moment of the @let-escapes-not@; then entering @fail@ is just a+ matter of adjusting the stack pointer back down to that point and entering the+ code for it.++ Another example:++ f x y = let z = huge-expression in+ if y==1 then z else+ if y==2 then z else+ 1++ (A let-escapes-not is an @StgLetNoEscape@.)++- We may eventually want:++ let-literal x = Literal in e+ And so the code for let(rec)-things: -} @@ -382,11 +366,11 @@ (GenStgExpr pass) -- body {--%************************************************************************-%* *-\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}-%* *-%************************************************************************+*************************************************************************+* *+GenStgExpr: hpc, scc and other debug annotations+* *+************************************************************************* Finally for @hpc@ expressions we introduce a new STG construct. -}@@ -400,12 +384,12 @@ {- ************************************************************************ * *-\subsection{STG right-hand sides}+STG right-hand sides * * ************************************************************************ -Here's the rest of the interesting stuff for @StgLet@s; the first-flavour is for closures:+Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for+closures: -} data GenStgRhs pass@@ -420,18 +404,19 @@ {- An example may be in order. Consider:-\begin{verbatim}-let t = \x -> \y -> ... x ... y ... p ... q in e-\end{verbatim}++ let t = \x -> \y -> ... x ... y ... p ... q in e+ Pulling out the free vars and stylising somewhat, we get the equivalent:-\begin{verbatim}-let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q-\end{verbatim}-Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are-offsets from @Node@ into the closure, and the code ptr for the closure-will be exactly that in parentheses above. -The second flavour of right-hand-side is for constructors (simple but important):+ let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q++Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are offsets from+@Node@ into the closure, and the code ptr for the closure will be exactly that+in parentheses above.++The second flavour of right-hand-side is for constructors (simple but+important): -} | StgRhsCon@@ -569,20 +554,19 @@ {- ************************************************************************ * *-\subsection[Stg-case-alternatives]{STG case alternatives}+STG case alternatives * * ************************************************************************ Very like in @CoreSyntax@ (except no type-world stuff). -The type constructor is guaranteed not to be abstract; that is, we can-see its representation. This is important because the code generator-uses it to determine return conventions etc. But it's not trivial-where there's a module loop involved, because some versions of a type-constructor might not have all the constructors visible. So-mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the-constructors or literals (which are guaranteed to have the Real McCoy)-rather than from the scrutinee type.+The type constructor is guaranteed not to be abstract; that is, we can see its+representation. This is important because the code generator uses it to+determine return conventions etc. But it's not trivial where there's a module+loop involved, because some versions of a type constructor might not have all+the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets+the TyCon from the constructors or literals (which are guaranteed to have the+Real McCoy) rather than from the scrutinee type. -} type GenStgAlt pass@@ -601,7 +585,7 @@ {- ************************************************************************ * *-\subsection[Stg]{The Plain STG parameterisation}+The Plain STG parameterisation * * ************************************************************************ @@ -648,17 +632,16 @@ ************************************************************************ * *-\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}+UpdateFlag * * ************************************************************************ This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. -A @ReEntrant@ closure may be entered multiple times, but should not be-updated or blackholed. An @Updatable@ closure should be updated after-evaluation (and may be blackholed during evaluation). A @SingleEntry@-closure will only be entered once, and so need not be updated but may-safely be blackholed.+A @ReEntrant@ closure may be entered multiple times, but should not be updated+or blackholed. An @Updatable@ closure should be updated after evaluation (and+may be blackholed during evaluation). A @SingleEntry@ closure will only be+entered once, and so need not be updated but may safely be blackholed. -} data UpdateFlag = ReEntrant | Updatable | SingleEntry@@ -677,13 +660,12 @@ {- ************************************************************************ * *-\subsubsection{StgOp}+StgOp * * ************************************************************************ -An StgOp allows us to group together PrimOps and ForeignCalls.-It's quite useful to move these around together, notably-in StgOpApp and COpStmt.+An StgOp allows us to group together PrimOps and ForeignCalls. It's quite useful+to move these around together, notably in StgOpApp and COpStmt. -} data StgOp@@ -700,12 +682,12 @@ {- ************************************************************************ * *-\subsection[Stg-pretty-printing]{Pretty-printing}+Pretty-printing * * ************************************************************************ -Robin Popplestone asked for semi-colon separators on STG binds; here's-hoping he likes terminators instead... Ditto for case alternatives.+Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he+likes terminators instead... Ditto for case alternatives. -} type OutputablePass pass =@@ -876,15 +858,6 @@ pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc --- special case-pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))- = sdocWithDynFlags $ \dflags ->- hsep [ ppr cc,- if not $ gopt Opt_SuppressStgExts dflags- then ppr ext else empty,- text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]---- general case pprStgRhs (StgRhsClosure ext cc upd_flag args body) = sdocWithDynFlags $ \dflags -> hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
compiler/typecheck/TcClassDcl.hs view
@@ -369,7 +369,7 @@ -- site of the method binder, and any inline or -- specialisation pragmas findMethodBind sel_name binds prag_fn- = foldlBag mplus Nothing (mapBag f binds)+ = foldl' mplus Nothing (mapBag f binds) where prags = lookupPragEnv prag_fn sel_name
compiler/typecheck/TcFlatten.hs view
@@ -29,6 +29,7 @@ import Bag import Control.Monad import MonadUtils ( zipWith3M )+import Data.Foldable ( foldrM ) import Control.Arrow ( first ) @@ -1690,11 +1691,11 @@ -- ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv] -- ==> (unify) [W] F [fmv] ~ fmv -- See Note [Unflatten using funeqs first]- ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs+ ; funeqs <- foldrM unflatten_funeq emptyCts funeqs ; traceTcS "Unflattening 1" $ braces (pprCts funeqs) -- Step 2: unify the tv_eqs, if possible- ; tv_eqs <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs+ ; tv_eqs <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs) -- Step 3: fill any remaining fmvs with fresh unification variables@@ -1702,7 +1703,7 @@ ; traceTcS "Unflattening 3" $ braces (pprCts funeqs) -- Step 4: remove any tv_eqs that look like ty ~ ty- ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs+ ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs ; let all_flat = tv_eqs `andCts` funeqs ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
compiler/typecheck/TcGenDeriv.hs view
@@ -1973,11 +1973,11 @@ splitDerivAuxBind (DerivAuxBind x) = Left x splitDerivAuxBind x = Right x - rm_dups = foldrBag dup_check emptyBag+ rm_dups = foldr dup_check emptyBag dup_check a b = if anyBag (== a) b then b else consBag a b genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff- genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)+ genAuxBinds' = foldr f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1) , emptyBag ) f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
compiler/typecheck/TcHsSyn.hs view
@@ -1677,7 +1677,7 @@ ; return (env1, binds') }) where collect_ev_bndrs :: Bag EvBind -> [EvVar]- collect_ev_bndrs = foldrBag add []+ collect_ev_bndrs = foldr add [] add (EvBind { eb_lhs = var }) vars = var : vars zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
compiler/typecheck/TcInteract.hs view
@@ -223,7 +223,7 @@ solveSimples cts = {-# SCC "solveSimples" #-}- do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)+ do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) ; solve_loop } where solve_loop
compiler/typecheck/TcRnDriver.hs view
@@ -1458,7 +1458,7 @@ foe_binds ; fo_gres = fi_gres `unionBags` foe_gres- ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)+ ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre) emptyFVs fo_gres ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
compiler/typecheck/TcSMonad.hs view
@@ -1668,7 +1668,7 @@ -- constraints, which perhaps may have become soluble after new_tv -- is substituted; ditto the dictionaries, which may include (a~b) -- or (a~~b) constraints.- kicked_out = foldrBag extendWorkListCt+ kicked_out = foldr extendWorkListCt (emptyWorkList { wl_eqs = tv_eqs_out , wl_funeqs = feqs_out }) ((dicts_out `andCts` irs_out)@@ -2054,7 +2054,7 @@ getNoGivenEqs tclvl skol_tvs = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds }) <- getInertCans- ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds+ ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds || anyDVarEnv eqs_given_here ieqs insols = filterBag insolubleEqCt irreds -- Specifically includes ones that originated in some@@ -2317,7 +2317,7 @@ ********************************************************************* -} foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldrBag k z irreds+foldIrreds k irreds z = foldr k z irreds {- *********************************************************************@@ -2467,7 +2467,7 @@ addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items- = addToUDFM m cls (foldrBag add emptyTM items)+ = addToUDFM m cls (foldr add emptyTM items) where add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm add ct _ = pprPanic "addDictsByClass" (ppr ct)
compiler/typecheck/TcSigs.hs view
@@ -45,7 +45,6 @@ import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import PrelNames( mkUnboundName ) import BasicTypes-import Bag( foldrBag ) import Module( getModule ) import Name import NameEnv@@ -577,7 +576,7 @@ -- ar_env maps a local to the arity of its definition ar_env :: NameEnv Arity- ar_env = foldrBag lhsBindArity emptyNameEnv binds+ ar_env = foldr lhsBindArity emptyNameEnv binds lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
compiler/typecheck/TcSimplify.hs view
@@ -48,7 +48,6 @@ import TcRnMonad as TcM import TcSMonad as TcS import TcType-import TrieMap () -- DV: for now import Type import TysWiredIn ( liftedRepTy ) import Unify ( tcMatchTyKi )@@ -1850,7 +1849,7 @@ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; let seeds1 = foldrBag add_implic_seeds old_needs implics+ ; let seeds1 = foldr add_implic_seeds old_needs implics seeds2 = foldEvBindMap add_wanted seeds1 ev_binds seeds3 = seeds2 `unionVarSet` tcvs need_inner = findNeededEvVars ev_binds seeds3@@ -2128,7 +2127,7 @@ new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp do_bag :: (a -> Bag c) -> Bag a -> Bag c- do_bag f = foldrBag (unionBags.f) emptyBag+ do_bag f = foldr (unionBags.f) emptyBag is_floatable skol_tvs ct | isGivenCt ct = False@@ -2369,7 +2368,7 @@ seed_skols = mkVarSet skols `unionVarSet` mkVarSet given_ids `unionVarSet`- foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`+ foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet` foldEvBindMap add_one_bind emptyVarSet binds -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3) -- Include the EvIds of any non-floating constraints@@ -2408,7 +2407,7 @@ | otherwise = not (ctEvId ct `elemVarSet` skols) add_captured_ev_ids :: Cts -> VarSet -> VarSet- add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts+ add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts where extra_skol ct acc | isDerivedCt ct = acc
compiler/typecheck/TcTyClsDecls.hs view
@@ -1938,11 +1938,12 @@ ; let (_, final_res_kind) = splitPiTys res_kind ; checkDataKindSig DataFamilySort final_res_kind ; tc_rep_name <- newTyConRepName tc_name- ; let tycon = mkFamilyTyCon tc_name binders+ ; let inj = Injective $ replicate (length binders) True+ tycon = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) (DataFamilyTyCon tc_rep_name)- parent NotInjective+ parent inj ; return tycon } | OpenTypeFamily <- fam_info
compiler/utils/Stream.hs view
@@ -7,8 +7,8 @@ -- ----------------------------------------------------------------------------- module Stream ( Stream(..), yield, liftIO,- collect, fromList,- Stream.map, Stream.mapM, Stream.mapAccumL+ collect, collect_, consume, fromList,+ Stream.map, Stream.mapM, Stream.mapAccumL, Stream.mapAccumL_ ) where import GhcPrelude@@ -71,6 +71,25 @@ Left () -> return (reverse acc) Right (a, str') -> go str' (a:acc) +-- | Turn a Stream into an ordinary list, by demanding all the elements.+collect_ :: Monad m => Stream m a r -> m ([a], r)+collect_ str = go str []+ where+ go str acc = do+ r <- runStream str+ case r of+ Left r -> return (reverse acc, r)+ Right (a, str') -> go str' (a:acc)++consume :: Monad m => Stream m a b -> (a -> m ()) -> m b+consume str f = do+ r <- runStream str+ case r of+ Left ret -> return ret+ Right (a, str') -> do+ f a+ consume str' f+ -- | Turn a list into a 'Stream', by yielding each element in turn. fromList :: Monad m => [a] -> Stream m a () fromList = mapM_ yield@@ -104,3 +123,13 @@ Right (a, str') -> do (c',b) <- f c a return (Right (b, mapAccumL f c' str'))++mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r+ -> Stream m b (c, r)+mapAccumL_ f c str = Stream $ do+ r <- runStream str+ case r of+ Left r -> return (Left (c, r))+ Right (a, str') -> do+ (c',b) <- f c a+ return (Right (b, mapAccumL_ f c' str'))
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20190806+version: 0.20190903 license: BSD3 license-file: LICENSE category: Development@@ -85,7 +85,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*,- ghc-lib-parser == 0.20190806+ ghc-lib-parser == 0.20190903 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -121,8 +121,6 @@ UnboxedTuples UndecidableInstances hs-source-dirs:- ghc-lib/stage0/libraries/ghci/build- ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build libraries/template-haskell compiler/specialise
ghc-lib/generated/ghcversion.h view
@@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190804+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190902 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
− ghc-lib/stage0/libraries/ghci/build/GHCi/InfoTable.hs
@@ -1,377 +0,0 @@-{-# LINE 1 "libraries/ghci/GHCi/InfoTable.hsc" #-}-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}---- Get definitions for the structs, constants & config etc.----- |--- 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- (--{-# LINE 14 "libraries/ghci/GHCi/InfoTable.hsc" #-}- mkConInfoTable--{-# LINE 16 "libraries/ghci/GHCi/InfoTable.hsc" #-}- ) where--import Prelude -- See note [Why do we import Prelude here?]--{-# LINE 20 "libraries/ghci/GHCi/InfoTable.hsc" #-}-import Foreign-import Foreign.C-import GHC.Ptr-import GHC.Exts-import GHC.Exts.Heap-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS--{-# LINE 28 "libraries/ghci/GHCi/InfoTable.hsc" #-}--ghciTablesNextToCode :: Bool--{-# LINE 31 "libraries/ghci/GHCi/InfoTable.hsc" #-}-ghciTablesNextToCode = True--{-# LINE 35 "libraries/ghci/GHCi/InfoTable.hsc" #-}---{-# LINE 37 "libraries/ghci/GHCi/InfoTable.hsc" #-}--- 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 the 'code' field.--- Otherwise, it should point to the start of the StgInfoTable.-mkConInfoTable- :: 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 allocateExec(), and- -- should be freed with freeExec().--mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =- castFunPtrToPtr <$> newExecConItbl itbl con_desc- where- entry_addr = interpConstrEntry !! ptrtag- code' = mkJumpToAddr entry_addr- itbl = StgInfoTable {- entry = if ghciTablesNextToCode- then Nothing- else Just entry_addr,- ptrs = fromIntegral ptr_words,- nptrs = fromIntegral nonptr_words,- tipe = CONSTR,- srtlen = fromIntegral tag,- code = if ghciTablesNextToCode- then Just code'- else Nothing- }----- -------------------------------------------------------------------------------- Building machine code fragments for a constructor's entry code--funPtrToInt :: FunPtr a -> Int-funPtrToInt (FunPtr a) = I# (addr2Int# a)--data Arch = ArchSPARC- | ArchPPC- | ArchX86- | ArchX86_64- | ArchAlpha- | ArchARM- | ArchARM64- | ArchPPC64- | ArchPPC64LE- | ArchUnknown- deriving Show--platform :: Arch-platform =--{-# LINE 96 "libraries/ghci/GHCi/InfoTable.hsc" #-}- ArchX86_64--{-# LINE 114 "libraries/ghci/GHCi/InfoTable.hsc" #-}--mkJumpToAddr :: EntryFunPtr -> ItblCodes-mkJumpToAddr a = case platform of- ArchSPARC ->- -- 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 ->- -- 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 ->- -- 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 ->- -- Generates:- -- jmpq *.L1(%rip)- -- .align 8- -- .L1:- -- .quad <addr>- --- -- which looks like:- -- 8: ff 25 02 00 00 00 jmpq *0x2(%rip) # 10 <f+0x10>- -- with addr at 10.- --- -- We need a full 64-bit pointer (we can't assume the info table is- -- allocated in low memory). Assuming the info pointer is aligned to- -- an 8-byte boundary, the addr will also be aligned.-- let w64 = fromIntegral (funPtrToInt a) :: Word64- insnBytes :: [Word8]- insnBytes- = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,- byte0 w64, byte1 w64, byte2 w64, byte3 w64,- byte4 w64, byte5 w64, byte6 w64, byte7 w64]- in- Left insnBytes-- ArchAlpha ->- 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 { } ->- -- 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]-- ArchARM64 { } ->- -- Generates:- --- -- ldr x1, label- -- br x1- -- label:- -- .quad <addr>- --- -- which looks like:- -- 0: 58000041 ldr x1, <label>- -- 4: d61f0020 br x1- let w64 = fromIntegral (funPtrToInt a) :: Word64- in Right [ 0x58000041- , 0xd61f0020- , fromIntegral w64- , fromIntegral (w64 `shiftR` 32) ]- ArchPPC64 ->- -- We use the compiler's register r12 to read the function- -- descriptor and the linker's register r11 as a temporary- -- register to hold the function entry point.- -- In the medium code model the function descriptor- -- is located in the first two gigabytes, i.e. the address- -- of the function pointer is a non-negative 32 bit number.- -- 0x0EADBEEF stands for the address of the function pointer:- -- 0: 3d 80 0e ad lis r12,0x0EAD- -- 4: 61 8c be ef ori r12,r12,0xBEEF- -- 8: e9 6c 00 00 ld r11,0(r12)- -- c: e8 4c 00 08 ld r2,8(r12)- -- 10: 7d 69 03 a6 mtctr r11- -- 14: e9 6c 00 10 ld r11,16(r12)- -- 18: 4e 80 04 20 bctr- let w32 = fromIntegral (funPtrToInt a)- hi16 x = (x `shiftR` 16) .&. 0xFFFF- lo16 x = x .&. 0xFFFF- in Right [ 0x3D800000 .|. hi16 w32,- 0x618C0000 .|. lo16 w32,- 0xE96C0000,- 0xE84C0008,- 0x7D6903A6,- 0xE96C0010,- 0x4E800420]-- ArchPPC64LE ->- -- The ABI requires r12 to point to the function's entry point.- -- We use the medium code model where code resides in the first- -- two gigabytes, so loading a non-negative32 bit address- -- with lis followed by ori is fine.- -- 0x0EADBEEF stands for the address:- -- 3D800EAD lis r12,0x0EAD- -- 618CBEEF ori r12,r12,0xBEEF- -- 7D8903A6 mtctr r12- -- 4E800420 bctr-- let w32 = fromIntegral (funPtrToInt a)- hi16 x = (x `shiftR` 16) .&. 0xFFFF- lo16 x = x .&. 0xFFFF- in Right [ 0x3D800000 .|. hi16 w32,- 0x618C0000 .|. lo16 w32,- 0x7D8903A6, 0x4E800420 ]-- -- This code must not be called. You either need to- -- add your architecture as a distinct case or- -- use non-TABLES_NEXT_TO_CODE mode- ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"--byte0 :: (Integral w) => w -> Word8-byte0 w = fromIntegral w--byte1, byte2, byte3, byte4, byte5, byte6, byte7- :: (Integral w, Bits w) => w -> Word8-byte1 w = fromIntegral (w `shiftR` 8)-byte2 w = fromIntegral (w `shiftR` 16)-byte3 w = fromIntegral (w `shiftR` 24)-byte4 w = fromIntegral (w `shiftR` 32)-byte5 w = fromIntegral (w `shiftR` 40)-byte6 w = fromIntegral (w `shiftR` 48)-byte7 w = fromIntegral (w `shiftR` 56)----- -------------------------------------------------------------------------------- read & write intfo tables---- entry point for direct returns for created constr itbls-foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr-foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr--interpConstrEntry :: [EntryFunPtr]-interpConstrEntry = [ error "pointer tag 0"- , stg_interp_constr1_entry- , stg_interp_constr2_entry- , stg_interp_constr3_entry- , stg_interp_constr4_entry- , stg_interp_constr5_entry- , stg_interp_constr6_entry- , stg_interp_constr7_entry ]--data StgConInfoTable = StgConInfoTable {- conDesc :: Ptr Word8,- infoTable :: StgInfoTable-}---pokeConItbl- :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable- -> IO ()-pokeConItbl wr_ptr _ex_ptr itbl = do--{-# LINE 328 "libraries/ghci/GHCi/InfoTable.hsc" #-}- -- Write the offset to the con_desc from the end of the standard InfoTable- -- at the first byte.- let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)- ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) wr_ptr con_desc_offset-{-# LINE 332 "libraries/ghci/GHCi/InfoTable.hsc" #-}--{-# LINE 338 "libraries/ghci/GHCi/InfoTable.hsc" #-}- pokeItbl (wr_ptr `plusPtr` ((8))) (infoTable itbl)-{-# LINE 339 "libraries/ghci/GHCi/InfoTable.hsc" #-}--sizeOfEntryCode :: Int-sizeOfEntryCode- | not ghciTablesNextToCode = 0- | otherwise =- case mkJumpToAddr undefined of- Left xs -> sizeOf (head xs) * length xs- Right xs -> sizeOf (head xs) * length xs---- Note: Must return proper pointer for use in a closure-newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())-newExecConItbl obj con_desc- = alloca $ \pcode -> do- let lcon_desc = BS.length con_desc + 1{- null terminator -}- -- SCARY- -- This size represents the number of bytes in an StgConInfoTable.- sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)- -- Note: we need to allocate the conDesc string next to the info- -- table, because on a 64-bit platform we reference this string- -- with a 32-bit offset relative to the info table, so if we- -- allocated the string separately it might be out of range.- wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode- ex_ptr <- peek pcode- let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz- , infoTable = obj }- pokeConItbl wr_ptr ex_ptr cinfo- BS.useAsCStringLen con_desc $ \(src, len) ->- copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len- let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)- poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)- _flushExec sz ex_ptr -- Cache flush (if needed)--{-# LINE 371 "libraries/ghci/GHCi/InfoTable.hsc" #-}- return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))--{-# LINE 375 "libraries/ghci/GHCi/InfoTable.hsc" #-}--foreign import ccall unsafe "allocateExec"- _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)--foreign import ccall unsafe "flushExec"- _flushExec :: CUInt -> Ptr a -> IO ()---- -------------------------------------------------------------------------------- Constants and config--wORD_SIZE :: Int-wORD_SIZE = (8)-{-# LINE 387 "libraries/ghci/GHCi/InfoTable.hsc" #-}--conInfoTableSizeB :: Int-conInfoTableSizeB = wORD_SIZE + itblSize--{-# LINE 391 "libraries/ghci/GHCi/InfoTable.hsc" #-}