diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -729,7 +729,7 @@ [] -- No exclusions case r of Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) - Just (Left err) -> throwOneError err + Just (Left err) -> throwErrors err Just (Right summary) -> return summary -- | Up until now, GHC has assumed a single compilation target per source file. diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -1162,7 +1162,7 @@ = tempLabelPrefixOrUnderscore <> pprUniqueAlways u pprCLabel dynFlags (AsmTempDerivedLabel l suf) - | sGhcWithNativeCodeGen $ settings dynFlags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags = ptext (asmTempLabelPrefix $ targetPlatform dynFlags) <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u @@ -1170,15 +1170,15 @@ <> ftext suf pprCLabel dynFlags (DynamicLinkerLabel info lbl) - | sGhcWithNativeCodeGen $ settings dynFlags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl pprCLabel dynFlags PicBaseLabel - | sGhcWithNativeCodeGen $ settings dynFlags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags = text "1b" pprCLabel dynFlags (DeadStripPreventer lbl) - | sGhcWithNativeCodeGen $ settings dynFlags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags = {- `lbl` can be temp one but we need to ensure that dsp label will stay @@ -1190,18 +1190,18 @@ <> pprCLabel dynFlags lbl <> text "_dsp" pprCLabel dynFlags (StringLitLabel u) - | sGhcWithNativeCodeGen $ settings dynFlags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags = pprUniqueAlways u <> ptext (sLit "_str") pprCLabel dynFlags lbl = getPprStyle $ \ sty -> - if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty + if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl else pprCLbl lbl maybe_underscore :: DynFlags -> SDoc -> SDoc maybe_underscore dynFlags doc = - if sLeadingUnderscore $ settings dynFlags + if platformMisc_leadingUnderscore $ platformMisc dynFlags then pp_cSEP <> doc else doc diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -531,7 +531,7 @@ | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc , oFFSET_StgFunInfoExtraFwd_arity dflags ) - pc = sPlatformConstants (settings dflags) + pc = platformConstants dflags ----------------------------------------------------------------------------- -- diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -94,7 +94,7 @@ pprTop (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live + = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -43,6 +43,7 @@ import DataCon import PatSyn import HscTypes (CompleteMatch(..)) +import BasicTypes (Boxity(..)) import DsMonad import TcSimplify (tcCheckSatisfiability) @@ -1078,12 +1079,17 @@ TuplePat tys ps boxity -> do tidy_ps <- translatePatVec fam_insts (map unLoc ps) let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) - return [vanillaConPattern tuple_con tys (concat tidy_ps)] + tys' = case boxity of + Boxed -> tys + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + Unboxed -> map getRuntimeRep tys ++ tys + return [vanillaConPattern tuple_con tys' (concat tidy_ps)] SumPat ty p alt arity -> do tidy_p <- translatePat fam_insts (unLoc p) let sum_con = RealDataCon (sumDataCon alt arity) - return [vanillaConPattern sum_con ty tidy_p] + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p] -- -------------------------------------------------------------------------- -- Not supposed to happen diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -541,7 +541,7 @@ | otherwise = text ('a':show n) -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = sLibFFI (settings dflags) && isNothing maybe_target + libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target type_string -- libffi needs to know the result type too: diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -191,10 +191,21 @@ , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (dL->L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) - | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) } - <- concatMap (unLoc . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd + | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ + concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] + + extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty ty = + case dL ty of + -- deriving (forall a. C a {- ^ Doc comment -}) + L l (HsForAllTy{ hst_fvf = ForallInvis + , hst_body = dL->L _ (HsDocTy _ _ doc) }) + -> Just (l, doc) + -- deriving (C a {- ^ Doc comment -}) + L l (HsDocTy _ _ doc) -> Just (l, doc) + _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -115,7 +115,7 @@ modifyMbPLS_ :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO () -modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f +modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f emptyPLS :: DynFlags -> PersistentLinkerState emptyPLS _ = PersistentLinkerState { @@ -343,7 +343,7 @@ -- Add directories to library search paths, this only has an effect -- on Windows. On Unix OSes this function is a NOP. - let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags) + let all_paths = let paths = takeDirectory (fst $ pgm_c dflags) : framework_paths ++ lib_paths_base ++ [ takeDirectory dll | DLLPath dll <- libspecs ] @@ -881,8 +881,8 @@ dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath] -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs hsc_env pls objs = do +dynLoadObjs _ pls [] = return pls +dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do let dflags = hsc_dflags hsc_env let platform = targetPlatform dflags let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] @@ -899,13 +899,13 @@ -- library. ldInputs = concatMap (\l -> [ Option ("-l" ++ l) ]) - (nub $ snd <$> temp_sos pls) + (nub $ snd <$> temp_sos) ++ concatMap (\lp -> [ Option ("-L" ++ lp) , Option "-Xlinker" , Option "-rpath" , Option "-Xlinker" , Option lp ]) - (nub $ fst <$> temp_sos pls) + (nub $ fst <$> temp_sos) ++ concatMap (\lp -> [ Option ("-L" ++ lp) @@ -933,13 +933,13 @@ -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 objs (pkgs_loaded pls) + linkDynLib dflags2 objs pkgs_loaded -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime dflags TFL_GhcSession [soFile] m <- loadDLL hsc_env soFile case m of - Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls } + Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } Just err -> panic ("Loading temp shared object failed: " ++ err) rmDupLinkables :: [Linkable] -- Already loaded diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -1,3 +1,6 @@ +{- +Main functions for .hie file generation +-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,7 +23,6 @@ import Class ( FunDep ) import CoreUtils ( exprType ) import ConLike ( conLikeName ) -import Config ( cProjectVersion ) import Desugar ( deSugarExpr ) import FieldLabel import HsSyn @@ -42,7 +44,6 @@ import qualified Data.Array as A import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC import qualified Data.Map as M import qualified Data.Set as S import Data.Data ( Data, Typeable ) @@ -98,9 +99,7 @@ let Just src_file = ml_hs_file $ ms_location ms src <- liftIO $ BS.readFile src_file return $ HieFile - { hie_version = curHieVersion - , hie_ghc_version = BSC.pack cProjectVersion - , hie_hs_file = src_file + { hie_hs_file = src_file , hie_module = ms_mod ms , hie_types = arr , hie_asts = asts' @@ -479,7 +478,9 @@ in case tyOpt of - _ | skipDesugaring e' -> fallback + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback | otherwise -> do hs_env <- Hsc $ \e w -> return (e,w) (_,mbe) <- liftIO $ deSugarExpr hs_env e diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs --- a/compiler/hieFile/HieBin.hs +++ b/compiler/hieFile/HieBin.hs @@ -1,8 +1,11 @@ +{- +Binary serialization for .hie files. +-} {-# LANGUAGE ScopedTypeVariables #-} -module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where +module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where +import Config ( cProjectVersion ) import GhcPrelude - import Binary import BinIface ( getDictFastString ) import FastMutInt @@ -14,17 +17,23 @@ import PrelInfo import SrcLoc import UniqSupply ( takeUniqFromSupply ) +import Util ( maybeRead ) import Unique import UniqFM import qualified Data.Array as A import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC import Data.List ( mapAccumR ) -import Data.Word ( Word32 ) -import Control.Monad ( replicateM ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) import System.Directory ( createDirectoryIfMissing ) import System.FilePath ( takeDirectory ) +import HieTypes + -- | `Name`'s get converted into `HieName`'s before being written into @.hie@ -- files. See 'toHieName' and 'fromHieName' for logic on how to convert between -- these two types. @@ -63,10 +72,33 @@ initBinMemSize :: Int initBinMemSize = 1024*1024 -writeHieFile :: Binary a => FilePath -> a -> IO () +-- | The header for HIE files - Capital ASCII letters "HIE". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () writeHieFile hie_file_path hiefile = do bh0 <- openBinMem initBinMemSize + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + -- remember where the dictionary pointer will go dict_p_p <- tellBin bh0 put_ bh0 dict_p_p @@ -105,7 +137,7 @@ symtab_map' <- readIORef symtab_map putSymbolTable bh symtab_next' symtab_map' - -- write the dictionary pointer at the fornt of the file + -- write the dictionary pointer at the front of the file dict_p <- tellBin bh putAt bh dict_p_p dict_p seekBin bh dict_p @@ -120,9 +152,86 @@ writeBinMem bh hie_file_path return () -readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache) +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache)) +readHieFileWithVersion readVersion nc file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + (hieFile, nc') <- readHieFileContents bh0 nc + return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) readHieFile nc file = do + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + (hieFile, nc') <- readHieFileContents bh0 nc + return $ (HieFileResult hieVersion ghcVersion hieFile, nc') + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache) +readHieFileContents bh0 nc = do dict <- get_dictionary bh0 diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs --- a/compiler/hieFile/HieDebug.hs +++ b/compiler/hieFile/HieDebug.hs @@ -1,3 +1,6 @@ +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs --- a/compiler/hieFile/HieTypes.hs +++ b/compiler/hieFile/HieTypes.hs @@ -1,3 +1,8 @@ +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -7,6 +12,7 @@ import GhcPrelude +import Config import Binary import FastString ( FastString ) import IfaceType @@ -28,8 +34,8 @@ type Span = RealSrcSpan -- | Current version of @.hie@ files -curHieVersion :: Word8 -curHieVersion = 0 +hieVersion :: Integer +hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer {- | GHC builds up a wealth of information about Haskell source as it compiles it. @@ -48,13 +54,7 @@ interface than the GHC API. -} data HieFile = HieFile - { hie_version :: Word8 - -- ^ version of the HIE format - - , hie_ghc_version :: ByteString - -- ^ Version of GHC that produced this file - - , hie_hs_file :: FilePath + { hie_hs_file :: FilePath -- ^ Initial Haskell source file path , hie_module :: Module @@ -74,11 +74,8 @@ , hie_hs_src :: ByteString -- ^ Raw bytes of the initial Haskell source } - instance Binary HieFile where put_ bh hf = do - put_ bh $ hie_version hf - put_ bh $ hie_ghc_version hf put_ bh $ hie_hs_file hf put_ bh $ hie_module hf put_ bh $ hie_types hf @@ -88,8 +85,6 @@ get bh = HieFile <$> get bh - <*> get bh - <*> get bh <*> get bh <*> get bh <*> get bh diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -155,7 +155,7 @@ -> Stream IO RawCmmGroup () -> IO () outputAsm dflags this_mod location filenm cmm_stream - | sGhcWithNativeCodeGen $ settings dflags + | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags = do ncg_uniqs <- mkSplitUniqSupply 'n' debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) @@ -226,7 +226,7 @@ -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes - | sLibFFI $ settings dflags = "#include \"ffi.h\"\n" + | platformMisc_libFFI $ platformMisc dflags = "#include \"ffi.h\"\n" | otherwise = "" stub_h_file_exists diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -29,6 +29,7 @@ hscPostBackendPhase, getLocation, setModLocation, setDynFlags, runPhase, exeFileName, maybeCreateManifest, + doCpp, linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode ) where @@ -51,7 +52,7 @@ import DynFlags import Panic import Util -import StringBuffer ( hGetStringBuffer ) +import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc @@ -59,10 +60,13 @@ import MonadUtils import Platform import TcRnTypes +import ToolSettings import Hooks import qualified GHC.LanguageExtensions as LangExt import FileCleanup import Ar +import Bag ( unitBag ) +import FastString ( mkFastString ) import Exception import System.Directory @@ -86,17 +90,28 @@ -- of slurping in the OPTIONS pragmas preprocess :: HscEnv - -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> IO (DynFlags, FilePath) -preprocess hsc_env (filename, mb_phase) = - ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either ErrorMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + ghandle handler $ + fmap Right $ + ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) Nothing -- We keep the processed file for the whole session to save on -- duplicated work in ghci. (Temporary TFL_GhcSession) Nothing{-no ModLocation-} []{-no foreign objects-} + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = return $ Left $ unitBag $ + mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -185,6 +200,7 @@ -- handled properly _ <- runPipeline StopLn hsc_env (output_fn, + Nothing, Just (HscOut src_flavour mod_name HscUpdateSig)) (Just basename) @@ -222,6 +238,7 @@ -- We're in --make mode: finish the compilation pipeline. _ <- runPipeline StopLn hsc_env (output_fn, + Nothing, Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) (Just basename) Persistent @@ -319,7 +336,7 @@ LangAsm -> As True -- allow CPP RawObject -> panic "compileForeign: should be unreachable" (_, stub_o) <- runPipeline StopLn hsc_env - (stub_c, Just (RealPhase phase)) + (stub_c, Nothing, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) Nothing{-no ModLocation-} [] @@ -341,7 +358,7 @@ let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env - (empty_stub, Nothing) + (empty_stub, Nothing, Nothing) (Just basename) Persistent (Just location) @@ -368,7 +385,7 @@ = lookupHook linkHook l dflags ghcLink dflags where l LinkInMemory _ _ _ - = if sGhcWithInterpreter $ settings dflags + = if platformMisc_ghcWithInterpreter $ platformMisc dflags then -- Not Linking...(demand linker will do the job) return Succeeded else panicBadLink LinkInMemory @@ -528,7 +545,9 @@ | otherwise = Persistent ( _, out_file) <- runPipeline stop_phase hsc_env - (src, fmap RealPhase mb_phase) Nothing output + (src, Nothing, fmap RealPhase mb_phase) + Nothing + output Nothing{-no ModLocation-} [] return out_file @@ -561,13 +580,15 @@ runPipeline :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) + -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) + -- ^ Pipeline input file name, optional + -- buffer and maybe -x suffix -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) +runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os = do let @@ -619,8 +640,22 @@ ++ input_fn)) HscOut {} -> return () + -- Write input buffer to temp file if requested + input_fn' <- case (start_phase, mb_input_buf) of + (RealPhase real_start_phase, Just input_buf) -> do + let suffix = phaseInputExt real_start_phase + fn <- newTempName dflags TFL_CurrentModule suffix + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + (_, _) -> return input_fn + debugTraceMsg dflags 4 (text "Running the pipeline") - r <- runPipeline' start_phase hsc_env env input_fn + r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os -- If we are compiling a Haskell module, and doing @@ -634,7 +669,7 @@ (text "Running the pipeline again for -dynamic-too") let dflags' = dynamicTooMkDynamicDynFlags dflags hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase hsc_env' env input_fn + _ <- runPipeline' start_phase hsc_env' env input_fn' maybe_loc foreign_os return () return r @@ -1008,8 +1043,11 @@ (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do do buf <- hGetStringBuffer input_fn - (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) - return (Just buf, mod_name, imps, src_imps) + eimps <- getImports dflags buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors errs + Right (src_imps,imps,L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps) -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking @@ -1582,7 +1620,7 @@ linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags - mySettings = settings dflags + toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags output_fn = exeFileName staticLink dflags @@ -1738,7 +1776,7 @@ -- like -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog -- on x86. - ++ (if sLdSupportsCompactUnwind mySettings && + ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && not staticLink && (platformOS platform == OSDarwin) && case platformArch platform of @@ -1762,7 +1800,7 @@ then ["-Wl,-read_only_relocs,suppress"] else []) - ++ (if sLdIsGnuLd mySettings && + ++ (if toolSettings_ldIsGnuLd toolSettings' && not (gopt Opt_WholeArchiveHsLibs dflags) then ["-Wl,--gc-sections"] else []) @@ -1889,7 +1927,7 @@ <$> (Archive <$> mapM loadObj modules) <*> mapM loadAr archives - if sLdIsGnuLd (settings dflags) + if toolSettings_ldIsGnuLd (toolSettings dflags) then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar @@ -2062,15 +2100,15 @@ joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () joinObjectFiles dflags o_files output_fn = do - let mySettings = settings dflags - ldIsGnuLd = sLdIsGnuLd mySettings + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags) ld_r args cc = SysTools.runLink dflags ([ SysTools.Option "-nostdlib", SysTools.Option "-Wl,-r" ] -- See Note [No PIE while linking] in DynFlags - ++ (if sGccSupportsNoPie mySettings + ++ (if toolSettings_ccSupportsNoPie toolSettings' then [SysTools.Option "-no-pie"] else []) @@ -2101,7 +2139,7 @@ -- suppress the generation of the .note.gnu.build-id section, -- which we don't need and sometimes causes ld to emit a -- warning: - ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"] + ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"] | otherwise = [] ccInfo <- getCompilerInfo dflags @@ -2112,7 +2150,7 @@ let o_files_abs = map (\x -> "\"" ++ (cwd x) ++ "\"") o_files writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" ld_r [SysTools.FileOption "" script] ccInfo - else if sLdSupportsFilelist mySettings + else if toolSettings_ldSupportsFilelist toolSettings' then do filelist <- newTempName dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -- ----------------------------------------------------------------------------- -- @@ -10,9 +10,11 @@ -- -- ----------------------------------------------------------------------------- module GhcMake( - depanal, + depanal, depanalPartial, load, load', LoadHowMuch(..), + downsweep, + topSortModuleGraph, ms_home_srcimps, ms_home_imps, @@ -46,7 +48,7 @@ import TcRnMonad ( initIfaceCheck ) import HscMain -import Bag ( listToBag ) +import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) import BasicTypes import Digraph import Exception ( tryIO, gbracket, gfinally ) @@ -80,6 +82,7 @@ import Control.Concurrent.QSem import Control.Exception import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import Data.IORef import Data.List import qualified Data.List as List @@ -119,6 +122,32 @@ -> Bool -- ^ allow duplicate roots -> m ModuleGraph depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots + if isEmptyBag errs + then do + warnMissingHomeModules hsc_env mod_graph + setSession hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + else throwErrors errs + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession let dflags = hsc_dflags hsc_env @@ -138,14 +167,10 @@ mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) excluded_mods allow_dup_roots - mod_summaries <- reportImportErrors mod_summariesE - - let mod_graph = mkModuleGraph mod_summaries - - warnMissingHomeModules hsc_env mod_graph - - setSession hsc_env { hsc_mod_graph = mod_graph } - return mod_graph + let + (errs, mod_summaries) = partitionEithers mod_summariesE + mod_graph = mkModuleGraph mod_summaries + return (unionManyBags errs, mod_graph) -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -184,6 +209,10 @@ is_my_target mod (TargetFile target_file _) | Just mod_file <- ml_hs_file (ms_location mod) = target_file == mod_file || + + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || + -- We can get a file target even if a module name was -- originally specified in a command line because it can -- be converted in guessTarget (by appending .hs/.lhs). @@ -1906,15 +1935,12 @@ <+> quotes (ppr mod)) -reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b] +reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b] reportImportErrors xs | null errs = return oks - | otherwise = throwManyErrors errs + | otherwise = throwErrors $ unionManyBags errs where (errs, oks) = partitionEithers xs -throwManyErrors :: MonadIO m => [ErrMsg] -> m ab -throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs - ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1937,7 +1963,7 @@ -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> IO [Either ErrMsg ModSummary] + -> IO [Either ErrorMessages ModSummary] -- The elts of [ModSummary] all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true -- in which case there can be repeats @@ -1954,11 +1980,11 @@ -- See Note [-fno-code mode] #8025 map1 <- if hscTarget dflags == HscNothing then enableCodeGenForTH - (defaultObjectTarget (settings dflags)) + (defaultObjectTarget dflags) map0 else if hscTarget dflags == HscInterpreted then enableCodeGenForUnboxedTuples - (defaultObjectTarget (settings dflags)) + (defaultObjectTarget dflags) map0 else return map0 return $ concat $ nodeMapElts map1 @@ -1971,13 +1997,13 @@ old_summary_map :: NodeMap ModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO (Either ErrMsg ModSummary) + getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) = do exists <- liftIO $ doesFileExist file - if exists - then Right `fmap` summariseFile hsc_env old_summaries file mb_phase + if exists || isJust maybe_buf + then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ mkPlainErrMsg dflags noSrcSpan $ + else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot @@ -1993,7 +2019,7 @@ -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO () + checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () @@ -2004,11 +2030,11 @@ loop :: [(Located ModuleName,IsBoot)] -- Work list: process these modules - -> NodeMap [Either ErrMsg ModSummary] + -> NodeMap [Either ErrorMessages ModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> IO (NodeMap [Either ErrorMessages ModSummary]) -- The result is the completed NodeMap loop [] done = return done loop ((wanted_mod, is_boot) : ss) done @@ -2037,8 +2063,8 @@ -- and .o file locations to be temporary files. -- See Note [-fno-code mode] enableCodeGenForTH :: HscTarget - -> NodeMap [Either ErrMsg ModSummary] - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenForTH = enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession where @@ -2057,8 +2083,8 @@ -- This is used used in order to load code that uses unboxed tuples -- into GHCi while still allowing some code to be interpreted. enableCodeGenForUnboxedTuples :: HscTarget - -> NodeMap [Either ErrMsg ModSummary] - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenForUnboxedTuples = enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule where @@ -2080,8 +2106,8 @@ -> TempFileLifetime -> TempFileLifetime -> HscTarget - -> NodeMap [Either ErrMsg ModSummary] - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where @@ -2143,7 +2169,7 @@ new_marked_mods = Set.insert ms_mod marked_mods in foldl' go new_marked_mods deps -mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary] +mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] mkRootMap summaries = Map.insertListWith (flip (++)) [ (msKey s, [Right s]) | s <- summaries ] Map.empty @@ -2203,13 +2229,13 @@ -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary + -> IO (Either ErrorMessages ModSummary) -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf +summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file + | Just old_summary <- findSummaryBySourceFile old_summaries src_fn = do let location = ms_location old_summary dflags = hsc_dflags hsc_env @@ -2221,82 +2247,44 @@ -- behaviour. -- return the cached summary if the source didn't change - if ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location NotBoot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - let hie_location = ml_hie_file location - hie_timestamp <- modificationTimeIfExists hie_location - - -- We have to repopulate the Finder's cache because it - -- was flushed before the downsweep. - _ <- liftIO $ addHomeModuleToFinder hsc_env - (moduleName (ms_mod old_summary)) (ms_location old_summary) - - return old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp } - else - new_summary src_timestamp + checkSummaryTimestamp + hsc_env dflags obj_allowed NotBoot (new_summary src_fn) + old_summary location src_timestamp | otherwise = do src_timestamp <- get_src_timestamp - new_summary src_timestamp + new_summary src_fn src_timestamp where get_src_timestamp = case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file + Nothing -> liftIO $ getModificationUTCTime src_fn -- getModificationUTCTime may fail - new_summary src_timestamp = do - let dflags = hsc_dflags hsc_env + new_summary src_fn src_timestamp = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf - let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file + location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps + mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location - return (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_obj_date = obj_timestamp }) + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = NotBoot + , nms_hsc_src = + if isHaskellSigFilename src_fn + then HsigFile + else HsSrcFile + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file @@ -2305,6 +2293,44 @@ [] -> Nothing (x:_) -> Just x +checkSummaryTimestamp + :: HscEnv -> DynFlags -> Bool -> IsBoot + -> (UTCTime -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> UTCTime + -> IO (Either e ModSummary) +checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot new_summary + old_summary location src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location is_boot + else return Nothing + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular serach path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + _ <- addHomeModuleToFinder hsc_env + (moduleName (ms_mod old_summary)) location + + hi_timestamp <- maybeGetIfaceDate dflags location + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + + | otherwise = + -- source changed: re-summarise. + new_summary src_timestamp + -- Summarise a module, and pick up source and timestamp. summariseModule :: HscEnv @@ -2314,7 +2340,7 @@ -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary + -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -2331,11 +2357,13 @@ -- return the cached summary if it hasn't changed. If the -- file has disappeared, we need to call the Finder again. case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t + Just (_,t) -> + Just <$> check_timestamp old_summary location src_fn t Nothing -> do m <- tryIO (getModificationUTCTime src_fn) case m of - Right t -> check_timestamp old_summary location src_fn t + Right t -> + Just <$> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it | otherwise -> ioError e @@ -2343,23 +2371,11 @@ where dflags = hsc_dflags hsc_env - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp dflags) = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - return (Just (Right old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp })) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp + check_timestamp old_summary location src_fn = + checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot + (new_summary location (ms_mod old_summary) src_fn) + old_summary location find_it = do found <- findImportedModule hsc_env wanted_mod Nothing @@ -2367,7 +2383,7 @@ Found location mod | isJust (ml_hs_file location) -> -- Home package - just_found location mod + Just <$> just_found location mod _ -> return Nothing -- Not found @@ -2385,16 +2401,13 @@ -- It might have been deleted since the Finder last found it maybe_t <- modificationTimeIfExists src_fn case maybe_t of - Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn + Nothing -> return $ Left $ noHsFileErr dflags loc src_fn Just t -> new_summary location' mod src_fn t - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf -- NB: Despite the fact that is_boot is a top-level parameter, we -- don't actually know coming into this function what the HscSource @@ -2408,97 +2421,123 @@ _ | isHaskellSigFilename src_fn -> HsigFile | otherwise -> HsSrcFile - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg dflags' mod_loc $ + when (pi_mod_name /= wanted_mod) $ + throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $ + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v - | (k,v) <- ((mod_name, mkHoleModule mod_name) + | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : thisUnitIdInsts dflags) ]) - in throwOneError $ mkPlainErrMsg dflags' mod_loc $ - text "Unexpected signature:" <+> quotes (ppr mod_name) + in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags - then parens (text "Try adding" <+> quotes (ppr mod_name) + then parens (text "Try adding" <+> quotes (ppr pi_mod_name) <+> text "to the" <+> quotes (text "signatures") <+> text "field in your Cabal file.") else parens (text "Try passing -instantiated-with=\"" <> suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr mod_name <> text "> as necessary.") + text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = is_boot + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_timestamp :: UTCTime + , nms_is_boot :: IsBoot + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_obj_allowed :: Bool + , nms_preimps :: PreprocessedImports + } - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + let dflags = hsc_dflags hsc_env - return (Just (Right (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_obj_date = obj_timestamp }))) + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget dflags) + || nms_obj_allowed -- bug #1205 + then getObjTimestamp nms_location nms_is_boot + else return Nothing + hi_timestamp <- maybeGetIfaceDate dflags nms_location + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + required_by_imports <- implicitRequirements hsc_env pi_theimps + + return $ ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + pi_theimps ++ extra_sig_imports ++ required_by_imports + , ms_hs_date = nms_src_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + } + getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot == IsBoot then return Nothing else modificationTimeIfExists (ml_obj_file location) - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,UTCTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - let local_opts = getOptions dflags buf src_fn - - (dflags', leftovers, warns) - <- parseDynamicFilePragma dflags local_opts - checkProcessArgsResult dflags leftovers - handleFlagWarnings dflags' warns - - let needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt LangExt.Cpp dflags' = True - | gopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled") +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [(Maybe FastString, Located ModuleName)] + , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } - return (dflags', src_fn, buf) +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT ErrorMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn + return PreprocessedImports {..} ----------------------------------------------------------------------------- @@ -2545,13 +2584,13 @@ noModError dflags loc wanted_mod err = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages noHsFileErr dflags loc path - = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages moduleNotFoundErr dflags mod - = mkPlainErrMsg dflags noSrcSpan $ + = unitBag $ mkPlainErrMsg dflags noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: DynFlags -> [ModSummary] -> IO () diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs deleted file mode 100644 --- a/compiler/main/HeaderInfo.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - ------------------------------------------------------------------------------ --- --- | Parsing the top of a Haskell source file to get its module name, --- imports and options. --- --- (c) Simon Marlow 2005 --- (c) Lemmih 2006 --- ------------------------------------------------------------------------------ - -module HeaderInfo ( getImports - , mkPrelImports -- used by the renamer too - , getOptionsFromFile, getOptions - , optionsErrorMsgs, - checkProcessArgsResult ) where - -#include "HsVersions.h" - -import GhcPrelude - -import HscTypes -import Parser ( parseHeader ) -import Lexer -import FastString -import HsSyn -import Module -import PrelNames -import StringBuffer -import SrcLoc -import DynFlags -import ErrUtils -import Util -import Outputable -import Pretty () -import Maybes -import Bag ( emptyBag, listToBag, unitBag ) -import MonadUtils -import Exception -import BasicTypes -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import System.IO -import System.IO.Unsafe -import Data.List - ------------------------------------------------------------------------------- - --- | Parse the imports of a source file. --- --- Throws a 'SourceError' if parsing fails. -getImports :: DynFlags - -> StringBuffer -- ^ Parse this. - -> FilePath -- ^ Filename the buffer came from. Used for - -- reporting parse error locations. - -> FilePath -- ^ The original source filename (used for locations - -- in the function result) - -> IO ([(Maybe FastString, Located ModuleName)], - [(Maybe FastString, Located ModuleName)], - Located ModuleName) - -- ^ The source imports, normal imports, and the module name. -getImports dflags buf filename source_filename = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 - case unP parseHeader (mkPState dflags buf loc) of - PFailed pst -> do - -- assuming we're not logging warnings here as per below - throwErrors (getErrorMessages pst dflags) - POk pst rdr_module -> do - let _ms@(_warns, errs) = getMessages pst dflags - -- don't log warnings: they'll be reported when we parse the file - -- for real. See #2500. - ms = (emptyBag, errs) - -- logWarnings warns - if errorsFound dflags ms - then throwIO $ mkSrcErr errs - else - let hsmod = unLoc rdr_module - mb_mod = hsmodName hsmod - imps = hsmodImports hsmod - main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) - 1 1) - mod = mb_mod `orElse` cL main_loc mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports (unLoc mod) main_loc - implicit_prelude imps - convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) - in - return (map convImport src_idecls, - map convImport (implicit_imports ++ ordinary_imps), - mod) - -mkPrelImports :: ModuleName - -> SrcSpan -- Attribute the "import Prelude" to this location - -> Bool -> [LImportDecl GhcPs] - -> [LImportDecl GhcPs] --- Construct the implicit declaration "import Prelude" (or not) --- --- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); --- because the former doesn't even look at Prelude.hi for instance --- declarations, whereas the latter does. -mkPrelImports this_mod loc implicit_prelude import_decls - | this_mod == pRELUDE_NAME - || explicit_prelude_import - || not implicit_prelude - = [] - | otherwise = [preludeImportDecl] - where - explicit_prelude_import - = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing })) - <- import_decls - , unLoc mod == pRELUDE_NAME ] - - preludeImportDecl :: LImportDecl GhcPs - preludeImportDecl - = cL loc $ ImportDecl { ideclExt = noExt, - ideclSourceSrc = NoSourceText, - ideclName = cL loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } - --------------------------------------------------------------- --- Get options --------------------------------------------------------------- - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptionsFromFile :: DynFlags - -> FilePath -- ^ Input file - -> IO [Located String] -- ^ Parsed options, if any. -getOptionsFromFile dflags filename - = Exception.bracket - (openBinaryFile filename ReadMode) - (hClose) - (\handle -> do - opts <- fmap (getOptions' dflags) - (lazyGetToks dflags' filename handle) - seqList opts $ return opts) - where -- We don't need to get haddock doc tokens when we're just - -- getting the options from pragmas, and lazily lexing them - -- correctly is a little tricky: If there is "\n" or "\n-" - -- left at the end of a buffer then the haddock doc may - -- continue past the end of the buffer, despite the fact that - -- we already have an apparently-complete token. - -- We therefore just turn Opt_Haddock off when doing the lazy - -- lex. - dflags' = gopt_unset dflags Opt_Haddock - -blockSize :: Int --- blockSize = 17 -- for testing :-) -blockSize = 1024 - -lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] -lazyGetToks dflags filename handle = do - buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] - lazyLexBuf handle state eof size = do - case unP (lexer False return) state of - POk state' t -> do - -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) - if atEnd (buffer state') && not eof - -- if this token reached the end of the buffer, and we haven't - -- necessarily read up to the end of the file, then the token might - -- be truncated, so read some more of the file and lex it again. - then getMore handle state size - else case unLoc t of - ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof size - return (t : rest) - _ | not eof -> getMore handle state size - | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] - -- parser assumes an ITeof sentinel at the end - - getMore :: Handle -> PState -> Int -> IO [Located Token] - getMore handle state size = do - -- pprTrace "getMore" (text (show (buffer state))) (return ()) - let new_size = size * 2 - -- double the buffer size each time we read a new block. This - -- counteracts the quadratic slowdown we otherwise get for very - -- large module names (#5981) - nextbuf <- hGetStringBufferBlock handle new_size - if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do - newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size - - -getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] -getToks dflags filename buf = lexAll (pragState dflags buf loc) - where - loc = mkRealSrcLoc (mkFastString filename) 1 1 - - lexAll state = case unP (lexer False return) state of - POk _ t@(dL->L _ ITeof) -> [t] - POk state' t -> t : lexAll state' - _ -> [cL (RealSrcSpan (last_loc state)) ITeof] - - --- | Parse OPTIONS and LANGUAGE pragmas of the source file. --- --- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) -getOptions :: DynFlags - -> StringBuffer -- ^ Input Buffer - -> FilePath -- ^ Source filename. Used for location info. - -> [Located String] -- ^ Parsed options. -getOptions dflags buf filename - = getOptions' dflags (getToks dflags filename buf) - --- The token parser is written manually because Happy can't --- return a partial result when it encounters a lexer error. --- We want to extract options before the buffer is passed through --- CPP, so we can't use the same trick as 'getImports'. -getOptions' :: DynFlags - -> [Located Token] -- Input buffer - -> [Located String] -- Options. -getOptions' dflags toks - = parseToks toks - where - parseToks (open:close:xs) - | IToptions_prag str <- unLoc open - , ITclose_prag <- unLoc close - = case toArgs str of - Left _err -> optionsParseError str dflags $ -- #15053 - combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (cL (getLoc open)) args ++ parseToks xs - parseToks (open:close:xs) - | ITinclude_prag str <- unLoc open - , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ - parseToks xs - parseToks (open:close:xs) - | ITdocOptions str <- unLoc open - , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] - ++ parseToks xs - parseToks (open:xs) - | ITlanguage_prag <- unLoc open - = parseLanguage xs - parseToks (comment:xs) -- Skip over comments - | isComment (unLoc comment) - = parseToks xs - parseToks _ = [] - parseLanguage ((dL->L loc (ITconid fs)):rest) - = checkExtension dflags (cL loc fs) : - case rest of - (dL->L _loc ITcomma):more -> parseLanguage more - (dL->L _loc ITclose_prag):more -> parseToks more - (dL->L loc _):_ -> languagePragParseError dflags loc - [] -> panic "getOptions'.parseLanguage(1) went past eof token" - parseLanguage (tok:_) - = languagePragParseError dflags (getLoc tok) - parseLanguage [] - = panic "getOptions'.parseLanguage(2) went past eof token" - - isComment :: Token -> Bool - isComment c = - case c of - (ITlineComment {}) -> True - (ITblockComment {}) -> True - (ITdocCommentNext {}) -> True - (ITdocCommentPrev {}) -> True - (ITdocCommentNamed {}) -> True - (ITdocSection {}) -> True - _ -> False - ------------------------------------------------------------------------------ - --- | Complain about non-dynamic flags in OPTIONS pragmas. --- --- Throws a 'SourceError' if the input list is non-empty claiming that the --- input flags are unknown. -checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () -checkProcessArgsResult dflags flags - = when (notNull flags) $ - liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (dL->L loc flag) - = mkPlainErrMsg dflags loc $ - (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> - text flag) - ------------------------------------------------------------------------------ - -checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (dL->L l ext) --- Checks if a given extension is valid, and if so returns --- its corresponding flag. Otherwise it throws an exception. - = let ext' = unpackFS ext in - if ext' `elem` supportedLanguagesAndExtensions - then cL l ("-X"++ext') - else unsupportedExtnError dflags l ext' - -languagePragParseError :: DynFlags -> SrcSpan -> a -languagePragParseError dflags loc = - throwErr dflags loc $ - vcat [ text "Cannot parse LANGUAGE pragma" - , text "Expecting comma-separated list of language options," - , text "each starting with a capital letter" - , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] - -unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a -unsupportedExtnError dflags loc unsup = - throwErr dflags loc $ - text "Unsupported extension: " <> text unsup $$ - if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) - where - suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions - - -optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs dflags unhandled_flags flags_lines _filename - = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines :: [Located String] - unhandled_flags_lines = [ cL l f - | f <- unhandled_flags - , (dL->L l f') <- flags_lines - , f == f' ] - mkMsg (dL->L flagSpan flag) = - ErrUtils.mkPlainErrMsg dflags flagSpan $ - text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag - -optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 -optionsParseError str dflags loc = - throwErr dflags loc $ - vcat [ text "Error while parsing OPTIONS_GHC pragma." - , text "Expecting whitespace-separated list of GHC options." - , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" - , text ("Input was: " ++ show str) ] - -throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 -throwErr dflags loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -174,7 +174,7 @@ import HieAst ( mkHieFile ) import HieTypes ( getAsts, hie_asts ) -import HieBin ( readHieFile, writeHieFile ) +import HieBin ( readHieFile, writeHieFile , hie_file_result) import HieDebug ( diffFile, validateScopes ) #include "HsVersions.h" @@ -434,7 +434,7 @@ -- Roundtrip testing nc <- readIORef $ hsc_NC hs_env (file', _) <- readHieFile nc out_file - case diffFile hieFile file' of + case diffFile hieFile (hie_file_result file') of [] -> putMsg dflags $ text "Got no roundtrip errors" xs -> do diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -49,6 +49,7 @@ import Util import DynFlags import Fingerprint +import ToolSettings import System.FilePath import System.IO @@ -282,70 +283,84 @@ ghcDebugged <- getBooleanSetting "Use Debugging" ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw" - return $ Settings { - sTargetPlatform = platform, - sTmpDir = normalise tmpdir, - sGhcUsagePath = ghc_usage_msg_path, - sGhciUsagePath = ghci_usage_msg_path, - sToolDir = mtool_dir, - sTopDir = top_dir, - sRawSettings = mySettings, - sExtraGccViaCFlags = words myExtraGccViaCFlags, - sSystemPackageConfig = pkgconfig_path, - sLdSupportsCompactUnwind = ldSupportsCompactUnwind, - sLdSupportsBuildId = ldSupportsBuildId, - sLdSupportsFilelist = ldSupportsFilelist, - sLdIsGnuLd = ldIsGnuLd, - sGccSupportsNoPie = gccSupportsNoPie, - sProgramName = "ghc", - sProjectVersion = cProjectVersion, - sPgm_L = unlit_path, - sPgm_P = (cpp_prog, cpp_args), - sPgm_F = "", - sPgm_c = (gcc_prog, gcc_args), - sPgm_a = (as_prog, as_args), - sPgm_l = (ld_prog, ld_args), - sPgm_dll = (mkdll_prog,mkdll_args), - sPgm_T = touch_path, - sPgm_windres = windres_path, - sPgm_libtool = libtool_path, - sPgm_ar = ar_path, - sPgm_ranlib = ranlib_path, - sPgm_lo = (lo_prog,[]), - sPgm_lc = (lc_prog,[]), - sPgm_lcc = (lcc_prog,[]), - sPgm_i = iserv_prog, - sOpt_L = [], - sOpt_P = [], - sOpt_P_fingerprint = fingerprint0, - sOpt_F = [], - sOpt_c = [], - sOpt_cxx = [], - sOpt_a = [], - sOpt_l = [], - sOpt_windres = [], - sOpt_lcc = [], - sOpt_lo = [], - sOpt_lc = [], - sOpt_i = [], - sPlatformConstants = platformConstants, + return $ Settings + { sGhcNameVersion = GhcNameVersion + { ghcNameVersion_programName = "ghc" + , ghcNameVersion_projectVersion = cProjectVersion + } - sTargetPlatformString = targetPlatformString, - sIntegerLibrary = integerLibrary, - sIntegerLibraryType = integerLibraryType, - sGhcWithInterpreter = ghcWithInterpreter, - sGhcWithNativeCodeGen = ghcWithNativeCodeGen, - sGhcWithSMP = ghcWithSMP, - sGhcRTSWays = ghcRTSWays, - sTablesNextToCode = tablesNextToCode, - sLeadingUnderscore = leadingUnderscore, - sLibFFI = useLibFFI, - sGhcThreaded = ghcThreaded, - sGhcDebugged = ghcDebugged, - sGhcRtsWithLibdw = ghcRtsWithLibdw - } + , sFileSettings = FileSettings + { fileSettings_tmpDir = normalise tmpdir + , fileSettings_ghcUsagePath = ghc_usage_msg_path + , fileSettings_ghciUsagePath = ghci_usage_msg_path + , fileSettings_toolDir = mtool_dir + , fileSettings_topDir = top_dir + , fileSettings_systemPackageConfig = pkgconfig_path + } + , sToolSettings = ToolSettings + { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind + , toolSettings_ldSupportsBuildId = ldSupportsBuildId + , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldIsGnuLd = ldIsGnuLd + , toolSettings_ccSupportsNoPie = gccSupportsNoPie + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = (gcc_prog, gcc_args) + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) + , toolSettings_pgm_T = touch_path + , toolSettings_pgm_windres = windres_path + , toolSettings_pgm_libtool = libtool_path + , toolSettings_pgm_ar = ar_path + , toolSettings_pgm_ranlib = ranlib_path + , toolSettings_pgm_lo = (lo_prog,[]) + , toolSettings_pgm_lc = (lc_prog,[]) + , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_i = iserv_prog + , toolSettings_opt_L = [] + , toolSettings_opt_P = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_F = [] + , toolSettings_opt_c = [] + , toolSettings_opt_cxx = [] + , toolSettings_opt_a = [] + , toolSettings_opt_l = [] + , toolSettings_opt_windres = [] + , toolSettings_opt_lcc = [] + , toolSettings_opt_lo = [] + , toolSettings_opt_lc = [] + , toolSettings_opt_i = [] + + , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags + } + + , sTargetPlatform = platform + , sPlatformMisc = PlatformMisc + { platformMisc_targetPlatformString = targetPlatformString + , platformMisc_integerLibrary = integerLibrary + , platformMisc_integerLibraryType = integerLibraryType + , platformMisc_ghcWithInterpreter = ghcWithInterpreter + , platformMisc_ghcWithNativeCodeGen = ghcWithNativeCodeGen + , platformMisc_ghcWithSMP = ghcWithSMP + , platformMisc_ghcRTSWays = ghcRTSWays + , platformMisc_tablesNextToCode = tablesNextToCode + , platformMisc_leadingUnderscore = leadingUnderscore + , platformMisc_libFFI = useLibFFI + , platformMisc_ghcThreaded = ghcThreaded + , platformMisc_ghcDebugged = ghcDebugged + , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw + } + + , sPlatformConstants = platformConstants + + , sRawSettings = mySettings + } + + {- Note [Windows stack usage] See: #8870 (and #8834 for related info) and #12186 @@ -418,10 +433,10 @@ -- against libHSrts, then both end up getting loaded, -- and things go wrong. We therefore link the libraries -- with the same RTS flags that we link GHC with. - dflags1 = if sGhcThreaded $ settings dflags0 + dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0 then addWay' WayThreaded dflags0 else dflags0 - dflags2 = if sGhcDebugged $ settings dflags1 + dflags2 = if platformMisc_ghcDebugged $ platformMisc dflags1 then addWay' WayDebug dflags1 else dflags1 dflags = updateWays dflags2 diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -135,13 +135,14 @@ mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc hsc_env - TcGblEnv{ tcg_exports = exports, - tcg_type_env = type_env, -- just for the Ids - tcg_tcs = tcs, - tcg_patsyns = pat_syns, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_mod = this_mod + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_sigs, + tcg_mod = this_mod } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. @@ -156,13 +157,13 @@ ; dfun_ids = map instanceDFunId insts' ; type_env' = extendTypeEnvWithIds type_env2 dfun_ids } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports - , md_complete_sigs = [] + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_sigs = complete_sigs }) } where diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -949,6 +949,7 @@ , BCC LE cmp_lo Nothing , CMPL II32 x_lo (RIReg y_lo) , BCC ALWAYS end_lbl Nothing + , NEWBLOCK cmp_lo , CMPL II32 y_lo (RIReg x_lo) , BCC ALWAYS end_lbl Nothing diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -98,7 +98,7 @@ , STU fmt r0 (AddrRegReg sp tmp) ] where - fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8) + fmt = intFormat $ widthFromBytes (platformWordSize platform) zero = ImmInt 0 tmp = tmpReg platform immAmount = ImmInt amount diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module Specialise ( specProgram, specUnfolding ) where #include "HsVersions.h" @@ -25,13 +26,13 @@ import CoreSyn import Rules import CoreOpt ( collectBindersPushingCo ) -import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkCast ) +import CoreUtils ( exprIsTrivial, mkCast, exprType ) import CoreFVs import CoreArity ( etaExpandToJoinPointRule ) import UniqSupply import Name import MkId ( voidArgId, voidPrimId ) -import Maybes ( catMaybes, isJust ) +import Maybes ( mapMaybe, isJust ) import MonadUtils ( foldlM ) import BasicTypes import HscTypes @@ -42,6 +43,7 @@ import FastString import State import UniqDFM +import TyCoRep (TyCoBinder (..)) import Control.Monad import qualified Control.Monad.Fail as MonadFail @@ -631,6 +633,190 @@ See #10491 -} +-- | An argument that we might want to specialise. +-- See Note [Specialising Calls] for the nitty gritty details. +data SpecArg + = + -- | Type arguments that should be specialised, due to appearing + -- free in the type of a 'SpecDict'. + SpecType Type + -- | Type arguments that should remain polymorphic. + | UnspecType + -- | Dictionaries that should be specialised. + | SpecDict DictExpr + -- | Value arguments that should not be specialised. + | UnspecArg + +instance Outputable SpecArg where + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr UnspecType = text "UnspecType" + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecArg = text "UnspecArg" + +getSpecDicts :: [SpecArg] -> [DictExpr] +getSpecDicts = mapMaybe go + where + go (SpecDict d) = Just d + go _ = Nothing + +getSpecTypes :: [SpecArg] -> [Type] +getSpecTypes = mapMaybe go + where + go (SpecType t) = Just t + go _ = Nothing + +isUnspecArg :: SpecArg -> Bool +isUnspecArg UnspecArg = True +isUnspecArg UnspecType = True +isUnspecArg _ = False + +isValueArg :: SpecArg -> Bool +isValueArg UnspecArg = True +isValueArg (SpecDict _) = True +isValueArg _ = False + +-- | Given binders from an original function 'f', and the 'SpecArg's +-- corresponding to its usage, compute everything necessary to build +-- a specialisation. +-- +-- We will use a running example. Consider the function +-- +-- foo :: forall a b. Eq a => Int -> blah +-- foo @a @b dEqA i = blah +-- +-- which is called with the 'CallInfo' +-- +-- [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg] +-- +-- We'd eventually like to build the RULE +-- +-- RULE "SPEC foo @T1 _" +-- forall @a @b (dEqA' :: Eq a). +-- foo @T1 @b dEqA' = $sfoo @b +-- +-- and the specialisation '$sfoo' +-- +-- $sfoo :: forall b. Int -> blah +-- $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah +-- +-- The cases for 'specHeader' below are presented in the same order as this +-- running example. The result of 'specHeader' for this example is as follows: +-- +-- ( -- Returned arguments +-- env + [a -> T1, deqA -> dEqA'] +-- , [] +-- +-- -- RULE helpers +-- , [b, dx', i] +-- , [T1, b, dx', i] +-- +-- -- Specialised function helpers +-- , [b, i] +-- , [dx] +-- , [T1, b, dx_spec, i] +-- ) +specHeader + :: SpecEnv + -> [CoreBndr] -- The binders from the original function 'f' + -> [SpecArg] -- From the CallInfo + -> SpecM ( -- Returned arguments + SpecEnv -- Substitution to apply to the body of 'f' + , [CoreBndr] -- All the remaining unspecialised args from the original function 'f' + + -- RULE helpers + , [CoreBndr] -- Binders for the RULE + , [CoreArg] -- Args for the LHS of the rule + + -- Specialised function helpers + , [CoreBndr] -- Binders for $sf + , [DictBind] -- Auxiliary dictionary bindings + , [CoreExpr] -- Specialised arguments for unfolding + ) + +-- We want to specialise on type 'T1', and so we must construct a substitution +-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding +-- details. +specHeader env (bndr : bndrs) (SpecType t : args) + = do { let env' = extendTvSubstList env [(bndr, t)] + ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( env'' + , unused_bndrs + , rule_bs + , Type t : rule_es + , bs' + , dx + , Type t : spec_args + ) + } + +-- Next we have a type that we don't want to specialise. We need to perform +-- a substitution on it (in case the type refers to 'a'). Additionally, we need +-- to produce a binder, LHS argument and RHS argument for the resulting rule, +-- /and/ a binder for the specialised body. +specHeader env (bndr : bndrs) (UnspecType : args) + = do { let (env', bndr') = substBndr env bndr + ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( env'' + , unused_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- Next we want to specialise the 'Eq a' dict away. We need to construct +-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for +-- the nitty-gritty), as a LHS rule and unfolding details. +specHeader env (bndr : bndrs) (SpecDict d : args) + = do { inst_dict_id <- newDictBndr env bndr + ; let (rhs_env2, dx_binds, spec_dict_args') + = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id] + ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader rhs_env2 bndrs args + ; pure ( env' + , unused_bndrs + -- See Note [Evidence foralls] + , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs + , varToCoreExpr inst_dict_id : rule_es + , bs' + , dx_binds ++ dx + , spec_dict_args' ++ spec_args + ) + } + +-- Finally, we have the unspecialised argument 'i'. We need to produce +-- a binder, LHS and RHS argument for the RULE, and a binder for the +-- specialised body. +-- +-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is +-- why 'i' doesn't appear in our RULE above. But we have no guarantee that +-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so +-- this case must be here. +specHeader env (bndr : bndrs) (UnspecArg : args) + = do { let (env', bndr') = substBndr env bndr + ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args) + <- specHeader env' bndrs args + ; pure ( env'' + , unused_bndrs + , bndr' : rule_bs + , varToCoreExpr bndr' : rule_es + , bndr' : bs' + , dx + , varToCoreExpr bndr' : spec_args + ) + } + +-- Return all remaining binders from the original function. These have the +-- invariant that they should all correspond to unspecialised arguments, so +-- it's safe to stop processing at this point. +specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], []) +specHeader env [] _ = pure (env, [], [], [], [], [], []) + + -- | Specialise a set of calls to imported bindings specImports :: DynFlags -> Module @@ -1171,8 +1357,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs -- The first case is the interesting one - | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas - && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args + | callSpecArity pis <= fn_arity -- See Note [Specialisation Must Preserve Sharing] && notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn)) -- Don't specialise NOINLINE things @@ -1193,15 +1378,14 @@ -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) where - _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars - , ppr rhs_bndrs, ppr n_dicts + _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs , ppr (idInlineActivation fn) ] fn_type = idType fn fn_arity = idArity fn fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - (tyvars, theta, _) = tcSplitSigmaTy fn_type - n_tyvars = length tyvars + pis = fst $ splitPiTys fn_type + theta = getTheta pis n_dicts = length theta inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag @@ -1212,10 +1396,7 @@ (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] - (rhs_tyvars, rhs_bndrs1) = span isTyVar rhs_bndrs - (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1 - body = mkLams rhs_bndrs2 rhs_body - -- Glue back on the non-dict lambdas + rhs_tyvars = filter isTyVar rhs_bndrs in_scope = CoreSubst.substInScope (se_subst env) @@ -1227,59 +1408,19 @@ -- NB: we look both in the new_rules (generated by this invocation -- of specCalls), and in existing_rules (passed in to specCalls) - mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] - mk_ty_args [] poly_tvs - = ASSERT( null poly_tvs ) [] - mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) - = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs - mk_ty_args (Just ty : call_ts) poly_tvs - = Type ty : mk_ty_args call_ts poly_tvs - mk_ty_args (Nothing : _) [] = panic "mk_ty_args" - ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: SpecInfo -- Accumulating parameter -> CallInfo -- Call instance -> SpecM SpecInfo spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) - (CI { ci_key = CallKey call_ts, ci_args = call_ds }) - = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts ) - - -- Suppose f's defn is f = /\ a b c -> \ d1 d2 -> rhs - -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2] - - -- Construct the new binding - -- f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs) - -- PLUS the rule - -- RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b - -- In the rule, d1' and d2' are just wildcards, not used in the RHS - -- PLUS the usage-details - -- { d1' = dx1; d2' = dx2 } - -- where d1', d2' are cloned versions of d1,d2, with the type substitution - -- applied. These auxiliary bindings just avoid duplication of dx1, dx2 - -- - -- Note that the substitution is applied to the whole thing. - -- This is convenient, but just slightly fragile. Notably: - -- * There had better be no name clashes in a/b/c - do { let - -- poly_tyvars = [b] in the example above - -- spec_tyvars = [a,c] - -- ty_args = [t1,b,t3] - spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] - env1 = extendTvSubstList env spec_tv_binds - (rhs_env, poly_tyvars) = substBndrs env1 - [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] - - -- Clone rhs_dicts, including instantiating their types - ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids - ; let (rhs_env2, dx_binds, spec_dict_args) - = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids - ty_args = mk_ty_args call_ts poly_tyvars - ev_args = map varToCoreExpr inst_dict_ids -- ev_args, ev_bndrs: - ev_bndrs = exprsFreeIdsList ev_args -- See Note [Evidence foralls] - rule_args = ty_args ++ ev_args - rule_bndrs = poly_tyvars ++ ev_bndrs + (CI { ci_key = call_args, ci_arity = call_arity }) + = ASSERT(call_arity <= fn_arity) + -- See Note [Specialising Calls] + do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args) + <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args + ; let rhs_body' = mkLams unused_bndrs rhs_body ; dflags <- getDynFlags ; if already_covered dflags rules_acc rule_args then return spec_acc @@ -1288,25 +1429,28 @@ -- , ppr dx_binds ]) $ do { -- Figure out the type of the specialised function - let body_ty = applyTypeToArgs rhs fn_type rule_args - (lam_args, app_args) -- Add a dummy argument if body_ty is unlifted + let body = mkLams unspec_bndrs rhs_body' + body_ty = substTy rhs_env2 $ exprType body + (lam_extra_args, app_args) -- See Note [Specialisations Must Be Lifted] | isUnliftedType body_ty -- C.f. WwLib.mkWorkerArgs , not (isJoinId fn) - = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId]) - | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkLamTypes lam_args body_ty + = ([voidArgId], unspec_bndrs ++ [voidPrimId]) + | otherwise = ([], unspec_bndrs) join_arity_change = length app_args - length rule_args spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn = Just (orig_join_arity + join_arity_change) | otherwise = Nothing + ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body) + ; let spec_id_ty = exprType spec_rhs ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity - ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body) ; this_mod <- getModule ; let -- The rule to put in the function's specialisation is: - -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b + -- forall x @b d1' d2'. + -- f x @T1 @b @T2 d1' d2' = f1 x @b + -- See Note [Specialising Calls] herald = case mb_mod of Nothing -- Specialising local fn -> text "SPEC" @@ -1315,7 +1459,7 @@ rule_name = mkFastString $ showSDoc dflags $ herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (map ppr_call_key_ty call_ts) + <+> hsep (mapMaybe ppr_call_key_ty call_args) -- This name ends up in interface files, so use occNameString. -- Otherwise uniques end up there, making builds -- less deterministic (See #4012 comment:61 ff) @@ -1338,6 +1482,7 @@ Nothing -> rule_wout_eta -- Add the { d1' = dx1; d2' = dx2 } usage stuff + -- See Note [Specialising Calls] spec_uds = foldr consDictBind rhs_uds dx_binds -------------------------------------- @@ -1352,11 +1497,9 @@ = (inl_prag { inl_inline = NoUserInline }, noUnfolding) | otherwise - = (inl_prag, specUnfolding dflags poly_tyvars spec_app - arity_decrease fn_unf) + = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf) - arity_decrease = length spec_dict_args - spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args + spec_app e = e `mkApps` spec_args -------------------------------------- -- Adding arity information just propagates it a bit faster @@ -1368,13 +1511,116 @@ `setIdUnfolding` spec_unf `asJoinId_maybe` spec_join_arity - ; return ( spec_rule : rules_acc + _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty + , ppr rhs_bndrs, ppr call_args + , ppr spec_rule + ] + + ; -- pprTrace "spec_call: rule" _rule_trace_doc + return ( spec_rule : rules_acc , (spec_f_w_arity, spec_rhs) : pairs_acc , spec_uds `plusUDs` uds_acc ) } } -{- Note [Account for casts in binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function: + + f :: forall a. Eq a => a -> blah + f = + if expensive + then f1 + else f2 + +As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' +at 'Int', eg: + + $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) + + RULE "SPEC f" + forall (d :: Eq Int). + f Int _ = $sfIntf + +We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! + +To avoid this, we only generate specialisations for functions whose arity is +enough to bind all of the arguments we need to specialise. This ensures our +specialised functions don't do any work before receiving all of their dicts, +and thus avoids the 'f' case above. + +Note [Specialisations Must Be Lifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function 'f': + + f = forall a. Eq a => Array# a + +used like + + case x of + True -> ...f @Int dEqInt... + False -> 0 + +Naively, we might generate an (expensive) specialisation + + $sfInt :: Array# Int + +even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to +the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to +preserve laziness. + +Note [Specialising Calls] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a function: + + f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux + f = \x -> /\ a b c -> \d1 d2 bar -> rhs + +and suppose it is called at: + + f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar + +This call is described as a 'CallInfo' whose 'ci_key' is + + [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1 + , SpecDict dFooT3, UnspecArg ] + +Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'? +Because we must specialise the function on type variables that appear +free in its *dictionary* arguments; but not on type variables that do not +appear in any dictionaries, i.e. are fully polymorphic. + +Because this call has dictionaries applied, we'd like to specialise +the call on any type argument that appears free in those dictionaries. +In this case, those are (a ~ T1, c ~ T3). + +As a result, we'd like to generate a function: + + $sf :: Int -> forall b. Bar -> Qux + $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs) + +Note that the substitution is applied to the whole thing. This is +convenient, but just slightly fragile. Notably: + * There had better be no name clashes in a/b/c + +We must construct a rewrite rule: + + RULE "SPEC f @T1 _ @T3" + forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3). + f x @T1 @b @T3 d1' d2' = $sf x @b + +In the rule, d1' and d2' are just wildcards, not used in the RHS. Note +additionally that 'bar' isn't captured by this rule --- we bind only +enough etas in order to capture all of the *specialised* arguments. + +Finally, we must also construct the usage-details + + { d1' = dx1; d2' = dx2 } + +where d1', d2' are cloned versions of d1,d2, with the type substitution +applied. These auxiliary bindings just avoid duplication of dx1, dx2. + +Note [Account for casts in binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f :: Eq a => a -> IO () {-# INLINABLE f @@ -1888,16 +2134,14 @@ -- These dups are eliminated by already_covered in specCalls data CallInfo - = CI { ci_key :: CallKey -- Type arguments - , ci_args :: [DictExpr] -- Dictionary arguments - , ci_fvs :: VarSet -- Free vars of the ci_key and ci_args + = CI { ci_key :: [SpecArg] -- All arguments + , ci_arity :: Int -- The number of variables necessary to bind + -- all of the specialised arguments + , ci_fvs :: VarSet -- Free vars of the ci_key -- call (including tyvars) -- [*not* include the main id itself, of course] } -newtype CallKey = CallKey [Maybe Type] - -- Nothing => unconstrained type argument - type DictExpr = CoreExpr ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet @@ -1911,16 +2155,15 @@ pprCallInfo fn (CI { ci_key = key }) = ppr fn <+> ppr key -ppr_call_key_ty :: Maybe Type -> SDoc -ppr_call_key_ty Nothing = char '_' -ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty - -instance Outputable CallKey where - ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts)) +ppr_call_key_ty :: SpecArg -> Maybe SDoc +ppr_call_key_ty (SpecType ty) = Just $ char '@' <+> pprParendType ty +ppr_call_key_ty UnspecType = Just $ char '_' +ppr_call_key_ty (SpecDict _) = Nothing +ppr_call_key_ty UnspecArg = Nothing instance Outputable CallInfo where - ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs }) - = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ]) + ppr (CI { ci_key = key, ci_fvs = fvs }) + = text "CI" <> braces (hsep [ fsep (mapMaybe ppr_call_key_ty key), ppr fvs ]) unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 @@ -1939,17 +2182,29 @@ callInfoFVs (CIS _ call_info) = foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info +computeArity :: [SpecArg] -> Int +computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg + +callSpecArity :: [TyCoBinder] -> Int +callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder + +getTheta :: [TyCoBinder] -> [PredType] +getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) + + ------------------------------------------------------------ -singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails -singleCall id tys dicts +singleCall :: Id -> [SpecArg] -> UsageDetails +singleCall id args = MkUD {ud_binds = emptyBag, ud_calls = unitDVarEnv id $ CIS id $ - unitBag (CI { ci_key = CallKey tys - , ci_args = dicts + unitBag (CI { ci_key = args -- used to be tys + , ci_arity = computeArity args , ci_fvs = call_fvs }) } where + tys = getSpecTypes args + dicts = getSpecDicts args call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs - tys_fvs = tyCoVarsOfTypes (catMaybes tys) + tys_fvs = tyCoVarsOfTypes tys -- The type args (tys) are guaranteed to be part of the dictionary -- types, because they are just the constrained types, -- and the dictionary is therefore sure to be bound @@ -1973,8 +2228,8 @@ = emptyUDs | not (all type_determines_value theta) - || not (spec_tys `lengthIs` n_tyvars) - || not ( dicts `lengthIs` n_dicts) + || not (computeArity ci_key <= idArity f) + || not (length dicts == length theta) || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] -- See also Note [Specialisations already covered] = -- pprTrace "mkCallUDs: discarding" _trace_doc @@ -1982,27 +2237,28 @@ | otherwise = -- pprTrace "mkCallUDs: keeping" _trace_doc - singleCall f spec_tys dicts + singleCall f ci_key where - _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts - , ppr (map (interestingDict env) dicts)] - (tyvars, theta, _) = tcSplitSigmaTy (idType f) - constrained_tyvars = tyCoVarsOfTypes theta - n_tyvars = length tyvars - n_dicts = length theta - - spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args] - dicts = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)] + _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)] + pis = fst $ splitPiTys $ idType f + theta = getTheta pis + constrained_tyvars = tyCoVarsOfTypes theta - -- ignores Coercion arguments - type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)] - type_zip tvs (Coercion _ : args) = type_zip tvs args - type_zip (tv:tvs) (Type ty : args) = (tv, ty) : type_zip tvs args - type_zip _ _ = [] + ci_key :: [SpecArg] + ci_key = fmap (\(t, a) -> + case t of + Named (binderVar -> tyVar) + | tyVar `elemVarSet` constrained_tyvars + -> case a of + Type ty -> SpecType ty + _ -> pprPanic "ci_key" $ ppr a + | otherwise + -> UnspecType + Anon InvisArg _ -> SpecDict a + Anon VisArg _ -> UnspecArg + ) $ zip pis args - mk_spec_ty tyvar ty - | tyvar `elemVarSet` constrained_tyvars = Just ty - | otherwise = Nothing + dicts = getSpecDicts ci_key want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) -- For imported things, we gather call instances if diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -768,14 +768,14 @@ -- declaration. The returned Pair includes invisible vars followed by visible ones unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet -- INVARIANT: [Bool] list contains at least one True value --- See Note [Verifying injectivity annotation]. This function implements fourth --- check described there. +-- See Note [Verifying injectivity annotation] in FamInstEnv. +-- This function implements check (4) described there. -- In theory, instead of implementing this whole check in this way, we could -- attempt to unify equation with itself. We would reject exactly the same -- equations but this method gives us more precise error messages by returning -- precise names of variables that are not mentioned in the RHS. unusedInjTvsInRHS tycon injList lhs rhs = - (`minusVarSet` injRhsVars) <$> injLHSVars + (`minusVarSet` injRhsVars) <$> injLhsVars where inj_pairs :: [(Type, ArgFlag)] -- All the injective arguments, paired with their visibility @@ -789,7 +789,7 @@ invis_vars = tyCoVarsOfTypes invis_lhs Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs - injLHSVars + injLhsVars = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars') vis_vars @@ -813,7 +813,7 @@ = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v) injTyVarsOfType (TyConApp tc tys) | isTypeFamilyTyCon tc - = case tyConInjectivityInfo tc of + = case tyConInjectivityInfo tc of NotInjective -> emptyVarSet Injective inj -> injTyVarsOfTypes (filterByList inj tys) | otherwise @@ -835,8 +835,7 @@ -- | Is type headed by a type family application? isTFHeaded :: Type -> Bool --- See Note [Verifying injectivity annotation]. This function implements third --- check described there. +-- See Note [Verifying injectivity annotation], case 3. isTFHeaded ty | Just ty' <- coreView ty = isTFHeaded ty' isTFHeaded ty | (TyConApp tc args) <- ty @@ -848,8 +847,7 @@ -- | If a RHS is a bare type variable return a set of LHS patterns that are not -- bare type variables. bareTvInRHSViolated :: [Type] -> Type -> [Type] --- See Note [Verifying injectivity annotation]. This function implements second --- check described there. +-- See Note [Verifying injectivity annotation], case 2. bareTvInRHSViolated pats rhs | isTyVarTy rhs = filter (not . isTyVarTy) pats bareTvInRHSViolated _ _ = [] diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -64,7 +64,6 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad -import Data.Maybe -- Defines a binding isForeignImport :: LForeignDecl name -> Bool @@ -251,8 +250,7 @@ ; let -- Drop the foralls before inspecting the -- structure of the foreign type. - (bndrs, res_ty) = tcSplitPiTys norm_sig_ty - arg_tys = mapMaybe binderRelevantType_maybe bndrs + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) id = mkLocalId nm sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, @@ -424,10 +422,9 @@ checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty return (CExport (L l (CExportStatic esrc str cconv')) src) where - -- Drop the foralls before inspecting n + -- Drop the foralls before inspecting -- the structure of the foreign type. - (bndrs, res_ty) = tcSplitPiTys sig_ty - arg_tys = mapMaybe binderRelevantType_maybe bndrs + (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty) {- ************************************************************************ @@ -457,6 +454,11 @@ | Just (_, res_ty) <- tcSplitIOType_maybe ty = -- Got an IO result type, that's always fine! check (pred_res_ty res_ty) (illegalForeignTyErr result) + + -- We disallow nested foralls in foreign types + -- (at least, for the time being). See #16702. + | tcIsForAllTy ty + = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall") -- Case for non-IO result type with FFI Import | not non_io_result_ok diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -516,21 +516,30 @@ ty = hfType hf matches = hfMatches hf wrap = hfWrap hf - tyApp = sep $ map ((text "@" <>) . pprParendType) wrap + tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars wrap + where pprArg b arg = case binderArgFlag b of + Specified -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + Inferred -> empty + Required -> pprPanic "pprHoleFit: bad Required" + (ppr b <+> ppr arg) tyAppVars = sep $ punctuate comma $ - map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $ - zip vars wrap + zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> + text "~" <+> pprParendType t) + vars wrap + + vars = unwrapTypeVars ty where - vars = unwrapTypeVars ty -- Attempts to get all the quantified type variables in a type, -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) -- into [m, a] - unwrapTypeVars :: Type -> [TyVar] + unwrapTypeVars :: Type -> [TyCoVarBinder] unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of Just (_, unfunned) -> unwrapTypeVars unfunned _ -> [] - where (vars, unforalled) = splitForAllTys t + where (vars, unforalled) = splitForAllVarBndrs t holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches holeDisp = if sMs then holeVs else sep $ replicate (length matches) $ text "_" diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -72,7 +72,7 @@ tcMatchesFun :: Located Name -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- Expected type of function + -> ExpSigmaType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) -- Returns type of body tcMatchesFun fn@(L _ fun_name) matches exp_ty diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -2,7 +2,7 @@ import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) -import TcType ( ExpRhoType, TcRhoType ) +import TcType ( ExpSigmaType, TcRhoType ) import TcRnTypes( TcM ) import SrcLoc ( Located ) import HsExtension ( GhcRn, GhcTcId ) @@ -13,5 +13,5 @@ tcMatchesFun :: Located Name -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType + -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId)) diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -2031,6 +2031,7 @@ gather_conflicts inj prev_branches cur_branch (acc, n) branch -- n is 0-based index of branch in prev_branches = case injectiveBranches inj cur_branch branch of + -- Case 1B2 in Note [Verifying injectivity annotation] in FamInstEnv InjectivityUnified ax1 ax2 | ax1 `isDominatedBy` (replace_br prev_branches n ax2) -> (acc, n + 1) diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20190523.1 +version: 0.20190603 license: BSD3 license-file: LICENSE category: Development @@ -84,7 +84,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*, - ghc-lib-parser == 0.20190523 + ghc-lib-parser == 0.20190603 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -162,6 +162,7 @@ BufWrite, ByteCodeTypes, Class, + CliOption, CmdLineParser, CmmType, CoAxiom, @@ -201,6 +202,7 @@ FastStringEnv, FieldLabel, FileCleanup, + FileSettings, Fingerprint, FiniteMap, ForeignCall, @@ -225,8 +227,10 @@ GHCi.RemoteTypes, GHCi.TH.Binary, GhcMonad, + GhcNameVersion, GhcPrelude, HaddockUtils, + HeaderInfo, Hooks, HsBinds, HsDecls, @@ -286,6 +290,7 @@ PatSyn, PipelineMonad, PlaceHolder, + PlainPanic, Platform, PlatformConstants, Plugins, @@ -300,6 +305,7 @@ RdrName, RepType, Rules, + Settings, SizedSeq, SrcLoc, StringBuffer, @@ -309,6 +315,7 @@ TcRnTypes, TcType, ToIface, + ToolSettings, TrieMap, TyCoRep, TyCon, @@ -435,7 +442,6 @@ GraphColor GraphOps GraphPpr - HeaderInfo HieAst HieBin HieDebug diff --git a/ghc-lib/generated/GHCConstantsHaskellWrappers.hs b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs --- a/ghc-lib/generated/GHCConstantsHaskellWrappers.hs +++ b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs @@ -1,250 +1,250 @@ cONTROL_GROUP_CONST_291 :: DynFlags -> Int -cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags)) +cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (platformConstants dflags) sTD_HDR_SIZE :: DynFlags -> Int -sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags)) +sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (platformConstants dflags) pROF_HDR_SIZE :: DynFlags -> Int -pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags)) +pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (platformConstants dflags) bLOCK_SIZE :: DynFlags -> Int -bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags)) +bLOCK_SIZE dflags = pc_BLOCK_SIZE (platformConstants dflags) bLOCKS_PER_MBLOCK :: DynFlags -> Int -bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags)) +bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (platformConstants dflags) tICKY_BIN_COUNT :: DynFlags -> Int -tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags)) +tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (platformConstants dflags) oFFSET_StgRegTable_rR1 :: DynFlags -> Int -oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (platformConstants dflags) oFFSET_StgRegTable_rR2 :: DynFlags -> Int -oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (platformConstants dflags) oFFSET_StgRegTable_rR3 :: DynFlags -> Int -oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (platformConstants dflags) oFFSET_StgRegTable_rR4 :: DynFlags -> Int -oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (platformConstants dflags) oFFSET_StgRegTable_rR5 :: DynFlags -> Int -oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (platformConstants dflags) oFFSET_StgRegTable_rR6 :: DynFlags -> Int -oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (platformConstants dflags) oFFSET_StgRegTable_rR7 :: DynFlags -> Int -oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (platformConstants dflags) oFFSET_StgRegTable_rR8 :: DynFlags -> Int -oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (platformConstants dflags) oFFSET_StgRegTable_rR9 :: DynFlags -> Int -oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (platformConstants dflags) oFFSET_StgRegTable_rR10 :: DynFlags -> Int -oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (platformConstants dflags) oFFSET_StgRegTable_rF1 :: DynFlags -> Int -oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (platformConstants dflags) oFFSET_StgRegTable_rF2 :: DynFlags -> Int -oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (platformConstants dflags) oFFSET_StgRegTable_rF3 :: DynFlags -> Int -oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (platformConstants dflags) oFFSET_StgRegTable_rF4 :: DynFlags -> Int -oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (platformConstants dflags) oFFSET_StgRegTable_rF5 :: DynFlags -> Int -oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (platformConstants dflags) oFFSET_StgRegTable_rF6 :: DynFlags -> Int -oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (platformConstants dflags) oFFSET_StgRegTable_rD1 :: DynFlags -> Int -oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (platformConstants dflags) oFFSET_StgRegTable_rD2 :: DynFlags -> Int -oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (platformConstants dflags) oFFSET_StgRegTable_rD3 :: DynFlags -> Int -oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (platformConstants dflags) oFFSET_StgRegTable_rD4 :: DynFlags -> Int -oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (platformConstants dflags) oFFSET_StgRegTable_rD5 :: DynFlags -> Int -oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (platformConstants dflags) oFFSET_StgRegTable_rD6 :: DynFlags -> Int -oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (platformConstants dflags) oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (platformConstants dflags) oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (platformConstants dflags) oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (platformConstants dflags) oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (platformConstants dflags) oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (platformConstants dflags) oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (platformConstants dflags) oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (platformConstants dflags) oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (platformConstants dflags) oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (platformConstants dflags) oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (platformConstants dflags) oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (platformConstants dflags) oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (platformConstants dflags) oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (platformConstants dflags) oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (platformConstants dflags) oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (platformConstants dflags) oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (platformConstants dflags) oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (platformConstants dflags) oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int -oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (platformConstants dflags) oFFSET_StgRegTable_rL1 :: DynFlags -> Int -oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (platformConstants dflags) oFFSET_StgRegTable_rSp :: DynFlags -> Int -oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (platformConstants dflags) oFFSET_StgRegTable_rSpLim :: DynFlags -> Int -oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (platformConstants dflags) oFFSET_StgRegTable_rHp :: DynFlags -> Int -oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (platformConstants dflags) oFFSET_StgRegTable_rHpLim :: DynFlags -> Int -oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (platformConstants dflags) oFFSET_StgRegTable_rCCCS :: DynFlags -> Int -oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (platformConstants dflags) oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int -oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (platformConstants dflags) oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int -oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (platformConstants dflags) oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int -oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (platformConstants dflags) oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int -oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags)) +oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (platformConstants dflags) oFFSET_stgGCEnter1 :: DynFlags -> Int -oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags)) +oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (platformConstants dflags) oFFSET_stgGCFun :: DynFlags -> Int -oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags)) +oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (platformConstants dflags) oFFSET_Capability_r :: DynFlags -> Int -oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags)) +oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (platformConstants dflags) oFFSET_bdescr_start :: DynFlags -> Int -oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags)) +oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (platformConstants dflags) oFFSET_bdescr_free :: DynFlags -> Int -oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags)) +oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (platformConstants dflags) oFFSET_bdescr_blocks :: DynFlags -> Int -oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags)) +oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (platformConstants dflags) oFFSET_bdescr_flags :: DynFlags -> Int -oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags)) +oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (platformConstants dflags) sIZEOF_CostCentreStack :: DynFlags -> Int -sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags)) +sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (platformConstants dflags) oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int -oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags)) +oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (platformConstants dflags) oFFSET_CostCentreStack_scc_count :: DynFlags -> Int -oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags)) +oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (platformConstants dflags) oFFSET_StgHeader_ccs :: DynFlags -> Int -oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags)) +oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (platformConstants dflags) oFFSET_StgHeader_ldvw :: DynFlags -> Int -oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags)) +oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (platformConstants dflags) sIZEOF_StgSMPThunkHeader :: DynFlags -> Int -sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags)) +sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (platformConstants dflags) oFFSET_StgEntCounter_allocs :: DynFlags -> Int -oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (platformConstants dflags) oFFSET_StgEntCounter_allocd :: DynFlags -> Int -oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (platformConstants dflags) oFFSET_StgEntCounter_registeredp :: DynFlags -> Int -oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (platformConstants dflags) oFFSET_StgEntCounter_link :: DynFlags -> Int -oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (platformConstants dflags) oFFSET_StgEntCounter_entry_count :: DynFlags -> Int -oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (platformConstants dflags) sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int -sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags)) +sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (platformConstants dflags) sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int -sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) +sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (platformConstants dflags) oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int -oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) +oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants dflags) oFFSET_StgMutArrPtrs_size :: DynFlags -> Int -oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags)) +oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (platformConstants dflags) sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int -sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) +sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (platformConstants dflags) oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int -oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) +oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants dflags) sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int -sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags)) +sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (platformConstants dflags) oFFSET_StgArrBytes_bytes :: DynFlags -> Int -oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags)) +oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (platformConstants dflags) oFFSET_StgTSO_alloc_limit :: DynFlags -> Int -oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (platformConstants dflags) oFFSET_StgTSO_cccs :: DynFlags -> Int -oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (platformConstants dflags) oFFSET_StgTSO_stackobj :: DynFlags -> Int -oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (platformConstants dflags) oFFSET_StgStack_sp :: DynFlags -> Int -oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags)) +oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (platformConstants dflags) oFFSET_StgStack_stack :: DynFlags -> Int -oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags)) +oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (platformConstants dflags) oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int -oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags)) +oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (platformConstants dflags) oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int -oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags)) +oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (platformConstants dflags) sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int -sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags)) +sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (platformConstants dflags) oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int -oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags)) +oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (platformConstants dflags) mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int -mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags)) +mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (platformConstants dflags) mAX_SPEC_AP_SIZE :: DynFlags -> Int -mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags)) +mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (platformConstants dflags) mIN_PAYLOAD_SIZE :: DynFlags -> Int -mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags)) +mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (platformConstants dflags) mIN_INTLIKE :: DynFlags -> Int -mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags)) +mIN_INTLIKE dflags = pc_MIN_INTLIKE (platformConstants dflags) mAX_INTLIKE :: DynFlags -> Int -mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags)) +mAX_INTLIKE dflags = pc_MAX_INTLIKE (platformConstants dflags) mIN_CHARLIKE :: DynFlags -> Int -mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags)) +mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (platformConstants dflags) mAX_CHARLIKE :: DynFlags -> Int -mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags)) +mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (platformConstants dflags) mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int -mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags)) +mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (platformConstants dflags) mAX_Vanilla_REG :: DynFlags -> Int -mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags)) +mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (platformConstants dflags) mAX_Float_REG :: DynFlags -> Int -mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags)) +mAX_Float_REG dflags = pc_MAX_Float_REG (platformConstants dflags) mAX_Double_REG :: DynFlags -> Int -mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags)) +mAX_Double_REG dflags = pc_MAX_Double_REG (platformConstants dflags) mAX_Long_REG :: DynFlags -> Int -mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags)) +mAX_Long_REG dflags = pc_MAX_Long_REG (platformConstants dflags) mAX_XMM_REG :: DynFlags -> Int -mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags)) +mAX_XMM_REG dflags = pc_MAX_XMM_REG (platformConstants dflags) mAX_Real_Vanilla_REG :: DynFlags -> Int -mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags)) +mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (platformConstants dflags) mAX_Real_Float_REG :: DynFlags -> Int -mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags)) +mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (platformConstants dflags) mAX_Real_Double_REG :: DynFlags -> Int -mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags)) +mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (platformConstants dflags) mAX_Real_XMM_REG :: DynFlags -> Int -mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags)) +mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (platformConstants dflags) mAX_Real_Long_REG :: DynFlags -> Int -mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags)) +mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (platformConstants dflags) rESERVED_C_STACK_BYTES :: DynFlags -> Int -rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags)) +rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (platformConstants dflags) rESERVED_STACK_WORDS :: DynFlags -> Int -rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags)) +rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (platformConstants dflags) aP_STACK_SPLIM :: DynFlags -> Int -aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags)) +aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (platformConstants dflags) wORD_SIZE :: DynFlags -> Int -wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags)) +wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) dOUBLE_SIZE :: DynFlags -> Int -dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags)) +dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (platformConstants dflags) cINT_SIZE :: DynFlags -> Int -cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags)) +cINT_SIZE dflags = pc_CINT_SIZE (platformConstants dflags) cLONG_SIZE :: DynFlags -> Int -cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags)) +cLONG_SIZE dflags = pc_CLONG_SIZE (platformConstants dflags) cLONG_LONG_SIZE :: DynFlags -> Int -cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags)) +cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (platformConstants dflags) bITMAP_BITS_SHIFT :: DynFlags -> Int -bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags)) +bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (platformConstants dflags) tAG_BITS :: DynFlags -> Int -tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags)) +tAG_BITS dflags = pc_TAG_BITS (platformConstants dflags) wORDS_BIGENDIAN :: DynFlags -> Bool -wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags)) +wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (platformConstants dflags) dYNAMIC_BY_DEFAULT :: DynFlags -> Bool -dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags)) +dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (platformConstants dflags) lDV_SHIFT :: DynFlags -> Int -lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags)) +lDV_SHIFT dflags = pc_LDV_SHIFT (platformConstants dflags) iLDV_CREATE_MASK :: DynFlags -> Integer -iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags)) +iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (platformConstants dflags) iLDV_STATE_CREATE :: DynFlags -> Integer -iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags)) +iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (platformConstants dflags) iLDV_STATE_USE :: DynFlags -> Integer -iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags)) +iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (platformConstants dflags) diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190522 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190603 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings --- a/ghc-lib/stage1/lib/settings +++ b/ghc-lib/stage1/lib/settings @@ -19,7 +19,7 @@ ,("dllwrap command", "/bin/false") ,("windres command", "/bin/false") ,("libtool command", "libtool") -,("unlit command", "$topdir/bin/ghc-lib/stage0/lib/bin/unlit") +,("unlit command", "$topdir/bin/unlit") ,("cross compiling", "NO") ,("target platform string", "x86_64-apple-darwin") ,("target os", "OSDarwin") @@ -37,9 +37,9 @@ ,("Use interpreter", "YES") ,("Use native code generator", "YES") ,("Support SMP", "YES") -,("RTS ways", "YES") +,("RTS ways", "v thr p thr_p debug_p thr_debug_p l thr_l debug thr_debug dyn thr_dyn debug_dyn l_dyn thr_debug_dyn thr_l_dyn") ,("Tables next to code", "YES") -,("Leading underscore", "NO") +,("Leading underscore", "YES") ,("Use LibFFI", "NO") ,("Use Threads", "YES") ,("Use Debugging", "NO") diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -7,7 +7,6 @@ import Control.Monad import Data.Bits -import DynFlags ( sTargetPlatform ) import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) import GHC import GHC.Ptr (Ptr (..)) @@ -68,7 +67,7 @@ show (maskTagBits addr)) tagBits - | target32Bit (sTargetPlatform (settings dflags)) = 2 + | target32Bit (targetPlatform dflags) = 2 | otherwise = 3 maskTagBits :: Ptr a -> Ptr a diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -2,7 +2,7 @@ import CmmExpr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) -import Panic +import PlainPanic #endif import Reg diff --git a/includes/MachDeps.h b/includes/MachDeps.h --- a/includes/MachDeps.h +++ b/includes/MachDeps.h @@ -34,7 +34,7 @@ * configuration from 'targetPlatform :: DynFlags -> Platform' * record. A few wrappers are already defined and used throughout GHC: * wORD_SIZE :: DynFlags -> Int - * wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags)) + * wORD_SIZE dflags = pc_WORD_SIZE (platformConstants dflags) * * Hence we hide these macros from -DSTAGE=1 */