Commit 1389ff56 authored by Austin Seipp's avatar Austin Seipp

compiler: de-lhs main/

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent bc9e81cf
%
% (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
......@@ -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 ()
......@@ -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
......@@ -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}
%
% (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}
%
% (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 (
......@@ -417,5 +417,3 @@ prettyPrintGhcErrors dflags
pprDebugAndThen dflags pgmError (text str) doc
_ ->
liftIO $ throwIO e
\end{code}
\begin{code}
module ErrUtils where
import Outputable (SDoc)
......@@ -16,5 +15,3 @@ data Severity
type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
\end{code}
%
% (c) The University of Glasgow, 2000-2006
%
{-
(c) The University of Glasgow, 2000-2006
\section[Finder]{Module Finder}
-}
\begin{code}
{-# LANGUAGE CPP #-}
module Finder (
......@@ -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}
\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}
\begin{code}
module Hooks where
data Hooks
emptyHooks :: Hooks
\end{code}
%
% (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}
\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}
{-
-----------------------------------------------------------------------------
--
-- (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<dir> 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
......@@ -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)
......@@ -1591,4 +1588,3 @@ linkDynLib dflags0 o_files dep_packages
++ map Option pkg_lib_path_opts
++ map Option pkg_link_opts
)
\end{code}
{-
(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
......@@ -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
......@@ -497,8 +490,8 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
-- 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
......@@ -527,11 +520,11 @@ of exceptions, and finally I gave up the battle:
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
......@@ -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)
......@@ -856,14 +848,13 @@ dffvLetBndr vanilla_unfold id
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}
%************************************************************************
%* *