From 1389ff565d9a41d21eb7e4fc6e2b23d0df08de24 Mon Sep 17 00:00:00 2001 From: Austin Seipp Date: Wed, 3 Dec 2014 12:41:58 -0600 Subject: [PATCH] compiler: de-lhs main/ Signed-off-by: Austin Seipp --- .../main/{CodeOutput.lhs => CodeOutput.hs} | 89 +++--- compiler/main/{Constants.lhs => Constants.hs} | 9 +- compiler/main/{ErrUtils.lhs => ErrUtils.hs} | 14 +- .../{ErrUtils.lhs-boot => ErrUtils.hs-boot} | 3 - compiler/main/{Finder.lhs => Finder.hs} | 11 +- compiler/main/{Hooks.lhs => Hooks.hs} | 19 +- .../main/{Hooks.lhs-boot => Hooks.hs-boot} | 4 - compiler/main/{HscTypes.lhs => HscTypes.hs} | 281 ++++++++---------- compiler/main/{Packages.lhs => Packages.hs} | 8 +- .../{Packages.lhs-boot => Packages.hs-boot} | 2 - compiler/main/{SysTools.lhs => SysTools.hs} | 60 ++-- compiler/main/{TidyPgm.lhs => TidyPgm.hs} | 148 +++++---- 12 files changed, 294 insertions(+), 354 deletions(-) rename compiler/main/{CodeOutput.lhs => CodeOutput.hs} (79%) rename compiler/main/{Constants.lhs => Constants.hs} (89%) rename compiler/main/{ErrUtils.lhs => ErrUtils.hs} (99%) rename compiler/main/{ErrUtils.lhs-boot => ErrUtils.hs-boot} (91%) rename compiler/main/{Finder.lhs => Finder.hs} (99%) rename compiler/main/{Hooks.lhs => Hooks.hs} (86%) rename compiler/main/{Hooks.lhs-boot => Hooks.hs-boot} (66%) rename compiler/main/{HscTypes.lhs => HscTypes.hs} (93%) rename compiler/main/{Packages.lhs => Packages.hs} (99%) rename compiler/main/{Packages.lhs-boot => Packages.hs-boot} (90%) rename compiler/main/{SysTools.lhs => SysTools.hs} (97%) rename compiler/main/{TidyPgm.lhs => TidyPgm.hs} (94%) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.hs similarity index 79% rename from compiler/main/CodeOutput.lhs rename to compiler/main/CodeOutput.hs index 72803c0d6b..cdb81b7f9e 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.hs @@ -1,9 +1,9 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + \section{Code output phase} +-} -\begin{code} {-# LANGUAGE CPP #-} module CodeOutput( codeOutput, outputForeignStubs ) where @@ -36,15 +36,15 @@ import Control.Exception import System.Directory import System.FilePath import System.IO -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Steering} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} codeOutput :: DynFlags -> Module -> FilePath @@ -56,7 +56,7 @@ codeOutput :: DynFlags (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream - = + = do { -- Lint each CmmGroup as it goes past ; let linted_cmm_stream = @@ -87,16 +87,15 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{C} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup () @@ -104,7 +103,7 @@ outputC :: DynFlags -> IO () outputC dflags filenm cmm_stream packages - = do + = do -- ToDo: make the C backend consume the C-- incrementally, by -- pushing the cmm_stream inside (c.f. nativeCodeGen) rawcmms <- Stream.collect cmm_stream @@ -116,10 +115,10 @@ outputC dflags filenm cmm_stream packages -- * the _stub.h file, if there is one. -- let rts = getPackageDetails dflags rtsPackageKey - + let cc_injects = unlines (map mk_include (includes rts)) - mk_include h_file = - case h_file of + mk_include h_file = + case h_file of '"':_{-"-} -> "#include "++h_file '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" @@ -130,16 +129,15 @@ outputC dflags filenm cmm_stream packages hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects writeCs dflags h rawcmms -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Assembler} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO () outputAsm dflags this_mod filenm cmm_stream | cGhcWithNativeCodeGen == "YES" @@ -154,16 +152,15 @@ outputAsm dflags this_mod filenm cmm_stream | otherwise = panic "This compiler was built without a native code generator" -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{LLVM} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () outputLlvm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' @@ -171,16 +168,15 @@ outputLlvm dflags filenm cmm_stream {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} llvmCodeGen dflags f ncg_uniqs cmm_stream -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Foreign import/export} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Maybe FilePath) -- C file created @@ -197,7 +193,7 @@ outputForeignStubs dflags mod location stubs let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc dflags stub_c_output_d - + -- Header file protos for "foreign export"ed functions. stub_h_output_d = pprCode CStyle h_code stub_h_output_w = showSDoc dflags stub_h_output_d @@ -208,7 +204,7 @@ outputForeignStubs dflags mod location stubs "Foreign export header file" stub_h_output_d -- we need the #includes from the rts package for the stub files - let rts_includes = + let rts_includes = let rts_pkg = getPackageDetails dflags rtsPackageKey in concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" @@ -226,7 +222,7 @@ outputForeignStubs dflags mod location stubs stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ + ("#define IN_STG_CODE 0\n" ++ "#include \"Rts.h\"\n" ++ rts_includes ++ ffi_includes ++ @@ -252,4 +248,3 @@ outputForeignStubs_help _fname "" _header _footer = return False outputForeignStubs_help fname doc_str header footer = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") return True -\end{code} diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.hs similarity index 89% rename from compiler/main/Constants.lhs rename to compiler/main/Constants.hs index ee126f5b20..0054888df3 100644 --- a/compiler/main/Constants.lhs +++ b/compiler/main/Constants.hs @@ -1,9 +1,9 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + \section[Constants]{Info about this compilation} +-} -\begin{code} module Constants (module Constants) where import Config @@ -30,4 +30,3 @@ wORD64_SIZE = 8 tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff -\end{code} diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.hs similarity index 99% rename from compiler/main/ErrUtils.lhs rename to compiler/main/ErrUtils.hs index 61f433573b..59bc01b324 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.hs @@ -1,13 +1,13 @@ -% -% (c) The AQUA Project, Glasgow University, 1994-1998 -% +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + \section[ErrsUtils]{Utilities for error reporting} +-} -\begin{code} {-# LANGUAGE CPP #-} module ErrUtils ( - MsgDoc, + MsgDoc, Validity(..), andValid, allValid, isValid, getInvalids, ErrMsg, WarnMsg, Severity(..), @@ -130,7 +130,7 @@ mkLocMessage severity locn msg where sev_info = case severity of SevWarning -> ptext (sLit "Warning:") - _other -> empty + _other -> empty -- For warnings, print Foo.hs:34: Warning: -- @@ -417,5 +417,3 @@ prettyPrintGhcErrors dflags pprDebugAndThen dflags pgmError (text str) doc _ -> liftIO $ throwIO e -\end{code} - diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.hs-boot similarity index 91% rename from compiler/main/ErrUtils.lhs-boot rename to compiler/main/ErrUtils.hs-boot index fc99c5afde..ac1673b367 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module ErrUtils where import Outputable (SDoc) @@ -16,5 +15,3 @@ data Severity type MsgDoc = SDoc mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -\end{code} - diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.hs similarity index 99% rename from compiler/main/Finder.lhs rename to compiler/main/Finder.hs index 189ef50fb6..71b4e97b39 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.hs @@ -1,9 +1,9 @@ -% -% (c) The University of Glasgow, 2000-2006 -% +{- +(c) The University of Glasgow, 2000-2006 + \section[Finder]{Module Finder} +-} -\begin{code} {-# LANGUAGE CPP #-} module Finder ( @@ -258,7 +258,7 @@ uncacheModule hsc_env mod = do findHomeModule :: HscEnv -> ModuleName -> IO FindResult findHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ - let + let dflags = hsc_dflags hsc_env home_path = importPaths dflags hisuf = hiSuf dflags @@ -691,4 +691,3 @@ cantFindErr cannot_find _ dflags mod_name find_result = parens (ptext (sLit "needs flag -package-key") <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty -\end{code} diff --git a/compiler/main/Hooks.lhs b/compiler/main/Hooks.hs similarity index 86% rename from compiler/main/Hooks.lhs rename to compiler/main/Hooks.hs index 63aaafa2a7..44f340aed9 100644 --- a/compiler/main/Hooks.lhs +++ b/compiler/main/Hooks.hs @@ -1,6 +1,5 @@ -\section[Hooks]{Low level API hooks} +-- \section[Hooks]{Low level API hooks} -\begin{code} module Hooks ( Hooks , emptyHooks , lookupHook @@ -40,15 +39,14 @@ import Type import SrcLoc import Data.Maybe -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Hooks} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- | Hooks can be used by GHC API clients to replace parts of -- the compiler pipeline. If a hook is not installed, GHC @@ -78,6 +76,3 @@ getHooked hook def = fmap (lookupHook hook def) getDynFlags lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a lookupHook hook def = fromMaybe def . hook . hooks - -\end{code} - diff --git a/compiler/main/Hooks.lhs-boot b/compiler/main/Hooks.hs-boot similarity index 66% rename from compiler/main/Hooks.lhs-boot rename to compiler/main/Hooks.hs-boot index 71b7bf2a7d..280de32063 100644 --- a/compiler/main/Hooks.lhs-boot +++ b/compiler/main/Hooks.hs-boot @@ -1,9 +1,5 @@ -\begin{code} module Hooks where data Hooks emptyHooks :: Hooks - -\end{code} - diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.hs similarity index 93% rename from compiler/main/HscTypes.lhs rename to compiler/main/HscTypes.hs index b6e3a98a50..d3666f52e8 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.hs @@ -1,9 +1,9 @@ -% -% (c) The University of Glasgow, 2006 -% +{- +(c) The University of Glasgow, 2006 + \section[HscTypes]{Types for the per-module compiler} +-} -\begin{code} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -- | Types for the per-module compiler @@ -315,15 +315,14 @@ handleFlagWarnings dflags warns | L loc warn <- warns ] printOrThrowWarnings dflags bag -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{HscEnv} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- | Hscenv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source @@ -436,15 +435,15 @@ pprTargetId (TargetFile f _) = text f instance Outputable TargetId where ppr = pprTargetId -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Package and Module Tables} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Helps us find information about modules in the home package type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package that have been fully compiled @@ -591,15 +590,15 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps hptObjs :: HomePackageTable -> [FilePath] hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Dealing with Annotations} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Deal with gathering annotations in from all possible places -- and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv @@ -616,15 +615,15 @@ prepareAnnotations hsc_env mb_guts = do Just home_pkg_anns, Just other_pkg_anns] return ann_env -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The Finder cache} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | The 'FinderCache' maps home module names to the result of -- searching for that module. It records the results of searching for -- modules along the search path. On @:load@, we flush the entire @@ -665,15 +664,15 @@ data FindResult -- home modules and package modules. On @:load@, only home modules are -- purged from this cache. type ModLocationCache = ModuleEnv ModLocation -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Symbol tables and Module details} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A 'ModIface' plus a 'ModDetails' summarises everything we know -- about a compiled module. The 'ModIface' is the stuff *before* linking, -- and can be written out to an interface file. The 'ModDetails is after @@ -1101,13 +1100,13 @@ data ForeignStubs appendStubC :: ForeignStubs -> SDoc -> ForeignStubs appendStubC NoStubs c_code = ForeignStubs empty c_code appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The interactive context} -%* * -%************************************************************************ +* * +************************************************************************ Note [The interactive package] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1215,9 +1214,8 @@ It does *not* contain * CoAxioms (ditto) See also Note [Interactively-bound Ids in GHCi] +-} - -\begin{code} -- | Interactive context, recording information about the state of the -- context in which statements are executed in a GHC session. data InteractiveContext @@ -1382,13 +1380,13 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m ppr (IIDecl d) = ppr d -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Building a PrintUnqualified -%* * -%************************************************************************ +* * +************************************************************************ Note [Printing original names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1434,8 +1432,8 @@ another scheme is to (recursively) say which dependencies are different. NB: When we extend package keys to also have holes, we will have to disambiguate those as well. +-} -\begin{code} -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified @@ -1516,14 +1514,12 @@ pkgQual dflags = alwaysQualify { queryQualifyPackage = mkQualPackage dflags } -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Implicit TyThings -%* * -%************************************************************************ +* * +************************************************************************ Note [Implicit TyThings] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1548,8 +1544,8 @@ Examples: * Axioms for newtypes are implicit (same as above), but axioms for data/type family instances are *not* implicit (like DFunIds). +-} -\begin{code} -- | Determine the 'TyThing's brought into scope by another 'TyThing' -- /other/ than itself. For example, Id's don't have any implicit TyThings -- as they just bring themselves into scope, but classes bring their @@ -1677,15 +1673,15 @@ tyThingAvailInfo (ATyCon t) dcs = tyConDataCons t tyThingAvailInfo t = Avail (getName t) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * TypeEnv -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A map from 'Name's to 'TyThing's, constructed by typechecking -- local declarations or interface files type TypeEnv = NameEnv TyThing @@ -1741,9 +1737,7 @@ extendTypeEnvList env things = foldl extendTypeEnv env things extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids = extendNameEnvList env [(getName id, AnId id) | id <- ids] -\end{code} -\begin{code} -- | Find the 'TyThing' for the given 'Name' by using all the resources -- at our disposal: the compiled modules in the 'HomePackageTable' and the -- compiled modules in other packages that live in 'PackageTypeEnv'. Note @@ -1774,9 +1768,7 @@ lookupTypeHscEnv hsc_env name = do where dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env -\end{code} -\begin{code} -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc @@ -1797,15 +1789,15 @@ tyThingId :: TyThing -> Id tyThingId (AnId id) = id tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc tyThingId other = pprPanic "tyThingId" (pprTyThing other) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{MonadThings and friends} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Class that abstracts out the common ability of the monads in GHC -- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides -- a number of related convenience functions for accessing particular @@ -1821,18 +1813,18 @@ class Monad m => MonadThings m where lookupTyCon :: Name -> m TyCon lookupTyCon = liftM tyThingTyCon . lookupThing -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Auxiliary types} -%* * -%************************************************************************ +* * +************************************************************************ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere +-} -\begin{code} ------------------ Warnings ------------------------- -- | Warning information for a module data Warnings @@ -1895,9 +1887,7 @@ plusWarns NoWarnings d = d plusWarns _ (WarnAll t) = WarnAll t plusWarns (WarnAll t) _ = WarnAll t plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) -\end{code} -\begin{code} -- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity mkIfaceFixCache pairs @@ -1925,15 +1915,15 @@ lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of Just (FixItem _ fix) -> fix Nothing -> defaultFixity -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{WhatsImported} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Records whether a module has orphans. An \"orphan\" is one of: -- -- * An instance declaration in a module other than the definition @@ -2106,16 +2096,14 @@ instance Binary Usage where return UsageFile { usg_file_path = fp, usg_file_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * The External Package State -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv @@ -2197,8 +2185,8 @@ addEpsInStats stats n_decls n_insts n_rules , n_decls_in = n_decls_in stats + n_decls , n_insts_in = n_insts_in stats + n_insts , n_rules_in = n_rules_in stats + n_rules } -\end{code} +{- Names in a NameCache are always stored as a Global, and have the SrcLoc of their binding locations. @@ -2206,8 +2194,8 @@ Actually that's not quite right. When we first encounter the original name, we might not be at its binding site (e.g. we are reading an interface file); so we give it 'noSrcLoc' then. Later, when we find its binding site, we fix it up. +-} -\begin{code} -- | The NameCache makes sure that there is just one Unique assigned for -- each original name; i.e. (module-name, occ-name) pair and provides -- something of a lookup mechanism for those names. @@ -2220,10 +2208,7 @@ data NameCache -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache = ModuleEnv (OccEnv Name) -\end{code} - -\begin{code} mkSOName :: Platform -> FilePath -> FilePath mkSOName platform root = case platformOS platform of @@ -2240,18 +2225,17 @@ soExt platform OSDarwin -> "dylib" OSMinGW32 -> "dll" _ -> "so" -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The module graph and ModSummary type A ModSummary is a node in the compilation manager's dependency graph, and it's also passed to hscMain -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A ModuleGraph contains all the nodes from the home package (only). -- There will be a node for each source module, plus a node for each hi-boot -- module. @@ -2375,15 +2359,15 @@ hscSourceString' dflags mod HsigFile = (("sig of "++).showPpr dflags) (getSigOf dflags mod)) ++ "]" -- NB: -sig-of could be missing if we're just typechecking -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Recmpilation} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Indicates whether a given module's source has been modified since it -- was last compiled. data SourceModified @@ -2400,15 +2384,15 @@ data SourceModified -- reasons: (a) we can omit the version check in checkOldIface, -- and (b) if the module used TH splices we don't need to force -- recompilation. -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Hpc Support} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Information about a modules use of Haskell Program Coverage data HpcInfo = HpcInfo @@ -2431,13 +2415,13 @@ emptyHpcInfo = NoHpcInfo isHpcUsed :: HpcInfo -> AnyHpcUsage isHpcUsed (HpcInfo {}) = True isHpcUsed (NoHpcInfo { hpcUsed = used }) = used -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Vectorisation Support} -%* * -%************************************************************************ +* * +************************************************************************ The following information is generated and consumed by the vectorisation subsystem. It communicates the vectorisation status of declarations from one @@ -2447,8 +2431,8 @@ Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo below? We need to know `f' when converting to IfaceVectInfo. However, during vectorisation, we need to know `f_v', whose `Var' we cannot lookup based on just the OccName easily in a Core pass. +-} -\begin{code} -- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also -- documentation at 'Vectorise.Env.GlobalEnv'. -- @@ -2544,18 +2528,18 @@ instance Binary IfaceVectInfo where a4 <- get bh a5 <- get bh return (IfaceVectInfo a1 a2 a3 a4 a5) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Safe Haskell Support} -%* * -%************************************************************************ +* * +************************************************************************ This stuff here is related to supporting the Safe Haskell extension, primarily about storing under what trust type a module has been compiled. +-} -\begin{code} -- | Is an import a safe import? type IsSafeImport = Bool @@ -2599,15 +2583,15 @@ instance Outputable IfaceTrustInfo where instance Binary IfaceTrustInfo where put_ bh iftrust = putByte bh $ trustInfoToNum iftrust get bh = getByte bh >>= (return . numToTrustInfo) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Parser result} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data HsParsedModule = HsParsedModule { hpm_module :: Located (HsModule RdrName), hpm_src_files :: [FilePath], @@ -2619,18 +2603,18 @@ data HsParsedModule = HsParsedModule { hpm_annotations :: ApiAnns -- See note [Api annotations] in ApiAnnotation.hs } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Linkable stuff} -%* * -%************************************************************************ +* * +************************************************************************ This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} -\begin{code} -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { linkableTime :: UTCTime, -- ^ Time at which this linkable was built @@ -2710,15 +2694,15 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other) byteCodeOfObject :: Unlinked -> CompiledByteCode byteCodeOfObject (BCOs bc _) = bc byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Breakpoint Support} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Breakpoint index type BreakIndex = Int @@ -2745,4 +2729,3 @@ emptyModBreaks = ModBreaks , modBreaks_vars = array (0,-1) [] , modBreaks_decls = array (0,-1) [] } -\end{code} diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.hs similarity index 99% rename from compiler/main/Packages.lhs rename to compiler/main/Packages.hs index 8fe169363f..0a875b2f13 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.hs @@ -1,7 +1,5 @@ -% -% (c) The University of Glasgow, 2006 -% -\begin{code} +-- (c) The University of Glasgow, 2006 + {-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Package manipulation @@ -1390,5 +1388,3 @@ pprModuleMap dflags = fsPackageName :: PackageConfig -> FastString fsPackageName = mkFastString . packageNameString - -\end{code} diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.hs-boot similarity index 90% rename from compiler/main/Packages.lhs-boot rename to compiler/main/Packages.hs-boot index 3fd0fd5422..2f898f19d3 100644 --- a/compiler/main/Packages.lhs-boot +++ b/compiler/main/Packages.hs-boot @@ -1,8 +1,6 @@ -\begin{code} module Packages where -- Well, this is kind of stupid... import {-# SOURCE #-} Module (PackageKey) import {-# SOURCE #-} DynFlags (DynFlags) data PackageState packageKeyPackageIdString :: DynFlags -> PackageKey -> String -\end{code} diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.hs similarity index 97% rename from compiler/main/SysTools.lhs rename to compiler/main/SysTools.hs index 4c7ab03664..375cf2e58c 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.hs @@ -1,3 +1,4 @@ +{- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2001-2003 @@ -5,8 +6,8 @@ -- Access to system tools: gcc, cp, rm etc -- ----------------------------------------------------------------------------- +-} -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} module SysTools ( @@ -96,8 +97,8 @@ import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) # error Unknown mingw32 arch # endif #endif -\end{code} +{- How GHC finds its files ~~~~~~~~~~~~~~~~~~~~~~~ @@ -162,13 +163,13 @@ stuff. End of NOTES --------------------------------------------- -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Initialisation} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) -> IO Settings -- Set all the mutable variables above, holding -- (a) the system programs @@ -351,9 +352,7 @@ initSysTools mbMinusB sOpt_lc = [], sPlatformConstants = platformConstants } -\end{code} -\begin{code} -- returns a Unix-format path (relying on getBaseDir to do so too) findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). -> IO String -- TopDir (in Unix format '/' separated) @@ -365,17 +364,15 @@ findTopDir Nothing -- "Just" on Windows, "Nothing" on unix Nothing -> throwGhcExceptionIO (InstallationError "missing -B option") Just dir -> return dir -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Running an external program} -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} runUnlit :: DynFlags -> [Option] -> IO () runUnlit dflags args = do let prog = pgm_L dflags @@ -932,7 +929,7 @@ runLibtool dflags args = do linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let args1 = map Option (getOpts dflags opt_l) args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags + libtool = pgm_libtool dflags mb_env <- getGccEnv args2 runSomethingFiltered dflags id "Linker" libtool args2 mb_env @@ -1019,15 +1016,15 @@ readElfSection _dflags section exe = do _ <- string "0]" skipSpaces munch (const True) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Managing temporary files -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} cleanTempDirs :: DynFlags -> IO () cleanTempDirs dflags = unless (gopt Opt_KeepTmpFiles dflags) @@ -1347,15 +1344,15 @@ traceCmd dflags phase_name cmd_line action handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Support code} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} ----------------------------------------------------------------------------- -- Define getBaseDir :: IO (Maybe String) @@ -1371,7 +1368,7 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. 0 -> return Nothing _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf | otherwise -> try_size (size * 2) - + rootDir s = case splitFileName $ normalise s of (d, ghc_exe) | lower ghc_exe `elem` ["ghc.exe", @@ -1591,4 +1588,3 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_lib_path_opts ++ map Option pkg_link_opts ) -\end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.hs similarity index 94% rename from compiler/main/TidyPgm.lhs rename to compiler/main/TidyPgm.hs index b7a867d718..ed37225219 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.hs @@ -1,9 +1,9 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% \section{Tidying up Core} +-} -\begin{code} {-# LANGUAGE CPP #-} module TidyPgm ( @@ -63,9 +63,8 @@ import Control.Monad import Data.Function import Data.List ( sortBy ) import Data.IORef ( atomicModifyIORef ) -\end{code} - +{- Constructing the TypeEnv, Instances, Rules, VectInfo from which the ModIface is constructed, and which goes on to subsequent modules in --make mode. @@ -84,11 +83,11 @@ plus one for each DataCon; the interface file will contain just one data type declaration, but it is de-serialised back into a collection of TyThings. -%************************************************************************ -%* * +************************************************************************ +* * Plan A: simpleTidyPgm -%* * -%************************************************************************ +* * +************************************************************************ Plan A: mkBootModDetails: omit pragmas, make interfaces small @@ -123,8 +122,8 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small * If this an hsig file, drop the instances altogether too (they'll get pulled in by the implicit module import. +-} -\begin{code} -- This is Plan A: make a small type env when typechecking only, -- or when compiling a hs-boot file, or simply when not using -O -- @@ -200,14 +199,13 @@ globaliseAndTidyId id = Id.setIdType (globaliseId id) tidy_type where tidy_type = tidyTopType (idType id) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Plan B: tidy bindings, make TypeEnv full of IdInfo -%* * -%************************************************************************ +* * +************************************************************************ Plan B: include pragmas, make interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -297,8 +295,8 @@ binder Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. +-} -\begin{code} tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env (ModGuts { mg_module = mod , mg_exports = exports @@ -334,7 +332,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; (unfold_env, tidy_occ_env) <- chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules (vectInfoVar vect_info) - ; let { (trimmed_binds, trimmed_rules) + ; let { (trimmed_binds, trimmed_rules) = findExternalRules omit_prags binds imp_rules unfold_env } ; (tidy_env, tidy_binds) @@ -422,10 +420,7 @@ lookup_aux_id type_env id = case lookupTypeEnv type_env (idName id) of Just (AnId id') -> id' _other -> pprPanic "lookup_aux_id" (ppr id) -\end{code} - -\begin{code} tidyTypeEnv :: Bool -- Compiling without -O, so omit prags -> TypeEnv -> TypeEnv @@ -464,9 +459,7 @@ trimThing other_thing extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv extendTypeEnvWithPatSyns tidy_patsyns type_env = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] -\end{code} -\begin{code} tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars , vectInfoParallelVars = parallelVars @@ -493,17 +486,17 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars ] lookup_var var = lookupWithDefaultVarEnv var_env var var - + -- We need to make sure that all names getting into the iface version of 'VectInfo' are -- external; otherwise, 'MkIface' will bomb out. isExternalId = isExternalName . idName -\end{code} +{- Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some time GHC tried to avoid exporting the data constructors of a data type if it wasn't strictly necessary to do so; see Trac #835. -But "strictly necessary" accumulated a longer and longer list +But "strictly necessary" accumulated a longer and longer list of exceptions, and finally I gave up the battle: commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 @@ -511,27 +504,27 @@ of exceptions, and finally I gave up the battle: Date: Thu Dec 6 16:03:16 2012 +0000 Stop attempting to "trim" data types in interface files - + Without -O, we previously tried to make interface files smaller by not including the data constructors of data types. But there are a lot of exceptions, notably when Template Haskell is involved or, more recently, DataKinds. - + However Trac #7445 shows that even without TemplateHaskell, using the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ is enough to require us to expose the data constructors. - + So I've given up on this "optimisation" -- it's probably not important anyway. Now I'm simply not attempting to trim off the data constructors. The gain in simplicity is worth the modest cost in interface file growth, which is limited to the bits reqd to describe those data constructors. -%************************************************************************ -%* * +************************************************************************ +* * Implicit bindings -%* * -%************************************************************************ +* * +************************************************************************ Note [Injecting implicit bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -578,8 +571,8 @@ There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense. See Note [Data constructor workers] in CorePrep. +-} -\begin{code} getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) @@ -590,18 +583,17 @@ getClassImplicitBinds cls get_defn :: Id -> CoreBind get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Step 1: finding externals} -%* * -%************************************************************************ +* * +************************************************************************ See Note [Choosing external names]. +-} -\begin{code} type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) -- Maps each top-level Id to its new Name (the Id is tidied in step 2) -- The Unique is unchanged. If the new Name is external, it will be @@ -696,7 +688,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ -- add vectorised version if any exists new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc) - + -- 'idocc' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set refined_id = case lookupVarSet binder_set idocc of @@ -744,13 +736,13 @@ addExternal expose_all id = (new_needed_ids, show_unfold) || neverUnfoldGuidance guidance) show_unfolding (DFunUnfolding {}) = True show_unfolding _ = False -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Deterministic free variables -%* * -%************************************************************************ +* * +************************************************************************ We want a deterministic free-variable list. exprFreeVars gives us a VarSet, which is in a non-deterministic order when converted to a @@ -758,8 +750,8 @@ list. Hence, here we define a free-variable finder that returns the free variables in the order that they are encountered. See Note [Choosing external names] +-} -\begin{code} bndrFvsInOrder :: Bool -> Id -> [Id] bndrFvsInOrder show_unfold id = run (dffvLetBndr show_unfold id) @@ -849,21 +841,20 @@ dffvLetBndr vanilla_unfold id | otherwise -> return () _ -> dffvExpr rhs - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = extendScopeList bndrs $ mapM_ dffvExpr args go_unf _ = return () go_rule (BuiltinRule {}) = return () go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) = extendScopeList bndrs (dffvExpr rhs) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * findExternalRules -%* * -%************************************************************************ +* * +************************************************************************ Note [Finding external rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -918,9 +909,8 @@ called in the final code), we keep the rule too. I found that binary sizes jumped by 6-10% when I started to specialise INLINE functions (again, Note [Inline specialisations] in Specialise). Adding trimAutoRules removed all this bloat. +-} - -\begin{code} findExternalRules :: Bool -- Omit pragmas -> [CoreBind] -> [CoreRule] -- Local rules for imported fns @@ -1000,20 +990,20 @@ findExternalRules omit_prags binds imp_id_rules unfold_env , is_external_id id -- Only collect rules for external Ids , rule <- idCoreRules id , expose_rule rule ] -- and ones that can fire in a client -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * tidyTopName -%* * -%************************************************************************ +* * +************************************************************************ This is where we set names to local/global based on whether they really are externally visible (see comment at the top of this module). If the name was previously local, we have to give it a unique occurrence name if we intend to externalise it. +-} -\begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv -> Id -> IO (TidyOccEnv, Name) tidyTopName mod nc_var maybe_ref occ_env id @@ -1081,17 +1071,15 @@ tidyTopName mod nc_var maybe_ref occ_env id -- All this is done by allcoateGlobalBinder. -- This is needed when *re*-compiling a module in GHCi; we must -- use the same name for externally-visible things as we did before. -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Step 2: top-level tidying} -%* * -%************************************************************************ - +* * +************************************************************************ +-} -\begin{code} -- TopTidyEnv: when tidying we need to know -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the @@ -1248,7 +1236,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ sig = strictnessInfo idinfo final_sig | not $ isNopSig sig - = WARN( _bottom_hidden sig , ppr name ) sig + = WARN( _bottom_hidden sig , ppr name ) sig -- try a cheap-and-cheerful bottom analyser | Just (_, nsig) <- mb_bot_str = nsig | otherwise = sig @@ -1285,13 +1273,13 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ -- it to the top level. So it seems more robust just to -- fix it here. arity = exprArity orig_rhs -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Figuring out CafInfo for an expression} -%* * -%************************************************************************ +* * +************************************************************************ hasCafRefs decides whether a top-level closure can point into the dynamic heap. We mark such things as `MayHaveCafRefs' because this information is @@ -1307,8 +1295,8 @@ hence the size of the SRTs) down, we could also look at the expression and decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. +-} -\begin{code} hasCafRefs :: DynFlags -> PackageKey -> Module -> (Id, Maybe DataCon, VarEnv Var) -> Arity -> CoreExpr -> CafInfo @@ -1359,9 +1347,8 @@ cafRefsV (_, _, p) id fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool -- hack for lazy-or over FastBool. fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) -\end{code} - +{- ------------------------------------------------------------------------------ -- Old, dead, type-trimming code ------------------------------------------------------------------------------- @@ -1460,3 +1447,4 @@ mustExposeTyCon no_trim_types exports tc data_cons = tyConDataCons tc exported_con con = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) +-} -- GitLab