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
%
\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
......@@ -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}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment