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
......@@ -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}
%
% (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 (
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:
-- <the warning message>
......@@ -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 (
......@@ -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}
\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
%
{-
(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}
%* *
%************************************************************************
* *
************************************************************************
-}