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} \section{Code output phase}
-}
\begin{code}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module CodeOutput( codeOutput, outputForeignStubs ) where module CodeOutput( codeOutput, outputForeignStubs ) where
...@@ -36,15 +36,15 @@ import Control.Exception ...@@ -36,15 +36,15 @@ import Control.Exception
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.IO import System.IO
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{Steering} \subsection{Steering}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
codeOutput :: DynFlags codeOutput :: DynFlags
-> Module -> Module
-> FilePath -> FilePath
...@@ -56,7 +56,7 @@ codeOutput :: DynFlags ...@@ -56,7 +56,7 @@ codeOutput :: DynFlags
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}))
codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
= =
do { do {
-- Lint each CmmGroup as it goes past -- Lint each CmmGroup as it goes past
; let linted_cmm_stream = ; let linted_cmm_stream =
...@@ -87,16 +87,15 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps 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 :: String -> (Handle -> IO a) -> IO a
doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{C} \subsection{C}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
outputC :: DynFlags outputC :: DynFlags
-> FilePath -> FilePath
-> Stream IO RawCmmGroup () -> Stream IO RawCmmGroup ()
...@@ -104,7 +103,7 @@ outputC :: DynFlags ...@@ -104,7 +103,7 @@ outputC :: DynFlags
-> IO () -> IO ()
outputC dflags filenm cmm_stream packages outputC dflags filenm cmm_stream packages
= do = do
-- ToDo: make the C backend consume the C-- incrementally, by -- ToDo: make the C backend consume the C-- incrementally, by
-- pushing the cmm_stream inside (c.f. nativeCodeGen) -- pushing the cmm_stream inside (c.f. nativeCodeGen)
rawcmms <- Stream.collect cmm_stream rawcmms <- Stream.collect cmm_stream
...@@ -116,10 +115,10 @@ outputC dflags filenm cmm_stream packages ...@@ -116,10 +115,10 @@ outputC dflags filenm cmm_stream packages
-- * the _stub.h file, if there is one. -- * the _stub.h file, if there is one.
-- --
let rts = getPackageDetails dflags rtsPackageKey let rts = getPackageDetails dflags rtsPackageKey
let cc_injects = unlines (map mk_include (includes rts)) let cc_injects = unlines (map mk_include (includes rts))
mk_include h_file = mk_include h_file =
case h_file of case h_file of
'"':_{-"-} -> "#include "++h_file '"':_{-"-} -> "#include "++h_file
'<':_ -> "#include "++h_file '<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\"" _ -> "#include \""++h_file++"\""
...@@ -130,16 +129,15 @@ outputC dflags filenm cmm_stream packages ...@@ -130,16 +129,15 @@ outputC dflags filenm cmm_stream packages
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
hPutStr h cc_injects hPutStr h cc_injects
writeCs dflags h rawcmms writeCs dflags h rawcmms
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{Assembler} \subsection{Assembler}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO () outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputAsm dflags this_mod filenm cmm_stream outputAsm dflags this_mod filenm cmm_stream
| cGhcWithNativeCodeGen == "YES" | cGhcWithNativeCodeGen == "YES"
...@@ -154,16 +152,15 @@ outputAsm dflags this_mod filenm cmm_stream ...@@ -154,16 +152,15 @@ outputAsm dflags this_mod filenm cmm_stream
| otherwise | otherwise
= panic "This compiler was built without a native code generator" = panic "This compiler was built without a native code generator"
\end{code}
{-
%************************************************************************ ************************************************************************
%* * * *
\subsection{LLVM} \subsection{LLVM}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
outputLlvm dflags filenm cmm_stream outputLlvm dflags filenm cmm_stream
= do ncg_uniqs <- mkSplitUniqSupply 'n' = do ncg_uniqs <- mkSplitUniqSupply 'n'
...@@ -171,16 +168,15 @@ outputLlvm dflags filenm cmm_stream ...@@ -171,16 +168,15 @@ outputLlvm dflags filenm cmm_stream
{-# SCC "llvm_output" #-} doOutput filenm $ {-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-} \f -> {-# SCC "llvm_CodeGen" #-}
llvmCodeGen dflags f ncg_uniqs cmm_stream llvmCodeGen dflags f ncg_uniqs cmm_stream
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{Foreign import/export} \subsection{Foreign import/export}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
-> IO (Bool, -- Header file created -> IO (Bool, -- Header file created
Maybe FilePath) -- C file created Maybe FilePath) -- C file created
...@@ -197,7 +193,7 @@ outputForeignStubs dflags mod location stubs ...@@ -197,7 +193,7 @@ outputForeignStubs dflags mod location stubs
let let
stub_c_output_d = pprCode CStyle c_code stub_c_output_d = pprCode CStyle c_code
stub_c_output_w = showSDoc dflags stub_c_output_d stub_c_output_w = showSDoc dflags stub_c_output_d
-- Header file protos for "foreign export"ed functions. -- Header file protos for "foreign export"ed functions.
stub_h_output_d = pprCode CStyle h_code stub_h_output_d = pprCode CStyle h_code
stub_h_output_w = showSDoc dflags stub_h_output_d stub_h_output_w = showSDoc dflags stub_h_output_d
...@@ -208,7 +204,7 @@ outputForeignStubs dflags mod location stubs ...@@ -208,7 +204,7 @@ outputForeignStubs dflags mod location stubs
"Foreign export header file" stub_h_output_d "Foreign export header file" stub_h_output_d
-- we need the #includes from the rts package for the stub files -- 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 let rts_pkg = getPackageDetails dflags rtsPackageKey in
concatMap mk_include (includes rts_pkg) concatMap mk_include (includes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n" mk_include i = "#include \"" ++ i ++ "\"\n"
...@@ -226,7 +222,7 @@ outputForeignStubs dflags mod location stubs ...@@ -226,7 +222,7 @@ outputForeignStubs dflags mod location stubs
stub_c_file_exists stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w <- outputForeignStubs_help stub_c stub_c_output_w
("#define IN_STG_CODE 0\n" ++ ("#define IN_STG_CODE 0\n" ++
"#include \"Rts.h\"\n" ++ "#include \"Rts.h\"\n" ++
rts_includes ++ rts_includes ++
ffi_includes ++ ffi_includes ++
...@@ -252,4 +248,3 @@ outputForeignStubs_help _fname "" _header _footer = return False ...@@ -252,4 +248,3 @@ outputForeignStubs_help _fname "" _header _footer = return False
outputForeignStubs_help fname doc_str header footer outputForeignStubs_help fname doc_str header footer
= do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
return True 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} \section[Constants]{Info about this compilation}
-}
\begin{code}
module Constants (module Constants) where module Constants (module Constants) where
import Config import Config
...@@ -30,4 +30,3 @@ wORD64_SIZE = 8 ...@@ -30,4 +30,3 @@ wORD64_SIZE = 8
tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR :: Int
tARGET_MAX_CHAR = 0x10ffff 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} \section[ErrsUtils]{Utilities for error reporting}
-}
\begin{code}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module ErrUtils ( module ErrUtils (
MsgDoc, MsgDoc,
Validity(..), andValid, allValid, isValid, getInvalids, Validity(..), andValid, allValid, isValid, getInvalids,
ErrMsg, WarnMsg, Severity(..), ErrMsg, WarnMsg, Severity(..),
...@@ -130,7 +130,7 @@ mkLocMessage severity locn msg ...@@ -130,7 +130,7 @@ mkLocMessage severity locn msg
where where
sev_info = case severity of sev_info = case severity of
SevWarning -> ptext (sLit "Warning:") SevWarning -> ptext (sLit "Warning:")
_other -> empty _other -> empty
-- For warnings, print Foo.hs:34: Warning: -- For warnings, print Foo.hs:34: Warning:
-- <the warning message> -- <the warning message>
...@@ -417,5 +417,3 @@ prettyPrintGhcErrors dflags ...@@ -417,5 +417,3 @@ prettyPrintGhcErrors dflags
pprDebugAndThen dflags pgmError (text str) doc pprDebugAndThen dflags pgmError (text str) doc
_ -> _ ->
liftIO $ throwIO e liftIO $ throwIO e
\end{code}
\begin{code}
module ErrUtils where module ErrUtils where
import Outputable (SDoc) import Outputable (SDoc)
...@@ -16,5 +15,3 @@ data Severity ...@@ -16,5 +15,3 @@ data Severity
type MsgDoc = SDoc type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc 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} \section[Finder]{Module Finder}
-}
\begin{code}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Finder ( module Finder (
...@@ -258,7 +258,7 @@ uncacheModule hsc_env mod = do ...@@ -258,7 +258,7 @@ uncacheModule hsc_env mod = do
findHomeModule :: HscEnv -> ModuleName -> IO FindResult findHomeModule :: HscEnv -> ModuleName -> IO FindResult
findHomeModule hsc_env mod_name = findHomeModule hsc_env mod_name =
homeSearchCache hsc_env mod_name $ homeSearchCache hsc_env mod_name $
let let
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
home_path = importPaths dflags home_path = importPaths dflags
hisuf = hiSuf dflags hisuf = hiSuf dflags
...@@ -691,4 +691,3 @@ cantFindErr cannot_find _ dflags mod_name find_result ...@@ -691,4 +691,3 @@ cantFindErr cannot_find _ dflags mod_name find_result
= parens (ptext (sLit "needs flag -package-key") = parens (ptext (sLit "needs flag -package-key")
<+> ppr (packageConfigId pkg)) <+> ppr (packageConfigId pkg))
| otherwise = Outputable.empty | otherwise = Outputable.empty
\end{code}
\section[Hooks]{Low level API hooks} -- \section[Hooks]{Low level API hooks}
\begin{code}
module Hooks ( Hooks module Hooks ( Hooks
, emptyHooks , emptyHooks
, lookupHook , lookupHook
...@@ -40,15 +39,14 @@ import Type ...@@ -40,15 +39,14 @@ import Type
import SrcLoc import SrcLoc
import Data.Maybe import Data.Maybe
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{Hooks} \subsection{Hooks}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
-- | Hooks can be used by GHC API clients to replace parts of -- | Hooks can be used by GHC API clients to replace parts of
-- the compiler pipeline. If a hook is not installed, GHC -- the compiler pipeline. If a hook is not installed, GHC
...@@ -78,6 +76,3 @@ getHooked hook def = fmap (lookupHook hook def) getDynFlags ...@@ -78,6 +76,3 @@ getHooked hook def = fmap (lookupHook hook def) getDynFlags
lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
lookupHook hook def = fromMaybe def . hook . hooks lookupHook hook def = fromMaybe def . hook . hooks
\end{code}
\begin{code}
module Hooks where module Hooks where
data Hooks data Hooks
emptyHooks :: Hooks emptyHooks :: Hooks
\end{code}
% -- (c) The University of Glasgow, 2006
% (c) The University of Glasgow, 2006
%
\begin{code}
{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE CPP, ScopedTypeVariables #-}
-- | Package manipulation -- | Package manipulation
...@@ -1390,5 +1388,3 @@ pprModuleMap dflags = ...@@ -1390,5 +1388,3 @@ pprModuleMap dflags =
fsPackageName :: PackageConfig -> FastString fsPackageName :: PackageConfig -> FastString
fsPackageName = mkFastString . packageNameString fsPackageName = mkFastString . packageNameString
\end{code}
\begin{code}
module Packages where module Packages where
-- Well, this is kind of stupid... -- Well, this is kind of stupid...
import {-# SOURCE #-} Module (PackageKey) import {-# SOURCE #-} Module (PackageKey)
import {-# SOURCE #-} DynFlags (DynFlags) import {-# SOURCE #-} DynFlags (DynFlags)
data PackageState data PackageState
packageKeyPackageIdString :: DynFlags -> PackageKey -> String packageKeyPackageIdString :: DynFlags -> PackageKey -> String
\end{code}
{-
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- --
-- (c) The University of Glasgow 2001-2003 -- (c) The University of Glasgow 2001-2003
...@@ -5,8 +6,8 @@ ...@@ -5,8 +6,8 @@
-- Access to system tools: gcc, cp, rm etc -- Access to system tools: gcc, cp, rm etc
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-}
\begin{code}
{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE CPP, ScopedTypeVariables #-}
module SysTools ( module SysTools (
...@@ -96,8 +97,8 @@ import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) ...@@ -96,8 +97,8 @@ import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
# error Unknown mingw32 arch # error Unknown mingw32 arch
# endif # endif
#endif #endif
\end{code}
{-
How GHC finds its files How GHC finds its files
~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~
...@@ -162,13 +163,13 @@ stuff. ...@@ -162,13 +163,13 @@ stuff.
End of NOTES End of NOTES
--------------------------------------------- ---------------------------------------------
%************************************************************************ ************************************************************************
%* * * *
\subsection{Initialisation} \subsection{Initialisation}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
-> IO Settings -- Set all the mutable variables above, holding -> IO Settings -- Set all the mutable variables above, holding
-- (a) the system programs -- (a) the system programs
...@@ -351,9 +352,7 @@ initSysTools mbMinusB ...@@ -351,9 +352,7 @@ initSysTools mbMinusB
sOpt_lc = [], sOpt_lc = [],
sPlatformConstants = platformConstants sPlatformConstants = platformConstants
} }
\end{code}
\begin{code}
-- returns a Unix-format path (relying on getBaseDir to do so too) -- returns a Unix-format path (relying on getBaseDir to do so too)
findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
-> IO String -- TopDir (in Unix format '/' separated) -> IO String -- TopDir (in Unix format '/' separated)
...@@ -365,17 +364,15 @@ findTopDir Nothing ...@@ -365,17 +364,15 @@ findTopDir Nothing
-- "Just" on Windows, "Nothing" on unix -- "Just" on Windows, "Nothing" on unix
Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option") Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Just dir -> return dir Just dir -> return dir
\end{code}
{-
%************************************************************************ ************************************************************************
%* * * *
\subsection{Running an external program} \subsection{Running an external program}
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
runUnlit :: DynFlags -> [Option] -> IO () runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = do runUnlit dflags args = do
let prog = pgm_L dflags let prog = pgm_L dflags
...@@ -932,7 +929,7 @@ runLibtool dflags args = do ...@@ -932,7 +929,7 @@ runLibtool dflags args = do
linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
let args1 = map Option (getOpts dflags opt_l) let args1 = map Option (getOpts dflags opt_l)
args2 = [Option "-static"] ++ args1 ++ args ++ linkargs args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
libtool = pgm_libtool dflags libtool = pgm_libtool dflags
mb_env <- getGccEnv args2 mb_env <- getGccEnv args2
runSomethingFiltered dflags id "Linker" libtool args2 mb_env runSomethingFiltered dflags id "Linker" libtool args2 mb_env
...@@ -1019,15 +1016,15 @@ readElfSection _dflags section exe = do ...@@ -1019,15 +1016,15 @@ readElfSection _dflags section exe = do
_ <- string "0]" _ <- string "0]"
skipSpaces skipSpaces
munch (const True) munch (const True)
\end{code}
%************************************************************************ {-
%* * ************************************************************************
* *
\subsection{Managing temporary files \subsection{Managing temporary files
%* * * *
%************************************************************************ ************************************************************************
-}
\begin{code}
cleanTempDirs :: DynFlags -> IO () cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags cleanTempDirs dflags
= unless (gopt Opt_KeepTmpFiles dflags) = unless (gopt Opt_KeepTmpFiles dflags)
...@@ -1347,15 +1344,15 @@ traceCmd dflags phase_name cmd_line action ...@@ -1347,15 +1344,15 @@ traceCmd dflags phase_name cmd_line action
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) } ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}