Skip to content
GitLab
Commit 1389ff56 authored by Austin Seipp's avatar Austin Seipp
Browse files

compiler: de-lhs main/ 



Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent bc9e81cf
Expand all Hide whitespace changes
Inline Side-by-side
compiler/main/CodeOutput.lhs → compiler/main/CodeOutput.hs
View file @ 1389ff56
%
% (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}
compiler/main/Constants.lhs → compiler/main/Constants.hs
View file @ 1389ff56
%
% (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}
compiler/main/ErrUtils.lhs → compiler/main/ErrUtils.hs
View file @ 1389ff56
%
% (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}
compiler/main/ErrUtils.lhs-boot → compiler/main/ErrUtils.hs-boot
View file @ 1389ff56
\begin{code}
module ErrUtils where
import Outputable (SDoc)
......@@ -16,5 +15,3 @@ data Severity
type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
\end{code}
compiler/main/Finder.lhs → compiler/main/Finder.hs
View file @ 1389ff56
%
% (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}
compiler/main/Hooks.lhs → compiler/main/Hooks.hs
View file @ 1389ff56
\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}
compiler/main/Hooks.lhs-boot → compiler/main/Hooks.hs-boot
View file @ 1389ff56
\begin{code}
module Hooks where
data Hooks
emptyHooks :: Hooks
\end{code}
compiler/main/Packages.lhs → compiler/main/Packages.hs
View file @ 1389ff56
%
% (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}
compiler/main/Packages.lhs-boot → compiler/main/Packages.hs-boot
View file @ 1389ff56
\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}
compiler/main/SysTools.lhs → compiler/main/SysTools.hs
View file @ 1389ff56
{-
-----------------------------------------------------------------------------
--
-- (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
......@@ -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}
compiler/main/TidyPgm.lhs → compiler/main/TidyPgm.hs
View file @ 1389ff56
{-
(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.
%************************************************************************
%* *