diff options
| author | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
|---|---|---|
| committer | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
| commit | 0065d5ab628975892cea1ec7303f968c3338cbe1 (patch) | |
| tree | 8e2afe0ab48ee33cf95009809d67c9649573ef92 /compiler/main | |
| parent | 28a464a75e14cece5db40f2765a29348273ff2d2 (diff) | |
| download | haskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz | |
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.
The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level. The build system now makes no
pretense at being multi-project, it is just the GHC build system.
No doubt this will break many things, and there will be a period of
instability while we fix the dependencies. A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.
Diffstat (limited to 'compiler/main')
27 files changed, 13012 insertions, 0 deletions
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs new file mode 100644 index 0000000000..e34b8c0857 --- /dev/null +++ b/compiler/main/CmdLineParser.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- +-- Command-line parser +-- +-- This is an abstract command-line parser used by both StaticFlags and +-- DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module CmdLineParser ( + processArgs, OptKind(..), + CmdLineP(..), getCmdLineState, putCmdLineState + ) where + +#include "HsVersions.h" + +import Util ( maybePrefixMatch, notNull, removeSpaces ) +#ifdef DEBUG +import Panic ( assertPanic ) +#endif + +data OptKind m + = NoArg (m ()) -- flag with no argument + | HasArg (String -> m ()) -- flag has an argument (maybe prefix) + | SepArg (String -> m ()) -- flag has a separate argument + | Prefix (String -> m ()) -- flag is a prefix only + | OptPrefix (String -> m ()) -- flag may be a prefix + | AnySuffix (String -> m ()) -- flag is a prefix, pass whole arg to fn + | PassFlag (String -> m ()) -- flag with no arg, pass flag to fn + | PrefixPred (String -> Bool) (String -> m ()) + | AnySuffixPred (String -> Bool) (String -> m ()) + +processArgs :: Monad m + => [(String, OptKind m)] -- cmdline parser spec + -> [String] -- args + -> m ( + [String], -- spare args + [String] -- errors + ) +processArgs spec args = process spec args [] [] + where + process _spec [] spare errs = + return (reverse spare, reverse errs) + + process spec args@(('-':arg):args') spare errs = + case findArg spec arg of + Just (rest,action) -> + case processOneArg action rest args of + Left err -> process spec args' spare (err:errs) + Right (action,rest) -> do + action >> process spec rest spare errs + Nothing -> + process spec args' (('-':arg):spare) errs + + process spec (arg:args) spare errs = + process spec args (arg:spare) errs + + +processOneArg :: OptKind m -> String -> [String] + -> Either String (m (), [String]) +processOneArg action rest (dash_arg@('-':arg):args) = + case action of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f -> + if rest /= "" + then Right (f rest, args) + else case args of + [] -> missingArgErr dash_arg + (arg1:args1) -> Right (f arg1, args1) + + SepArg f -> + case args of + [] -> unknownFlagErr dash_arg + (arg1:args1) -> Right (f arg1, args1) + + Prefix f -> + if rest /= "" + then Right (f rest, args) + else unknownFlagErr dash_arg + + PrefixPred p f -> + if rest /= "" + then Right (f rest, args) + else unknownFlagErr dash_arg + + OptPrefix f -> Right (f rest, args) + + AnySuffix f -> Right (f dash_arg, args) + + AnySuffixPred p f -> Right (f dash_arg, args) + + PassFlag f -> + if rest /= "" + then unknownFlagErr dash_arg + else Right (f dash_arg, args) + + +findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a) +findArg spec arg + = case [ (removeSpaces rest, k) + | (pat,k) <- spec, + Just rest <- [maybePrefixMatch pat arg], + arg_ok k rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok (NoArg _) rest arg = null rest +arg_ok (HasArg _) rest arg = True +arg_ok (SepArg _) rest arg = null rest +arg_ok (Prefix _) rest arg = notNull rest +arg_ok (PrefixPred p _) rest arg = notNull rest && p rest +arg_ok (OptPrefix _) rest arg = True +arg_ok (PassFlag _) rest arg = null rest +arg_ok (AnySuffix _) rest arg = True +arg_ok (AnySuffixPred p _) rest arg = p arg + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-- ----------------------------------------------------------------------------- +-- A state monad for use in the command-line parser + +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + +instance Monad (CmdLineP s) where + return a = CmdLineP $ \s -> (a, s) + m >>= k = CmdLineP $ \s -> let + (a, s') = runCmdLine m s + in runCmdLine (k a) s' + +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState s = CmdLineP $ \_ -> ((),s) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs new file mode 100644 index 0000000000..d1b293353a --- /dev/null +++ b/compiler/main/CodeOutput.lhs @@ -0,0 +1,303 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section{Code output phase} + +\begin{code} +module CodeOutput( codeOutput, outputForeignStubs ) where + +#include "HsVersions.h" + +#ifndef OMIT_NATIVE_CODEGEN +import UniqSupply ( mkSplitUniqSupply ) +import AsmCodeGen ( nativeCodeGen ) +#endif + +#ifdef ILX +import IlxGen ( ilxGen ) +#endif + +#ifdef JAVA +import JavaGen ( javaGen ) +import qualified PrintJava +import OccurAnal ( occurAnalyseBinds ) +#endif + +import Finder ( mkStubPaths ) +import PprC ( writeCs ) +import CmmLint ( cmmLint ) +import Packages +import Util +import FastString ( unpackFS ) +import Cmm ( Cmm ) +import HscTypes +import DynFlags +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) +import Outputable +import Pretty ( Mode(..), printDoc ) +import Module ( Module, ModLocation(..) ) +import List ( nub ) +import Maybes ( firstJust ) + +import Distribution.Package ( showPackageId ) +import Directory ( doesFileExist ) +import Monad ( when ) +import IO +\end{code} + +%************************************************************************ +%* * +\subsection{Steering} +%* * +%************************************************************************ + +\begin{code} +codeOutput :: DynFlags + -> Module + -> ModLocation + -> ForeignStubs + -> [PackageId] + -> [Cmm] -- Compiled C-- + -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + +codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC + = + -- You can have C (c_output) or assembly-language (ncg_output), + -- but not both. [Allowing for both gives a space leak on + -- flat_abstractC. WDP 94/10] + + -- Dunno if the above comment is still meaningful now. JRS 001024. + + do { when (dopt Opt_DoCmmLinting dflags) $ do + { showPass dflags "CmmLint" + ; let lints = map cmmLint flat_abstractC + ; case firstJust lints of + Just err -> do { printDump err + ; ghcExit dflags 1 + } + Nothing -> return () + } + + ; showPass dflags "CodeOutput" + ; let filenm = hscOutName dflags + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; case hscTarget dflags of { + HscInterpreted -> return (); + HscAsm -> outputAsm dflags filenm flat_abstractC; + HscC -> outputC dflags filenm this_mod location + flat_abstractC stubs_exist pkg_deps + foreign_stubs; + HscJava -> +#ifdef JAVA + outputJava dflags filenm mod_name tycons core_binds; +#else + panic "Java support not compiled into this ghc"; +#endif + HscILX -> +#ifdef ILX + let tycons = typeEnvTyCons type_env in + outputIlx dflags filenm mod_name tycons stg_binds; +#else + panic "ILX support not compiled into this ghc"; +#endif + } + ; return stubs_exist + } + +doOutput :: String -> (Handle -> IO ()) -> IO () +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action +\end{code} + + +%************************************************************************ +%* * +\subsection{C} +%* * +%************************************************************************ + +\begin{code} +outputC dflags filenm mod location flat_absC + (stub_h_exists, _) packages foreign_stubs + = do + -- figure out which header files to #include in the generated .hc file: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + pkg_configs <- getExplicitPackagesAnd dflags packages + let pkg_names = map (showPackageId.package) pkg_configs + + c_includes <- getPackageCIncludes pkg_configs + let cmdline_includes = cmdlineHcIncludes dflags -- -#include options + + ffi_decl_headers + = case foreign_stubs of + NoStubs -> [] + ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) + -- Remove duplicates, because distinct foreign import decls + -- may cite the same #include. Order doesn't matter. + + all_headers = c_includes + ++ reverse cmdline_includes + ++ ffi_decl_headers + + let cc_injects = unlines (map mk_include all_headers) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects + when stub_h_exists $ + hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") + writeCs dflags h flat_absC + where + (_, stub_h) = mkStubPaths dflags mod location +\end{code} + + +%************************************************************************ +%* * +\subsection{Assembler} +%* * +%************************************************************************ + +\begin{code} +outputAsm dflags filenm flat_absC + +#ifndef OMIT_NATIVE_CODEGEN + + = do ncg_uniqs <- mkSplitUniqSupply 'n' + ncg_output_d <- _scc_ "NativeCodeGen" + nativeCodeGen dflags flat_absC ncg_uniqs + dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d) + _scc_ "OutputAsm" doOutput filenm $ + \f -> printDoc LeftMode f ncg_output_d + where + +#else /* OMIT_NATIVE_CODEGEN */ + + = pprPanic "This compiler was built without a native code generator" + (text "Use -fvia-C instead") + +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Java} +%* * +%************************************************************************ + +\begin{code} +#ifdef JAVA +outputJava dflags filenm mod tycons core_binds + = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java) + -- User style printing for now to keep indentation + where + occ_anal_binds = occurAnalyseBinds core_binds + -- Make sure we have up to date dead-var information + java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds + pp_java = PrintJava.compilationUnit java_code +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Ilx} +%* * +%************************************************************************ + +\begin{code} +#ifdef ILX +outputIlx dflags filename mod tycons stg_binds + = doOutput filename (\ f -> printForC f pp_ilx) + where + pp_ilx = ilxGen mod tycons stg_binds +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Foreign import/export} +%* * +%************************************************************************ + +\begin{code} +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Bool) -- C file created +outputForeignStubs dflags mod location stubs + | NoStubs <- stubs = do + -- When compiling External Core files, may need to use stub + -- files from a previous compilation + stub_c_exists <- doesFileExist stub_c + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, stub_c_exists) + + | ForeignStubs h_code c_code _ _ <- stubs + = do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc 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 stub_h_output_d + -- in + + createDirectoryHierarchy (directoryOf stub_c) + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export header file" stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rtsid = rtsPackageId (pkgState dflags) + rts_includes + | ExtPackage pid <- rtsid = + let rts_pkg = getPackageDetails (pkgState dflags) pid in + concatMap mk_include (includes rts_pkg) + | otherwise = [] + mk_include i = "#include \"" ++ i ++ "\"\n" + + stub_h_file_exists + <- outputForeignStubs_help stub_h stub_h_output_w + ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export stubs" stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include \"Rts.h\"\n" ++ + rts_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, stub_c_file_exists) + where + (stub_c, stub_h) = mkStubPaths dflags mod location + +cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" +cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" + +-- Don't use doOutput for dumping the f. export stubs +-- since it is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +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} + diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs new file mode 100644 index 0000000000..43db93249a --- /dev/null +++ b/compiler/main/Constants.lhs @@ -0,0 +1,150 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Constants]{Info about this compilation} + +\begin{code} +module Constants (module Constants) where + +-- This magical #include brings in all the everybody-knows-these magic +-- constants unfortunately, we need to be *explicit* about which one +-- we want; if we just hope a -I... will get the right one, we could +-- be in trouble. + +#include "HsVersions.h" +#include "../includes/MachRegs.h" +#include "../includes/Constants.h" +#include "../includes/MachDeps.h" +#include "../includes/DerivedConstants.h" + +-- import Util +\end{code} + +All pretty arbitrary: + +\begin{code} +mAX_TUPLE_SIZE = (62 :: Int) -- Should really match the number + -- of decls in Data.Tuple +mAX_CONTEXT_REDUCTION_DEPTH = (20 :: Int) +\end{code} + + +\begin{code} +-- specialised fun/thunk/constr closure types +mAX_SPEC_THUNK_SIZE = (MAX_SPEC_THUNK_SIZE :: Int) +mAX_SPEC_FUN_SIZE = (MAX_SPEC_FUN_SIZE :: Int) +mAX_SPEC_CONSTR_SIZE = (MAX_SPEC_CONSTR_SIZE :: Int) + +-- pre-compiled thunk types +mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int) +mAX_SPEC_AP_SIZE = (MAX_SPEC_AP_SIZE :: Int) + +-- closure sizes: these do NOT include the header (see below for header sizes) +mIN_PAYLOAD_SIZE = (MIN_PAYLOAD_SIZE::Int) +\end{code} + +\begin{code} +mIN_INTLIKE, mAX_INTLIKE :: Int +mIN_INTLIKE = MIN_INTLIKE +mAX_INTLIKE = MAX_INTLIKE + +mIN_CHARLIKE, mAX_CHARLIKE :: Int +mIN_CHARLIKE = MIN_CHARLIKE +mAX_CHARLIKE = MAX_CHARLIKE +\end{code} + +A section of code-generator-related MAGIC CONSTANTS. + +\begin{code} +mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary +-- If you change this, you may need to change runtimes/standard/Update.lhc +\end{code} + +\begin{code} +mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int) +mAX_Float_REG = (MAX_FLOAT_REG :: Int) +mAX_Double_REG = (MAX_DOUBLE_REG :: Int) +mAX_Long_REG = (MAX_LONG_REG :: Int) + +mAX_Real_Vanilla_REG = (MAX_REAL_VANILLA_REG :: Int) +mAX_Real_Float_REG = (MAX_REAL_FLOAT_REG :: Int) +mAX_Real_Double_REG = (MAX_REAL_DOUBLE_REG :: Int) +#ifdef MAX_REAL_LONG_REG +mAX_Real_Long_REG = (MAX_REAL_LONG_REG :: Int) +#else +mAX_Real_Long_REG = (0::Int) +#endif +\end{code} + +Closure header sizes. + +\begin{code} +sTD_HDR_SIZE = (STD_HDR_SIZE :: Int) +pROF_HDR_SIZE = (PROF_HDR_SIZE :: Int) +gRAN_HDR_SIZE = (GRAN_HDR_SIZE :: Int) +\end{code} + +Info Table sizes. + +\begin{code} +sTD_ITBL_SIZE = (STD_ITBL_SIZE :: Int) +rET_ITBL_SIZE = (RET_ITBL_SIZE :: Int) +pROF_ITBL_SIZE = (PROF_ITBL_SIZE :: Int) +gRAN_ITBL_SIZE = (GRAN_ITBL_SIZE :: Int) +tICKY_ITBL_SIZE = (TICKY_ITBL_SIZE :: Int) +\end{code} + +Size of a double in StgWords. + +\begin{code} +dOUBLE_SIZE = SIZEOF_DOUBLE :: Int +wORD64_SIZE = 8 :: Int +iNT64_SIZE = wORD64_SIZE +\end{code} + +This tells the native code generator the size of the spill +area is has available. + +\begin{code} +rESERVED_C_STACK_BYTES = (RESERVED_C_STACK_BYTES :: Int) +\end{code} + +The amount of (Haskell) stack to leave free for saving registers when +returning to the scheduler. + +\begin{code} +rESERVED_STACK_WORDS = (RESERVED_STACK_WORDS :: Int) +\end{code} + +Size of a word, in bytes + +\begin{code} +wORD_SIZE = (SIZEOF_HSWORD :: Int) +wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int +\end{code} + +Size of a C int, in bytes. May be smaller than wORD_SIZE. + +\begin{code} +cINT_SIZE = (SIZEOF_INT :: Int) +\end{code} + +Size of a storage manager block (in bytes). + +\begin{code} +bLOCK_SIZE = (BLOCK_SIZE :: Int) +bLOCK_SIZE_W = (bLOCK_SIZE `quot` wORD_SIZE :: Int) +\end{code} + +Number of bits to shift a bitfield left by in an info table. + +\begin{code} +bITMAP_BITS_SHIFT = (BITMAP_BITS_SHIFT :: Int) +\end{code} + +Constants derived from headers in ghc/includes, generated by the program +../includes/mkDerivedConstants.c. + +\begin{code} +#include "../includes/GHCConstants.h" +\end{code} diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs new file mode 100644 index 0000000000..80d906c4a7 --- /dev/null +++ b/compiler/main/DriverMkDepend.hs @@ -0,0 +1,342 @@ +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DriverMkDepend ( + doMkDependHS + ) where + +#include "HsVersions.h" + +import qualified GHC +import GHC ( Session, ModSummary(..) ) +import DynFlags ( DynFlags( verbosity, opt_dep ), getOpts ) +import Util ( escapeSpaces, splitFilename, joinFileExt ) +import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath ) +import Packages ( PackageIdH(..) ) +import SysTools ( newTempName ) +import qualified SysTools +import Module ( Module, ModLocation(..), mkModule, + addBootSuffix_maybe ) +import Digraph ( SCC(..) ) +import Finder ( findModule, FindResult(..) ) +import Util ( global, consIORef ) +import Outputable +import Panic +import SrcLoc ( unLoc ) +import CmdLineParser + +#if __GLASGOW_HASKELL__ <= 408 +import Panic ( catchJust, ioErrors ) +#endif +import ErrUtils ( debugTraceMsg, printErrorsAndWarnings ) + +import DATA_IOREF ( IORef, readIORef, writeIORef ) +import EXCEPTION + +import System ( ExitCode(..), exitWith ) +import Directory +import IO +import Monad ( when ) +import Maybe ( isJust ) + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: Session -> [FilePath] -> IO () +doMkDependHS session srcs + = do { -- Initialisation + dflags <- GHC.getSessionDynFlags session + ; files <- beginMkDependHS dflags + + -- Do the downsweep to find all the modules + ; targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + ; GHC.setTargets session targets + ; excl_mods <- readIORef v_Dep_exclude_mods + ; r <- GHC.depanal session excl_mods True {- Allow dup roots -} + ; case r of + Nothing -> exitWith (ExitFailure 1) + Just mod_summaries -> do { + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False mod_summaries Nothing + + -- Print out the dependencies if wanted + ; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + + -- Prcess them one by one, dumping results into makefile + -- and complaining about cycles + ; mapM (processDeps session excl_mods (mkd_tmp_hdl files)) sorted + + -- Tidy up + ; endMkDependHS dflags files }} + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: DynFlags -> IO MkDepFiles + +beginMkDependHS dflags = do + -- slurp in the mkdependHS-style options + let flags = getOpts dflags opt_dep + _ <- processArgs dep_opts flags + + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName dflags "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + makefile <- readIORef v_Dep_makefile + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchJust ioErrors slurp + (\e -> if isEOFError e then return () else ioError e) + catchJust ioErrors chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: Session + -> [Module] + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps session excl_mods hdl (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwDyn (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + +processDeps session excl_mods hdl (AcyclicSCC node) + = do { extra_suffixes <- readIORef v_Dep_suffixes + ; hsc_env <- GHC.sessionHscEnv session + ; include_pkg_deps <- readIORef v_Dep_include_pkg_deps + ; let src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp is_boot imp_mod + = do { mb_hi <- findDependency hsc_env src_file imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency hdl obj_files src_file + + -- Emit a dependency for each import + + -- SOURCE imports + ; mapM_ (do_imp True) + (filter (`notElem` excl_mods) (map unLoc (ms_srcimps node))) + + -- regular imports + ; mapM_ (do_imp False) + (filter (`notElem` excl_mods) (map unLoc (ms_imps node))) + } + + +findDependency :: HscEnv + -> FilePath -- Importing module: used only for error msg + -> Module -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file file +findDependency hsc_env src imp is_boot include_pkg_deps + = do { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findModule hsc_env imp True {-explicit-} + ; case r of + Found loc pkg + -- Not in this package: we don't need a dependency + | ExtPackage _ <- pkg, not include_pkg_deps + -> return Nothing + + -- Home package: just depend on the .hi or hi-boot file + | otherwise + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + _ -> panic "findDependency" + } + +----------------------------- +writeDependency :: Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency hdl targets dep + = hPutStrLn hdl (unwords (map escapeSpaces targets) ++ " : " + ++ escapeSpaces dep) + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Extra suffices e.g. ["x","y"] + -> [FilePath] -- Zapped filenames e.g. ["foo.o", "foo.x_o", "foo.y_o"] + -- Note that that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we can strip it with removeSuffix + + -- NOTE: we used to have this comment + -- In order to construct hi files with alternate suffixes, we + -- now have to find the "basename" of the hi file. This is + -- difficult because we can't just split the hi filename + -- at the last dot - the hisuf might have dots in it. So we + -- check whether the hi filename ends in hisuf, and if it does, + -- we strip off hisuf, otherwise we strip everything after the + -- last dot. + -- But I'm not sure we care about hisufs with dots in them. + -- Lots of other things will break first! + +insertSuffixes file_name extras + = file_name : [ basename `joinFileExt` (extra ++ "_" ++ suffix) | extra <- extras ] + where + (basename, suffix) = splitFilename file_name + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: DynFlags -> MkDepFiles -> IO () + +endMkDependHS dflags + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the original makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchJust ioErrors slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) + + -- Copy the new makefile in place + SysTools.copy dflags "Installing new makefile" tmp_file makefile + + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + + -- Flags +GLOBAL_VAR(v_Dep_makefile, "Makefile", String); +GLOBAL_VAR(v_Dep_include_pkg_deps, False, Bool); +GLOBAL_VAR(v_Dep_exclude_mods, [], [Module]); +GLOBAL_VAR(v_Dep_suffixes, [], [String]); +GLOBAL_VAR(v_Dep_warnings, True, Bool); + +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + +-- for compatibility with the old mkDependHS, we accept options of the form +-- -optdep-f -optdep.depend, etc. +dep_opts = + [ ( "s", SepArg (consIORef v_Dep_suffixes) ) + , ( "f", SepArg (writeIORef v_Dep_makefile) ) + , ( "w", NoArg (writeIORef v_Dep_warnings False) ) + , ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) ) + , ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) ) + , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) + , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) + ] diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs new file mode 100644 index 0000000000..6e945314cb --- /dev/null +++ b/compiler/main/DriverPhases.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module DriverPhases ( + HscSource(..), isHsBoot, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, -- :: String -> Phase + phaseInputExt, -- :: Phase -> String + + isHaskellishSuffix, + isHaskellSrcSuffix, + isObjectSuffix, + isCishSuffix, + isExtCoreSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isSourceSuffix, + + isHaskellishFilename, + isHaskellSrcFilename, + isObjectFilename, + isCishFilename, + isExtCoreFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename -- :: FilePath -> Bool + ) where + +import Util ( suffixOf ) +import Panic ( panic ) + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out +-} + +data HscSource + = HsSrcFile | HsBootFile | ExtCoreFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString ExtCoreFile = "[ext core]" + +isHsBoot :: HscSource -> Bool +isHsBoot HsBootFile = True +isHsBoot other = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Cc + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | Mangle -- assembly mangling, now done by a separate script. + | SplitMangle -- after mangler if splitting + | SplitAs + | As + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn other = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase HCc HCc = True +eqPhase Mangle Mangle = True +eqPhase SplitMangle SplitMangle = True +eqPhase SplitAs SplitAs = True +eqPhase As As = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase StopLn StopLn = True +eqPhase _ _ = False + +-- Partial ordering on phases: we want to know which phases will occur before +-- which others. This is used for sanity checking, to ensure that the +-- pipeline will stop at some point (see DriverPipeline.runPipeline). +StopLn `happensBefore` y = False +x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y + where + after_x = nextPhase x + +nextPhase :: Phase -> Phase +-- A conservative approximation the next phase, used in happensBefore +nextPhase (Unlit sf) = Cpp sf +nextPhase (Cpp sf) = HsPp sf +nextPhase (HsPp sf) = Hsc sf +nextPhase (Hsc sf) = HCc +nextPhase HCc = Mangle +nextPhase Mangle = SplitMangle +nextPhase SplitMangle = As +nextPhase As = SplitAs +nextPhase SplitAs = StopLn +nextPhase Cc = As +nextPhase CmmCpp = Cmm +nextPhase Cmm = HCc +nextPhase StopLn = panic "nextPhase: nothing after StopLn" + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hcr" = Hsc ExtCoreFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Cc +startPhase "C" = Cc +startPhase "cc" = Cc +startPhase "cxx" = Cc +startPhase "raw_s" = Mangle +startPhase "split_s" = SplitMangle +startPhase "s" = As +startPhase "S" = As +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit ExtCoreFile) = "lhcr" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Cc = "c" +phaseInputExt Mangle = "raw_s" +phaseInputExt SplitMangle = "split_s" -- not really generated +phaseInputExt As = "s" +phaseInputExt SplitAs = "split_s" -- not really generated +phaseInputExt CmmCpp = "cmm" +phaseInputExt Cmm = "cmmcpp" +phaseInputExt StopLn = "o" +#ifdef ILX +phaseInputExt Ilx2Il = "ilx" +phaseInputExt Ilasm = "il" +#endif + +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp", "hcr", "cmm" ] +haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ] +extcoreish_suffixes = [ "hcr" ] +haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] -- Will not be deleted as temp files + +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +#if mingw32_TARGET_OS || cygwin32_TARGET_OS +objish_suffixes = [ "o", "O", "obj", "OBJ" ] +#else +objish_suffixes = [ "o" ] +#endif + +#ifdef mingw32_TARGET_OS +dynlib_suffixes = ["dll", "DLL"] +#elif defined(darwin_TARGET_OS) +dynlib_suffixes = ["dylib"] +#else +dynlib_suffixes = ["so"] +#endif + +isHaskellishSuffix s = s `elem` haskellish_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isExtCoreSuffix s = s `elem` extcoreish_suffixes +isObjectSuffix s = s `elem` objish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes +isDynLibSuffix s = s `elem` dynlib_suffixes + +isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + +isHaskellishFilename f = isHaskellishSuffix (suffixOf f) +isHaskellSrcFilename f = isHaskellSrcSuffix (suffixOf f) +isCishFilename f = isCishSuffix (suffixOf f) +isExtCoreFilename f = isExtCoreSuffix (suffixOf f) +isObjectFilename f = isObjectSuffix (suffixOf f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (suffixOf f) +isDynLibFilename f = isDynLibSuffix (suffixOf f) +isSourceFilename f = isSourceSuffix (suffixOf f) + + diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs new file mode 100644 index 0000000000..e20bc56940 --- /dev/null +++ b/compiler/main/DriverPipeline.hs @@ -0,0 +1,1405 @@ +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DriverPipeline ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + staticLink, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compile, CompResult(..), + link, + + -- DLL building + doMkDLL, + + ) where + +#include "HsVersions.h" + +import Packages +import HeaderInfo +import DriverPhases +import SysTools ( newTempName, addFilesToClean, getSysMan, copy ) +import qualified SysTools +import HscMain +import Finder +import HscTypes +import Outputable +import Module +import ErrUtils +import DynFlags +import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) +import Config +import Panic +import Util +import StringBuffer ( hGetStringBuffer ) +import BasicTypes ( SuccessFlag(..) ) +import Maybes ( expectJust ) +import ParserCoreUtils ( getCoreModuleName ) +import SrcLoc ( unLoc ) +import SrcLoc ( Located(..) ) + +import EXCEPTION +import DATA_IOREF ( readIORef, writeIORef, IORef ) +import GLAEXTS ( Int(..) ) + +import Directory +import System +import IO +import Monad +import Data.List ( isSuffixOf ) +import Maybe + + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath) +preprocess dflags (filename, mb_phase) = + ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) + runPipeline anyHsc dflags (filename, mb_phase) Temporary Nothing{-no ModLocation-} + +-- --------------------------------------------------------------------------- +-- Compile + +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, and passing the +-- output of hsc through the C compiler. + +-- NB. No old interface can also mean that the source has changed. + +compile :: HscEnv + -> ModSummary + -> Maybe Linkable -- Just linkable <=> source unchanged + -> Maybe ModIface -- Old interface, if available + -> Int -> Int + -> IO CompResult + +data CompResult + = CompOK ModDetails -- New details + ModIface -- New iface + (Maybe Linkable) -- a Maybe, for the same reasons as hm_linkable + + | CompErrs + + +compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do + + let dflags0 = ms_hspp_opts mod_summary + this_mod = ms_mod mod_summary + src_flavour = ms_hsc_src mod_summary + + have_object + | Just l <- maybe_old_linkable, isObjectLinkable l = True + | otherwise = False + + -- FIXME: We need to know whether or not we're recompiling the file. Move this to HscMain? + --showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary) + + let location = ms_location mod_summary + let input_fn = expectJust "compile:hs" (ml_hs_file location) + let input_fnpp = ms_hspp_file mod_summary + + debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) + + let (basename, _) = splitFilename input_fn + + -- We add the directory in which the .hs files resides) to the import path. + -- This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + let current_dir = directoryOf basename + old_paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : old_paths } + + -- Figure out what lang we're generating + let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + -- ... and what the next phase should be + let next_phase = hscNextPhase dflags src_flavour hsc_lang + -- ... and what file to generate the output into + output_fn <- getOutputFilename dflags next_phase + Temporary basename next_phase (Just location) + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + + -- -no-recomp should also work with --make + let do_recomp = dopt Opt_RecompChecking dflags + source_unchanged = isJust maybe_old_linkable && do_recomp + hsc_env' = hsc_env { hsc_dflags = dflags' } + object_filename = ml_obj_file location + + let getStubLinkable False = return [] + getStubLinkable True + = do stub_o <- compileStub dflags' this_mod location + return [ DotO stub_o ] + + handleBatch (HscNoRecomp, iface, details) + = ASSERT (isJust maybe_old_linkable) + return (CompOK details iface maybe_old_linkable) + handleBatch (HscRecomp hasStub, iface, details) + | isHsBoot src_flavour + = return (CompOK details iface Nothing) + | otherwise + = do stub_unlinked <- getStubLinkable hasStub + (hs_unlinked, unlinked_time) <- + case hsc_lang of + HscNothing + -> return ([], ms_hs_date mod_summary) + -- We're in --make mode: finish the compilation pipeline. + _other + -> do runPipeline StopLn dflags (output_fn,Nothing) Persistent + (Just location) + -- The object filename comes from the ModLocation + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + let linkable = LM unlinked_time this_mod + (hs_unlinked ++ stub_unlinked) + return (CompOK details iface (Just linkable)) + + handleInterpreted (InteractiveNoRecomp, iface, details) + = ASSERT (isJust maybe_old_linkable) + return (CompOK details iface maybe_old_linkable) + handleInterpreted (InteractiveRecomp hasStub comp_bc, iface, details) + = do stub_unlinked <- getStubLinkable hasStub + let hs_unlinked = [BCOs comp_bc] + unlinked_time = ms_hs_date mod_summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let linkable = LM unlinked_time this_mod + (hs_unlinked ++ stub_unlinked) + return (CompOK details iface (Just linkable)) + + let runCompiler compiler handle + = do mbResult <- compiler hsc_env' mod_summary + source_unchanged old_iface + (Just (mod_index, nmods)) + case mbResult of + Nothing -> return CompErrs + Just result -> handle result + -- run the compiler + case hsc_lang of + HscInterpreted | not (isHsBoot src_flavour) -- We can't compile boot files to + -- bytecode so don't even try. + -> runCompiler hscCompileInteractive handleInterpreted + HscNothing + -> runCompiler hscCompileNothing handleBatch + _other + -> runCompiler hscCompileBatch handleBatch + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support) + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- Consequently, we derive the _stub.o filename from the haskell object +-- filename. +-- +-- This isn't necessarily the same as the object filename we +-- would get if we just compiled the _stub.c file using the pipeline. +-- For example: +-- +-- ghc src/A.hs -odir obj +-- +-- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with +-- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want +-- obj/A_stub.o. + +compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath +compileStub dflags mod location = do + let (o_base, o_ext) = splitFilename (ml_obj_file location) + stub_o = o_base ++ "_stub" `joinFileExt` o_ext + + -- compile the _stub.c file w/ gcc + let (stub_c,_) = mkStubPaths dflags mod location + runPipeline StopLn dflags (stub_c,Nothing) + (SpecificFile stub_o) Nothing{-no ModLocation-} + + return stub_o + + +-- --------------------------------------------------------------------------- +-- Link + +link :: GhcMode -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +#ifdef GHCI +link Interactive dflags batch_attempt_linking hpt + = do -- Not Linking...(demand linker will do the job) + return Succeeded +#endif + +link JustTypecheck dflags batch_attempt_linking hpt + = return Succeeded + +link BatchCompile dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + home_mod_infos = moduleEnvElts hpt + + -- the packages we depend on + pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName dflags + + -- if the modification time on the executable is later than the + -- modification times on all of the objects, then omit linking + -- (unless the -no-recomp flag was given). + e_exe_time <- IO.try $ getModificationTime exe_file + let linking_needed + | Left _ <- e_exe_time = True + | Right t <- e_exe_time = + any (t <) (map linkableTime linkables) + + if dopt Opt_RecompChecking dflags && not linking_needed + then do debugTraceMsg dflags 1 (text exe_file <+> ptext SLIT("is up to date, linking not required.")) + return Succeeded + else do + + debugTraceMsg dflags 1 (ptext SLIT("Linking") <+> text exe_file + <+> text "...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + MkDLL -> doMkDLL + StaticLink -> staticLink + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- staticLink only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot dflags stop_phase srcs = do + o_files <- mapM (compileFile dflags stop_phase) srcs + doLink dflags stop_phase o_files + +compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile dflags stop_phase (src, mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwDyn (CmdLineError ("does not exist: " ++ src)) + + let + split = dopt Opt_SplitObjs dflags + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | Just o_file <- mb_o_file = SpecificFile o_file + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + stop_phase' = case stop_phase of + As | split -> SplitAs + other -> stop_phase + + (_, out_file) <- runPipeline stop_phase' dflags + (src, mb_phase) output Nothing{-no ModLocation-} + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + StaticLink -> staticLink dflags o_files link_pkgs + MkDLL -> doMkDLL dflags o_files link_pkgs + where + -- Always link in the haskell98 package for static linking. Other + -- packages have to be specified via the -package flag. + link_pkgs + | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id] + | otherwise = [] + + +-- --------------------------------------------------------------------------- +-- Run a compilation pipeline, consisting of multiple phases. + +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. + +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- GHC_OPTIONS pragmas), and the changes affect later phases in the +-- pipeline. + +data PipelineOutput + = Temporary + -- output should be to a temporary file: we're going to + -- run more compilation steps on this output later + | Persistent + -- we want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile FilePath + -- the output must go into the specified file. + +runPipeline + :: Phase -- When to stop + -> DynFlags -- Dynamic flags + -> (FilePath,Maybe Phase) -- Input filename (and maybe -x suffix) + -> PipelineOutput -- Output filename + -> Maybe ModLocation -- A ModLocation, if this is a Haskell module + -> IO (DynFlags, FilePath) -- (final flags, output filename) + +runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc + = do + let (basename, suffix) = splitFilename input_fn + + -- If we were given a -x flag, then use that phase to start from + start_phase + | Just x_phase <- mb_phase = x_phase + | otherwise = startPhase suffix + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + -- + -- There is a partial ordering on phases, where A < B iff A occurs + -- before B in a normal compilation pipeline. + + when (not (start_phase `happensBefore` stop_phase)) $ + throwDyn (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + + -- this is a function which will be used to calculate output file names + -- as we go along (we partially apply it to some of its inputs here) + let get_output_fn = getOutputFilename dflags stop_phase output basename + + -- Execute the pipeline... + (dflags', output_fn, maybe_loc) <- + pipeLoop dflags start_phase stop_phase input_fn + basename suffix get_output_fn maybe_loc + + -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file. + case output of + Temporary -> + return (dflags', output_fn) + _other -> + do final_fn <- get_output_fn stop_phase maybe_loc + when (final_fn /= output_fn) $ + copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn + ++ "'") output_fn final_fn + return (dflags', final_fn) + + + +pipeLoop :: DynFlags -> Phase -> Phase + -> FilePath -> String -> Suffix + -> (Phase -> Maybe ModLocation -> IO FilePath) + -> Maybe ModLocation + -> IO (DynFlags, FilePath, Maybe ModLocation) + +pipeLoop dflags phase stop_phase + input_fn orig_basename orig_suff + orig_get_output_fn maybe_loc + + | phase `eqPhase` stop_phase -- All done + = return (dflags, input_fn, maybe_loc) + + | not (phase `happensBefore` stop_phase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + = panic ("pipeLoop: at phase " ++ show phase ++ + " but I wanted to stop at phase " ++ show stop_phase) + + | otherwise + = do { (next_phase, dflags', maybe_loc, output_fn) + <- runPhase phase stop_phase dflags orig_basename + orig_suff input_fn orig_get_output_fn maybe_loc + ; pipeLoop dflags' next_phase stop_phase output_fn + orig_basename orig_suff orig_get_output_fn maybe_loc } + +getOutputFilename + :: DynFlags -> Phase -> PipelineOutput -> String + -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename dflags stop_phase output basename + = func + where + hcsuf = hcSuf dflags + odir = objectDir dflags + osuf = objectSuf dflags + keep_hc = dopt Opt_KeepHcFiles dflags + keep_raw_s = dopt Opt_KeepRawSFiles dflags + keep_s = dopt Opt_KeepSFiles dflags + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + func next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile f <- output = return f + | keep_this_output = persistent_fn + | otherwise = newTempName dflags suffix + where + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + StopLn -> True + Mangle | keep_raw_s -> True + As | keep_s -> True + HCc | keep_hc -> True + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename `joinFileExt` suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | Just d <- odir = d `joinFileName` persistent + | otherwise = persistent + + +-- ----------------------------------------------------------------------------- +-- Each phase in the pipeline returns the next phase to execute, and the +-- name of the file in which the output was placed. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the via-C route to using the native code generator. + +runPhase :: Phase -- Do this phase first + -> Phase -- Stop just before this phase + -> DynFlags + -> String -- basename of original input source + -> String -- its extension + -> FilePath -- name of file which contains the input to this phase. + -> (Phase -> Maybe ModLocation -> IO FilePath) + -- how to calculate the output filename + -> Maybe ModLocation -- the ModLocation, if we have one + -> IO (Phase, -- next phase + DynFlags, -- new dynamic flags + Maybe ModLocation, -- the ModLocation, if we have one + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_loc + = do let unlit_flags = getOpts dflags opt_L + -- The -h option passes the file name for unlit to put in a #line directive + output_fn <- get_output_fn (Cpp sf) maybe_loc + + SysTools.runUnlit dflags + (map SysTools.Option unlit_flags ++ + [ SysTools.Option "-h" + , SysTools.Option input_fn + , SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ]) + + return (Cpp sf, dflags, maybe_loc, output_fn) + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc + = do src_opts <- getOptionsFromFile input_fn + (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts) + checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff) + + if not (dopt Opt_Cpp dflags) then + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (HsPp sf, dflags, maybe_loc, input_fn) + else do + output_fn <- get_output_fn (HsPp sf) maybe_loc + doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn + return (HsPp sf, dflags, maybe_loc, output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc + = do if not (dopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (Hsc sf, dflags, maybe_loc, input_fn) + else do + let hspp_opts = getOpts dflags opt_F + let orig_fn = basename `joinFileExt` suff + output_fn <- get_output_fn (Hsc sf) maybe_loc + SysTools.runPp dflags + ( [ SysTools.Option orig_fn + , SysTools.Option input_fn + , SysTools.FileOption "" output_fn + ] ++ + map SysTools.Option hspp_opts + ) + return (Hsc sf, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _maybe_loc + = do -- normal Hsc mode, not mkdependHS + + -- we add the current directory (i.e. the directory in which + -- the .hs files resides) to the import path, since this is + -- what gcc does, and it's probably what you want. + let current_dir = directoryOf basename + + paths = includePaths dflags0 + dflags = dflags0 { includePaths = current_dir : paths } + + -- gather the imports and module name + (hspp_buf,mod_name) <- + case src_flavour of + ExtCoreFile -> do { -- no explicit imports in ExtCore input. + ; m <- getCoreModuleName input_fn + ; return (Nothing, mkModule m) } + + other -> do { buf <- hGetStringBuffer input_fn + ; (_,_,L _ mod_name) <- getImports dflags buf input_fn + ; return (Just buf, mod_name) } + + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames, and this is as good a way + -- as any to generate them, and better than most. (e.g. takes + -- into accout the -osuf flags) + location1 <- mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + + -- Make the ModSummary to hand to hscMain + src_timestamp <- getModificationTime (basename `joinFileExt` suff) + let + unused_field = panic "runPhase:ModSummary field" + -- Some fields are not looked at by hscMain + mod_summary = ModSummary { ms_mod = mod_name, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location4, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_imps = unused_field, + ms_srcimps = unused_field } + + o_file = ml_obj_file location4 -- The real object file + + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + let do_recomp = dopt Opt_RecompChecking dflags + source_unchanged <- + if not do_recomp || not (isStopLn stop) + -- Set source_unchanged to False unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return False + -- Otherwise look at file modification dates + else do o_file_exists <- doesFileExist o_file + if not o_file_exists + then return False -- Need to recompile + else do t2 <- getModificationTime o_file + if t2 > src_timestamp + then return True + else return False + + -- get the DynFlags + let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) + let next_phase = hscNextPhase dflags src_flavour hsc_lang + output_fn <- get_output_fn next_phase (Just location4) + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + + hsc_env <- newHscEnv dflags' + + -- Tell the finder cache about this module + addHomeModuleToFinder hsc_env mod_name location4 + + -- run the compiler! + mbResult <- hscCompileOneShot hsc_env + mod_summary source_unchanged + Nothing -- No iface + Nothing -- No "module i of n" progress info + + case mbResult of + Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + Just HscNoRecomp + -> do SysTools.touch dflags' "Touching object file" o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't be in HscNoRecomp) + -- but we touch it anyway, to keep 'make' happy (we think). + return (StopLn, dflags', Just location4, o_file) + Just (HscRecomp hasStub) + -> do when hasStub $ + do stub_o <- compileStub dflags' mod_name location4 + consIORef v_Ld_inputs stub_o + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + when (isHsBoot src_flavour) $ + SysTools.touch dflags' "Touching object file" o_file + return (next_phase, dflags', Just location4, output_fn) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc + = do + output_fn <- get_output_fn Cmm maybe_loc + doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn + return (Cmm, dflags, maybe_loc, output_fn) + +runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc + = do + let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang + output_fn <- get_output_fn next_phase maybe_loc + + let dflags' = dflags { hscTarget = hsc_lang, + hscOutName = output_fn, + extCoreName = basename ++ ".hcr" } + + ok <- hscCmmFile dflags' input_fn + + when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) + + return (next_phase, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +-- we don't support preprocessing .c files (with -E) now. Doing so introduces +-- way too many hacks, and I can't say I've ever used it anyway. + +runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` HCc + = do let cc_opts = getOpts dflags opt_c + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- files; this is the Value Add(TM) that using ghc instead of + -- gcc gives you :) + pkg_include_dirs <- getPackageIncludePath dflags pkgs + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags + let pic_c_flags = picCCOpts dflags + + let verb = getVerbFlag dflags + + pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs + + let split_objs = dopt Opt_SplitObjs dflags + split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] + | otherwise = [ ] + + let excessPrecision = dopt Opt_ExcessPrecision dflags + + let cc_opt | optLevel dflags >= 2 = "-O2" + | otherwise = "-O" + + -- Decide next phase + + let mangle = dopt Opt_DoAsmMangling dflags + next_phase + | hcc && mangle = Mangle + | otherwise = As + output_fn <- get_output_fn next_phase maybe_loc + + let + more_hcc_opts = +#if i386_TARGET_ARCH + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if excessPrecision then [] else [ "-ffloat-store" ]) ++ +#endif + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + + + SysTools.runCc dflags ( + -- force the C compiler to interpret this file as C when + -- compiling .hc files, by adding the -x c option. + -- Also useful for plain .c files, just in case GHC saw a + -- -x c option. + [ SysTools.Option "-x", SysTools.Option "c"] ++ + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ pic_c_flags + ++ (if hcc && mangle + then md_regd_c_flags + else []) + ++ (if hcc + then more_hcc_opts + else []) + ++ [ verb, "-S", "-Wimplicit", cc_opt ] + ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] + ++ cc_opts + ++ split_opt + ++ include_paths + ++ pkg_extra_cc_opts + )) + + return (next_phase, dflags, maybe_loc, output_fn) + + -- ToDo: postprocess the output from gcc + +----------------------------------------------------------------------------- +-- Mangle phase + +runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc + = do let mangler_opts = getOpts dflags opt_m + +#if i386_TARGET_ARCH + machdep_opts <- return [ show (stolen_x86_regs dflags) ] +#else + machdep_opts <- return [] +#endif + + let split = dopt Opt_SplitObjs dflags + next_phase + | split = SplitMangle + | otherwise = As + output_fn <- get_output_fn next_phase maybe_loc + + SysTools.runMangle dflags (map SysTools.Option mangler_opts + ++ [ SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option machdep_opts) + + return (next_phase, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- Splitting phase + +runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc + = do -- tmp_pfx is the prefix used for the split .s files + -- We also use it as the file to contain the no. of split .s files (sigh) + split_s_prefix <- SysTools.newTempName dflags "split" + let n_files_fn = split_s_prefix + + SysTools.runSplit dflags + [ SysTools.FileOption "" input_fn + , SysTools.FileOption "" split_s_prefix + , SysTools.FileOption "" n_files_fn + ] + + -- Save the number of split files for future references + s <- readFile n_files_fn + let n_files = read s :: Int + writeIORef v_Split_info (split_s_prefix, n_files) + + -- Remember to delete all these files + addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] + + return (SplitAs, dflags, maybe_loc, "**splitmangle**") + -- we don't use the filename + +----------------------------------------------------------------------------- +-- As phase + +runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc + = do let as_opts = getOpts dflags opt_a + let cmdline_include_paths = includePaths dflags + + output_fn <- get_output_fn StopLn maybe_loc + + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryHierarchy (directoryOf output_fn) + + SysTools.runAs dflags + (map SysTools.Option as_opts + ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] + ++ [ SysTools.Option "-c" + , SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + + return (StopLn, dflags, maybe_loc, output_fn) + + +runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc + = do + output_fn <- get_output_fn StopLn maybe_loc + + let (base_o, _) = splitFilename output_fn + split_odir = base_o ++ "_split" + osuf = objectSuf dflags + + createDirectoryHierarchy split_odir + + -- remove M_split/ *.o, because we're going to archive M_split/ *.o + -- later and we don't want to pick up any old objects. + fs <- getDirectoryContents split_odir + mapM_ removeFile $ map (split_odir `joinFileName`) + $ filter (osuf `isSuffixOf`) fs + + let as_opts = getOpts dflags opt_a + + (split_s_prefix, n) <- readIORef v_Split_info + + let split_s n = split_s_prefix ++ "__" ++ show n `joinFileExt` "s" + split_obj n = split_odir `joinFileName` + filenameOf base_o ++ "__" ++ show n + `joinFileExt` osuf + + let assemble_file n + = SysTools.runAs dflags + (map SysTools.Option as_opts ++ + [ SysTools.Option "-c" + , SysTools.Option "-o" + , SysTools.FileOption "" (split_obj n) + , SysTools.FileOption "" (split_s n) + ]) + + mapM_ assemble_file [1..n] + + -- and join the split objects into a single object file: + let ld_r args = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-nodefaultlibs", + SysTools.Option "-Wl,-r", + SysTools.Option ld_x_flag, + SysTools.Option "-o", + SysTools.FileOption "" output_fn ] ++ args) + ld_x_flag | null cLD_X = "" + | otherwise = "-Wl,-x" + + if cLdIsGNULd == "YES" + then do + let script = split_odir `joinFileName` "ld.script" + writeFile script $ + "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" + ld_r [SysTools.FileOption "" script] + else do + ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) + + return (StopLn, dflags, maybe_loc, output_fn) + + +----------------------------------------------------------------------------- +-- MoveBinary sort-of-phase +-- After having produced a binary, move it somewhere else and generate a +-- wrapper script calling the binary. Currently, we need this only in +-- a parallel way (i.e. in GUM), because PVM expects the binary in a +-- central directory. +-- This is called from staticLink below, after linking. I haven't made it +-- a separate phase to minimise interfering with other modules, and +-- we don't need the generality of a phase (MoveBinary is always +-- done after linking and makes only sense in a parallel setup) -- HWL + +runPhase_MoveBinary input_fn + = do + sysMan <- getSysMan + pvm_root <- getEnv "PVM_ROOT" + pvm_arch <- getEnv "PVM_ARCH" + let + pvm_executable_base = "=" ++ input_fn + pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base + -- nuke old binary; maybe use configur'ed names for cp and rm? + system ("rm -f " ++ pvm_executable) + -- move the newly created binary into PVM land + system ("cp -p " ++ input_fn ++ " " ++ pvm_executable) + -- generate a wrapper script for running a parallel prg under PVM + writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan) + return True + +-- generates a Perl skript starting a parallel prg under PVM +mk_pvm_wrapper_script :: String -> String -> String -> String +mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ + [ + "eval 'exec perl -S $0 ${1+\"$@\"}'", + " if $running_under_some_shell;", + "# =!=!=!=!=!=!=!=!=!=!=!", + "# This script is automatically generated: DO NOT EDIT!!!", + "# Generated by Glasgow Haskell Compiler", + "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!", + "#", + "$pvm_executable = '" ++ pvm_executable ++ "';", + "$pvm_executable_base = '" ++ pvm_executable_base ++ "';", + "$SysMan = '" ++ sysMan ++ "';", + "", + {- ToDo: add the magical shortcuts again iff we actually use them -- HWL + "# first, some magical shortcuts to run "commands" on the binary", + "# (which is hidden)", + "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {", + " local($cmd) = $1;", + " system("$cmd $pvm_executable");", + " exit(0); # all done", + "}", -} + "", + "# Now, run the real binary; process the args first", + "$ENV{'PE'} = $pvm_executable_base;", -- ++ pvm_executable_base, + "$debug = '';", + "$nprocessors = 0; # the default: as many PEs as machines in PVM config", + "@nonPVM_args = ();", + "$in_RTS_args = 0;", + "", + "args: while ($a = shift(@ARGV)) {", + " if ( $a eq '+RTS' ) {", + " $in_RTS_args = 1;", + " } elsif ( $a eq '-RTS' ) {", + " $in_RTS_args = 0;", + " }", + " if ( $a eq '-d' && $in_RTS_args ) {", + " $debug = '-';", + " } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {", + " $nprocessors = $1;", + " } else {", + " push(@nonPVM_args, $a);", + " }", + "}", + "", + "local($return_val) = 0;", + "# Start the parallel execution by calling SysMan", + "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");", + "$return_val = $?;", + "# ToDo: fix race condition moving files and flushing them!!", + "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";", + "exit($return_val);" + ] + +----------------------------------------------------------------------------- +-- Complain about non-dynamic flags in OPTIONS pragmas + +checkProcessArgsResult flags filename + = do when (notNull flags) (throwDyn (ProgramError ( + showSDoc (hang (text filename <> char ':') + 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+> + hsep (map text flags))) + ))) + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [PackageId] +getHCFilePackages filename = + EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToPackageId (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO () +staticLink dflags o_files dep_packages = do + let verb = getVerbFlag dflags + output_fn = exeFileName dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + pkg_link_opts <- getPackageLinkOpts dflags dep_packages + +#ifdef darwin_TARGET_OS + pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages + let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths + + let framework_paths = frameworkPaths dflags + framework_path_opts = map ("-F"++) framework_paths + + pkg_frameworks <- getPackageFrameworks dflags dep_packages + let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ] + + let frameworks = cmdlineFrameworks dflags + framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] + -- reverse because they're added in reverse order from the cmd line +#endif + + -- probably _stub.o files + extra_ld_inputs <- readIORef v_Ld_inputs + + -- opts from -optl-<blah> (including -l<blah> options) + let extra_ld_opts = getOpts dflags opt_l + + let ways = wayNames dflags + + -- Here are some libs that need to be linked at the *end* of + -- the command line, because they contain symbols that are referred to + -- by the RTS. We can't therefore use the ordinary way opts for these. + let + debug_opts | WayDebug `elem` ways = [ +#if defined(HAVE_LIBBFD) + "-lbfd", "-liberty" +#endif + ] + | otherwise = [] + + let + thread_opts | WayThreaded `elem` ways = [ +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) + "-lpthread" +#endif +#if defined(osf3_TARGET_OS) + , "-lexc" +#endif + ] + | otherwise = [] + + let (md_c_flags, _) = machdepCCOpts dflags + SysTools.runLink dflags ( + [ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts +#ifdef darwin_TARGET_OS + ++ framework_path_opts + ++ framework_opts +#endif + ++ pkg_lib_path_opts + ++ pkg_link_opts +#ifdef darwin_TARGET_OS + ++ pkg_framework_path_opts + ++ pkg_framework_opts +#endif + ++ debug_opts + ++ thread_opts + )) + + -- parallel only: move binary to another dir -- HWL + when (WayPar `elem` ways) + (do success <- runPhase_MoveBinary output_fn + if success then return () + else throwDyn (InstallationError ("cannot move binary to PVM dir"))) + + +exeFileName :: DynFlags -> FilePath +exeFileName dflags + | Just s <- outputFile dflags = +#if defined(mingw32_HOST_OS) + if null (suffixOf s) + then s `joinFileExt` "exe" + else s +#else + s +#endif + | otherwise = +#if defined(mingw32_HOST_OS) + "main.exe" +#else + "a.out" +#endif + +----------------------------------------------------------------------------- +-- Making a DLL (only for Win32) + +doMkDLL :: DynFlags -> [String] -> [PackageId] -> IO () +doMkDLL dflags o_files dep_packages = do + let verb = getVerbFlag dflags + let static = opt_Static + let no_hs_main = dopt Opt_NoHsMain dflags + let o_file = outputFile dflags + let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } + + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths + + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + pkg_link_opts <- getPackageLinkOpts dflags dep_packages + + -- probably _stub.o files + extra_ld_inputs <- readIORef v_Ld_inputs + + -- opts from -optdll-<blah> + let extra_ld_opts = getOpts dflags opt_dll + + let pstate = pkgState dflags + rts_id | ExtPackage id <- rtsPackageId pstate = id + | otherwise = panic "staticLink: rts package missing" + base_id | ExtPackage id <- basePackageId pstate = id + | otherwise = panic "staticLink: base package missing" + rts_pkg = getPackageDetails pstate rts_id + base_pkg = getPackageDetails pstate base_id + + let extra_os = if static || no_hs_main + then [] + else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", + head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] + + let (md_c_flags, _) = machdepCCOpts dflags + SysTools.runMkDLL dflags + ([ SysTools.Option verb + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + md_c_flags + ++ o_files + ++ extra_os + ++ [ "--target=i386-mingw32" ] + ++ extra_ld_inputs + ++ lib_path_opts + ++ extra_ld_opts + ++ pkg_lib_path_opts + ++ pkg_link_opts + ++ (if "--def" `elem` (concatMap words extra_ld_opts) + then [ "" ] + else [ "--export-all" ]) + )) + +-- ----------------------------------------------------------------------------- +-- Running CPP + +doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw include_cc_opts input_fn output_fn = do + let hscpp_opts = getOpts dflags opt_P + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths = foldr (\ x xs -> "-I" : x : xs) [] + (cmdline_include_paths ++ pkg_include_dirs) + + let verb = getVerbFlag dflags + + let cc_opts + | not include_cc_opts = [] + | otherwise = (optc ++ md_c_flags) + where + optc = getOpts dflags opt_c + (md_c_flags, _) = machdepCCOpts dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) + + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS=1", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1", + "-D" ++ TARGET_OS ++ "_HOST_OS=1", + "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + cpp_prog ([SysTools.Option verb] + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option cc_opts + ++ map SysTools.Option target_defs + ++ [ SysTools.Option "-x" + , SysTools.Option "c" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +cHaskell1Version = "5" -- i.e., Haskell 98 + +-- Default CPP defines in Haskell source +hsSourceCppOpts = + [ "-D__HASKELL1__="++cHaskell1Version + , "-D__GLASGOW_HASKELL__="++cProjectVersionInt + , "-D__HASKELL98__" + , "-D__CONCURRENT_HASKELL__" + ] + + +-- ----------------------------------------------------------------------------- +-- Misc. + +hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase +hscNextPhase dflags HsBootFile hsc_lang = StopLn +hscNextPhase dflags other hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle + | otherwise -> As + HscNothing -> StopLn + HscInterpreted -> StopLn + _other -> StopLn + + +hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget +hscMaybeAdjustTarget dflags stop HsBootFile current_hsc_lang + = HscNothing -- No output (other than Foo.hi-boot) for hs-boot files +hscMaybeAdjustTarget dflags stop other current_hsc_lang + = hsc_lang + where + keep_hc = dopt Opt_KeepHcFiles dflags + hsc_lang + -- don't change the lang if we're interpreting + | current_hsc_lang == HscInterpreted = current_hsc_lang + + -- force -fvia-C if we are being asked for a .hc file + | HCc <- stop = HscC + | keep_hc = HscC + -- otherwise, stick to the plan + | otherwise = current_hsc_lang + +GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) + -- The split prefix and number of files diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs new file mode 100644 index 0000000000..78acb98375 --- /dev/null +++ b/compiler/main/DynFlags.hs @@ -0,0 +1,1344 @@ +----------------------------------------------------------------------------- +-- +-- Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from +-- compilation to compilation using OPTIONS_GHC pragmas, and in a +-- multi-session GHC each session can be using different dynamic +-- flags. Dynamic flags can also be set at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module DynFlags ( + -- Dynamic flags + DynFlag(..), + DynFlags(..), + HscTarget(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), + Option(..), + + -- Configuration of the core-to-core and stg-to-stg phases + CoreToDo(..), + StgToDo(..), + SimplifierSwitch(..), + SimplifierMode(..), FloatOutSwitches(..), + getCoreToDo, getStgToDo, + + -- Manipulating DynFlags + defaultDynFlags, -- DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + + dopt, -- DynFlag -> DynFlags -> Bool + dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags + getOpts, -- (DynFlags -> [a]) -> IO [a] + getVerbFlag, + updOptLevel, + setTmpDir, + + -- parsing DynFlags + parseDynamicFlags, + allFlags, + + -- misc stuff + machdepCCOpts, picCCOpts, + ) where + +#include "HsVersions.h" + +import Module ( Module, mkModule ) +import PrelNames ( mAIN ) +import StaticFlags ( opt_Static, opt_PIC, + WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag ) +import {-# SOURCE #-} Packages (PackageState) +import DriverPhases ( Phase(..), phaseInputExt ) +import Config +import CmdLineParser +import Panic ( panic, GhcException(..) ) +import Util ( notNull, splitLongestPrefix, split, normalisePath ) +import SrcLoc ( SrcSpan ) + +import DATA_IOREF ( readIORef ) +import EXCEPTION ( throwDyn ) +import Monad ( when ) +#ifdef mingw32_TARGET_OS +import Data.List ( isPrefixOf ) +#endif +import Maybe ( fromJust ) +import Char ( isDigit, isUpper ) +import Outputable +import System.IO ( hPutStrLn, stderr ) +import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DynFlag + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_asm + | Opt_D_dump_cpranal + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_flatC + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_rn + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg + | Opt_D_dump_stranal + | Opt_D_dump_tc + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace + | Opt_D_dump_splices + | Opt_D_dump_BCOs + | Opt_D_dump_vect + | Opt_D_source_stats + | Opt_D_verbose_core2core + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_minimal_imports + | Opt_D_faststring_stats + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnIncompletePatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnSimplePatterns + | Opt_WarnTypeDefaults + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnDeprecations + | Opt_WarnDodgyImports + | Opt_WarnOrphans + + -- language opts + | Opt_AllowOverlappingInstances + | Opt_AllowUndecidableInstances + | Opt_AllowIncoherentInstances + | Opt_MonomorphismRestriction + | Opt_GlasgowExts + | Opt_FFI + | Opt_PArr -- syntactic support for parallel arrays + | Opt_Arrows -- Arrow-notation syntax + | Opt_TH + | Opt_ImplicitParams + | Opt_Generics + | Opt_ImplicitPrelude + | Opt_ScopedTypeVariables + | Opt_BangPatterns + + -- optimisation opts + | Opt_Strictness + | Opt_FullLaziness + | Opt_CSE + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_IgnoreBreakpoints + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_UnboxStrictFields + + -- misc opts + | Opt_Cpp + | Opt_Pp + | Opt_RecompChecking + | Opt_DryRun + | Opt_DoAsmMangling + | Opt_ExcessPrecision + | Opt_ReadUserPackageConf + | Opt_NoHsMain + | Opt_SplitObjs + | Opt_StgStats + | Opt_HideAllPackages + + -- keeping stuff + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepRawSFiles + | Opt_KeepTmpFiles + + deriving (Eq) + +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + coreToDo :: Maybe [CoreToDo], -- reserved for -Ofile + stgToDo :: Maybe [StgToDo], -- similarly + hscTarget :: HscTarget, + hscOutName :: String, -- name of the output file + extCoreName :: String, -- name of the .core output file + verbosity :: Int, -- verbosity level + optLevel :: Int, -- optimisation level + maxSimplIterations :: Int, -- max simplifier iterations + ruleCheck :: Maybe String, + stolen_x86_regs :: Int, + cmdlineHcIncludes :: [String], -- -#includes + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + + -- ways + wayNames :: [WayName], -- way flags from the cmd line + buildTag :: String, -- the global "way" (eg. "p" for prof) + rtsBuildTag :: String, -- the RTS "way" + + -- paths etc. + objectDir :: Maybe String, + hiDir :: Maybe String, + stubDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + + outputFile :: Maybe String, + outputHi :: Maybe String, + + includePaths :: [String], + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + tmpDir :: String, -- no trailing '/' + + -- options for particular phases + opt_L :: [String], + opt_P :: [String], + opt_F :: [String], + opt_c :: [String], + opt_m :: [String], + opt_a :: [String], + opt_l :: [String], + opt_dll :: [String], + opt_dep :: [String], + + -- commands for particular phases + pgm_L :: String, + pgm_P :: (String,[Option]), + pgm_F :: String, + pgm_c :: (String,[Option]), + pgm_m :: (String,[Option]), + pgm_s :: (String,[Option]), + pgm_a :: (String,[Option]), + pgm_l :: (String,[Option]), + pgm_dll :: (String,[Option]), + + -- ** Package flags + extraPkgConfs :: [FilePath], + -- The -package-conf flags given on the command line, in the order + -- they appeared. + + packageFlags :: [PackageFlag], + -- The -package and -hide-package flags from the command-line + + -- ** Package state + pkgState :: PackageState, + + -- hsc dynamic flags + flags :: [DynFlag], + + -- message output + log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO () + } + +data HscTarget + = HscC + | HscAsm + | HscJava + | HscILX + | HscInterpreted + | HscNothing + deriving (Eq, Show) + +data GhcMode + = BatchCompile -- | @ghc --make Main@ + | Interactive -- | @ghc --interactive@ + | OneShot -- | @ghc -c Foo.hs@ + | JustTypecheck -- | Development environemnts, refactorer, etc. + | MkDepend + deriving Eq + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +data GhcLink -- What to do in the link step, if there is one + = -- Only relevant for modes + -- DoMake and StopBefore StopLn + NoLink -- Don't link at all + | StaticLink -- Ordinary linker [the default] + | MkDLL -- Make a DLL + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink other = False + +data PackageFlag + = ExposePackage String + | HidePackage String + | IgnorePackage String + +defaultHscTarget + | cGhcWithNativeCodeGen == "YES" = HscAsm + | otherwise = HscC + +initDynFlags dflags = do + -- someday these will be dynamic flags + ways <- readIORef v_Ways + build_tag <- readIORef v_Build_tag + rts_build_tag <- readIORef v_RTS_Build_tag + return dflags{ + wayNames = ways, + buildTag = build_tag, + rtsBuildTag = rts_build_tag + } + +defaultDynFlags = + DynFlags { + ghcMode = OneShot, + ghcLink = StaticLink, + coreToDo = Nothing, + stgToDo = Nothing, + hscTarget = defaultHscTarget, + hscOutName = "", + extCoreName = "", + verbosity = 0, + optLevel = 0, + maxSimplIterations = 4, + ruleCheck = Nothing, + stolen_x86_regs = 4, + cmdlineHcIncludes = [], + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + + wayNames = panic "ways", + buildTag = panic "buildTag", + rtsBuildTag = panic "rtsBuildTag", + + objectDir = Nothing, + hiDir = Nothing, + stubDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + + outputFile = Nothing, + outputHi = Nothing, + includePaths = [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + tmpDir = cDEFAULT_TMPDIR, + + opt_L = [], + opt_P = [], + opt_F = [], + opt_c = [], + opt_a = [], + opt_m = [], + opt_l = [], + opt_dll = [], + opt_dep = [], + + pgm_L = panic "pgm_L", + pgm_P = panic "pgm_P", + pgm_F = panic "pgm_F", + pgm_c = panic "pgm_c", + pgm_m = panic "pgm_m", + pgm_s = panic "pgm_s", + pgm_a = panic "pgm_a", + pgm_l = panic "pgm_l", + pgm_dll = panic "pgm_mkdll", + + extraPkgConfs = [], + packageFlags = [], + pkgState = panic "pkgState", + + flags = [ + Opt_RecompChecking, + Opt_ReadUserPackageConf, + + Opt_ImplicitPrelude, + Opt_MonomorphismRestriction, + Opt_Strictness, + -- strictness is on by default, but this only + -- applies to -O. + Opt_CSE, -- similarly for CSE. + Opt_FullLaziness, -- ...and for full laziness + + Opt_DoLambdaEtaExpansion, + -- This one is important for a tiresome reason: + -- we want to make sure that the bindings for data + -- constructors are eta-expanded. This is probably + -- a good thing anyway, but it seems fragile. + + Opt_DoAsmMangling, + + -- and the default no-optimisation options: + Opt_IgnoreInterfacePragmas, + Opt_OmitInterfacePragmas + + ] ++ standardWarnings, + + log_action = \severity srcSpan style msg -> + case severity of + SevInfo -> hPutStrLn stderr (show (msg style)) + SevFatal -> hPutStrLn stderr (show (msg style)) + _ -> hPutStrLn stderr ('\n':show ((mkLocMessage srcSpan msg) style)) + } + +{- + Verbosity levels: + + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +dopt :: DynFlag -> DynFlags -> Bool +dopt f dflags = f `elem` (flags dflags) + +dopt_set :: DynFlags -> DynFlag -> DynFlags +dopt_set dfs f = dfs{ flags = f : flags dfs } + +dopt_unset :: DynFlags -> DynFlag -> DynFlags +dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } + +getOpts :: DynFlags -> (DynFlags -> [a]) -> [a] +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +getVerbFlag :: DynFlags -> String +getVerbFlag dflags + | verbosity dflags >= 3 = "-v" + | otherwise = "" + +setObjectDir f d = d{ objectDir = f} +setHiDir f d = d{ hiDir = f} +setStubDir f d = d{ stubDir = f} + +setObjectSuf f d = d{ objectSuf = f} +setHiSuf f d = d{ hiSuf = f} +setHcSuf f d = d{ hcSuf = f} + +setOutputFile f d = d{ outputFile = f} +setOutputHi f d = d{ outputHi = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)} + +setPgmL f d = d{ pgm_L = f} +setPgmF f d = d{ pgm_F = f} +setPgmc f d = d{ pgm_c = (f,[])} +setPgmm f d = d{ pgm_m = (f,[])} +setPgms f d = d{ pgm_s = (f,[])} +setPgma f d = d{ pgm_a = (f,[])} +setPgml f d = d{ pgm_l = (f,[])} +setPgmdll f d = d{ pgm_dll = (f,[])} + +addOptL f d = d{ opt_L = f : opt_L d} +addOptP f d = d{ opt_P = f : opt_P d} +addOptF f d = d{ opt_F = f : opt_F d} +addOptc f d = d{ opt_c = f : opt_c d} +addOptm f d = d{ opt_m = f : opt_m d} +addOpta f d = d{ opt_a = f : opt_a d} +addOptl f d = d{ opt_l = f : opt_l d} +addOptdll f d = d{ opt_dll = f : opt_dll d} +addOptdep f d = d{ opt_dep = f : opt_dep d} + +addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. [The reason being, of course, that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform.] + +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- Set dynflags appropriate to the optimisation level +updOptLevel n dfs + = if (n >= 1) + then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O + else dfs2{ optLevel = n } + where + dfs1 = foldr (flip dopt_unset) dfs remove_dopts + dfs2 = foldr (flip dopt_set) dfs1 extra_dopts + + extra_dopts + | n == 0 = opt_0_dopts + | otherwise = opt_1_dopts + + remove_dopts + | n == 0 = opt_1_dopts + | otherwise = opt_0_dopts + +opt_0_dopts = [ + Opt_IgnoreInterfacePragmas, + Opt_OmitInterfacePragmas + ] + +opt_1_dopts = [ + Opt_IgnoreAsserts, + Opt_DoEtaReduction, + Opt_CaseMerge + ] + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +standardWarnings + = [ Opt_WarnDeprecations, + Opt_WarnOverlappingPatterns, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnDuplicateExports + ] + +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyImports + ] + +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSigs, + Opt_WarnHiShadows, + Opt_WarnOrphans + ] + +-- ----------------------------------------------------------------------------- +-- CoreToDo: abstraction of core-to-core passes to run. + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + SimplifierMode + [SimplifierSwitch] + -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoStrictness + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreDoOldStrictness + | CoreDoGlomBinds + | CoreCSE + | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules + -- matching this string + + | CoreDoNothing -- useful when building up lists of these things + +data SimplifierMode -- See comments in SimplMonad + = SimplGently + | SimplPhase Int + +data SimplifierSwitch + = MaxSimplifierIterations Int + | NoCaseOfCase + +data FloatOutSwitches + = FloatOutSw Bool -- True <=> float lambdas to top level + Bool -- True <=> float constants to top level, + -- even if they do not escape a lambda + + +-- The core-to-core pass ordering is derived from the DynFlags: + +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + | Just todo <- coreToDo dflags = todo -- set explicitly by user + | otherwise = core_todo + where + opt_level = optLevel dflags + max_iter = maxSimplIterations dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + cse = dopt Opt_CSE dflags + rule_check = ruleCheck dflags + + core_todo = + if opt_level == 0 then + [ + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ] + ] + else {- opt_level >= 1 -} [ + + -- initial simplify: mk specialiser happy: minimum effort please + CoreDoSimplify SimplGently [ + -- Simplify "gently" + -- Don't inline anything till full laziness has bitten + -- In particular, inlining wrappers inhibits floating + -- e.g. ...(case f x of ...)... + -- ==> ...(case (case x of I# x# -> fw x#) of ...)... + -- ==> ...(case x of I# x# -> case fw x# of ...)... + -- and now the redex (f x) isn't floatable any more + -- Similarly, don't apply any rules until after full + -- laziness. Notably, list fusion can prevent floating. + + NoCaseOfCase, + -- Don't do case-of-case transformations. + -- This makes full laziness work better + MaxSimplifierIterations max_iter + ], + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + CoreDoSpecialising, + + if full_laziness then CoreDoFloatOutwards (FloatOutSw False False) + else CoreDoNothing, + + CoreDoFloatInwards, + + CoreDoSimplify (SimplPhase 2) [ + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + MaxSimplifierIterations max_iter + ], + case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing }, + + CoreDoSimplify (SimplPhase 1) [ + -- Need inline-phase2 here so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + MaxSimplifierIterations max_iter + ], + case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing }, + + CoreDoSimplify (SimplPhase 0) [ + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + MaxSimplifierIterations 3 + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + + ], + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, + +#ifdef OLD_STRICTNESS + CoreDoOldStrictness +#endif + if strictness then CoreDoStrictness else CoreDoNothing, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ], + + if full_laziness then + CoreDoFloatOutwards (FloatOutSw False -- Not lambdas + True) -- Float constants + else CoreDoNothing, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + if cse then CoreCSE else CoreDoNothing, + + CoreDoFloatInwards, + +-- Case-liberation for -O2. This should be after +-- strictness analysis and the simplification which follows it. + + case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }, + + if opt_level >= 2 then + CoreLiberateCase + else + CoreDoNothing, + if opt_level >= 2 then + CoreDoSpecConstr + else + CoreDoNothing, + + -- Final clean-up simplification: + CoreDoSimplify (SimplPhase 0) [ + MaxSimplifierIterations max_iter + ] + ] + +-- ----------------------------------------------------------------------------- +-- StgToDo: abstraction of stg-to-stg passes to run. + +data StgToDo + = StgDoMassageForProfiling -- should be (next to) last + -- There's also setStgVarInfo, but its absolute "lastness" + -- is so critical that it is hardwired in (no flag). + | D_stg_stats + +getStgToDo :: DynFlags -> [StgToDo] +getStgToDo dflags + | Just todo <- stgToDo dflags = todo -- set explicitly by user + | otherwise = todo2 + where + stg_stats = dopt Opt_StgStats dflags + + todo1 = if stg_stats then [D_stg_stats] else [] + + todo2 | WayProf `elem` wayNames dflags + = StgDoMassageForProfiling : todo1 + | otherwise + = todo1 + +-- ----------------------------------------------------------------------------- +-- DynFlags parser + +allFlags :: [String] +allFlags = map ('-':) $ + [ name | (name, optkind) <- dynamic_flags, ok optkind ] ++ + map ("fno-"++) flags ++ + map ("f"++) flags + where ok (PrefixPred _ _) = False + ok _ = True + flags = map fst fFlags + +dynamic_flags :: [(String, OptKind DynP)] +dynamic_flags = [ + ( "n" , NoArg (setDynFlag Opt_DryRun) ) + , ( "cpp" , NoArg (setDynFlag Opt_Cpp)) + , ( "F" , NoArg (setDynFlag Opt_Pp)) + , ( "#include" , HasArg (addCmdlineHCInclude) ) + , ( "v" , OptPrefix (setVerbosity) ) + + ------- Specific phases -------------------------------------------- + , ( "pgmL" , HasArg (upd . setPgmL) ) + , ( "pgmP" , HasArg (upd . setPgmP) ) + , ( "pgmF" , HasArg (upd . setPgmF) ) + , ( "pgmc" , HasArg (upd . setPgmc) ) + , ( "pgmm" , HasArg (upd . setPgmm) ) + , ( "pgms" , HasArg (upd . setPgms) ) + , ( "pgma" , HasArg (upd . setPgma) ) + , ( "pgml" , HasArg (upd . setPgml) ) + , ( "pgmdll" , HasArg (upd . setPgmdll) ) + + , ( "optL" , HasArg (upd . addOptL) ) + , ( "optP" , HasArg (upd . addOptP) ) + , ( "optF" , HasArg (upd . addOptF) ) + , ( "optc" , HasArg (upd . addOptc) ) + , ( "optm" , HasArg (upd . addOptm) ) + , ( "opta" , HasArg (upd . addOpta) ) + , ( "optl" , HasArg (upd . addOptl) ) + , ( "optdll" , HasArg (upd . addOptdll) ) + , ( "optdep" , HasArg (upd . addOptdep) ) + + , ( "split-objs" , NoArg (if can_split + then setDynFlag Opt_SplitObjs + else return ()) ) + + -------- Linking ---------------------------------------------------- + , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) + , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep. + , ( "-mk-dll" , NoArg (upd $ \d -> d{ ghcLink=MkDLL } )) + + ------- Libraries --------------------------------------------------- + , ( "L" , Prefix addLibraryPath ) + , ( "l" , AnySuffix (\s -> do upd (addOptl s) + upd (addOptdll s))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , ( "framework-path" , HasArg addFrameworkPath ) + , ( "framework" , HasArg (upd . addCmdlineFramework) ) + + ------- Output Redirection ------------------------------------------ + , ( "odir" , HasArg (upd . setObjectDir . Just)) + , ( "o" , SepArg (upd . setOutputFile . Just)) + , ( "ohi" , HasArg (upd . setOutputHi . Just )) + , ( "osuf" , HasArg (upd . setObjectSuf)) + , ( "hcsuf" , HasArg (upd . setHcSuf)) + , ( "hisuf" , HasArg (upd . setHiSuf)) + , ( "hidir" , HasArg (upd . setHiDir . Just)) + , ( "tmpdir" , HasArg (upd . setTmpDir)) + , ( "stubdir" , HasArg (upd . setStubDir . Just)) + + ------- Keeping temporary files ------------------------------------- + , ( "keep-hc-file" , AnySuffix (\_ -> setDynFlag Opt_KeepHcFiles)) + , ( "keep-s-file" , AnySuffix (\_ -> setDynFlag Opt_KeepSFiles)) + , ( "keep-raw-s-file", AnySuffix (\_ -> setDynFlag Opt_KeepRawSFiles)) + , ( "keep-tmp-files" , AnySuffix (\_ -> setDynFlag Opt_KeepTmpFiles)) + + ------- Miscellaneous ---------------------------------------------- + , ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain)) + , ( "main-is" , SepArg setMainIs ) + + ------- recompilation checker -------------------------------------- + , ( "recomp" , NoArg (setDynFlag Opt_RecompChecking) ) + , ( "no-recomp" , NoArg (unSetDynFlag Opt_RecompChecking) ) + + ------- Packages ---------------------------------------------------- + , ( "package-conf" , HasArg extraPkgConf_ ) + , ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) ) + , ( "package-name" , HasArg ignorePackage ) -- for compatibility + , ( "package" , HasArg exposePackage ) + , ( "hide-package" , HasArg hidePackage ) + , ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) ) + , ( "ignore-package" , HasArg ignorePackage ) + , ( "syslib" , HasArg exposePackage ) -- for compatibility + + ------ HsCpp opts --------------------------------------------------- + , ( "D", AnySuffix (upd . addOptP) ) + , ( "U", AnySuffix (upd . addOptP) ) + + ------- Include/Import Paths ---------------------------------------- + , ( "I" , Prefix addIncludePath) + , ( "i" , OptPrefix addImportPath ) + + ------ Debugging ---------------------------------------------------- + , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats)) + + , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm) + , ( "ddump-asm", setDumpFlag Opt_D_dump_asm) + , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal) + , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv) + , ( "ddump-ds", setDumpFlag Opt_D_dump_ds) + , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC) + , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign) + , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings) + , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal) + , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed) + , ( "ddump-rn", setDumpFlag Opt_D_dump_rn) + , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl) + , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations) + , ( "ddump-spec", setDumpFlag Opt_D_dump_spec) + , ( "ddump-prep", setDumpFlag Opt_D_dump_prep) + , ( "ddump-stg", setDumpFlag Opt_D_dump_stg) + , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal) + , ( "ddump-tc", setDumpFlag Opt_D_dump_tc) + , ( "ddump-types", setDumpFlag Opt_D_dump_types) + , ( "ddump-rules", setDumpFlag Opt_D_dump_rules) + , ( "ddump-cse", setDumpFlag Opt_D_dump_cse) + , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper) + , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace)) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace)) + , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace) + , ( "ddump-splices", setDumpFlag Opt_D_dump_splices) + , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats)) + , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm) + , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats) + , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs) + , ( "dsource-stats", setDumpFlag Opt_D_source_stats) + , ( "dverbose-core2core", setDumpFlag Opt_D_verbose_core2core) + , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg) + , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs)) + , ( "ddump-hi", setDumpFlag Opt_D_dump_hi) + , ( "ddump-minimal-imports", NoArg (setDynFlag Opt_D_dump_minimal_imports)) + , ( "ddump-vect", setDumpFlag Opt_D_dump_vect) + , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting)) + , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting)) + , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting)) + , ( "dshow-passes", NoArg (do unSetDynFlag Opt_RecompChecking + setVerbosity "2") ) + , ( "dfaststring-stats", NoArg (setDynFlag Opt_D_faststring_stats)) + + ------ Machine dependant (-m<blah>) stuff --------------------------- + + , ( "monly-2-regs", NoArg (upd (\s -> s{stolen_x86_regs = 2}) )) + , ( "monly-3-regs", NoArg (upd (\s -> s{stolen_x86_regs = 3}) )) + , ( "monly-4-regs", NoArg (upd (\s -> s{stolen_x86_regs = 4}) )) + + ------ Warning opts ------------------------------------------------- + , ( "W" , NoArg (mapM_ setDynFlag minusWOpts) ) + , ( "Werror" , NoArg (setDynFlag Opt_WarnIsError) ) + , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) ) + , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) /* DEPREC */ + , ( "w" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) + + ------ Optimisation flags ------------------------------------------ + , ( "O" , NoArg (upd (setOptLevel 1))) + , ( "Onot" , NoArg (upd (setOptLevel 0))) + , ( "O" , PrefixPred (all isDigit) + (\f -> upd (setOptLevel (read f)))) + + , ( "fmax-simplifier-iterations", + PrefixPred (all isDigit) + (\n -> upd (\dfs -> + dfs{ maxSimplIterations = read n })) ) + + , ( "frule-check", + SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s }))) + + ------ Compiler flags ----------------------------------------------- + + , ( "fno-code", NoArg (setTarget HscNothing)) + , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) + , ( "fvia-c", NoArg (setTarget HscC) ) + , ( "fvia-C", NoArg (setTarget HscC) ) + , ( "filx", NoArg (setTarget HscILX) ) + + , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) + , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) + + -- the rest of the -f* and -fno-* flags + , ( "fno-", PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) ) + , ( "f", PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) ) + ] + +-- these -f<blah> flags can all be reversed with -fno-<blah> + +fFlags = [ + ( "warn-duplicate-exports", Opt_WarnDuplicateExports ), + ( "warn-hi-shadowing", Opt_WarnHiShadows ), + ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns ), + ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd ), + ( "warn-missing-fields", Opt_WarnMissingFields ), + ( "warn-missing-methods", Opt_WarnMissingMethods ), + ( "warn-missing-signatures", Opt_WarnMissingSigs ), + ( "warn-name-shadowing", Opt_WarnNameShadowing ), + ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns ), + ( "warn-simple-patterns", Opt_WarnSimplePatterns ), + ( "warn-type-defaults", Opt_WarnTypeDefaults ), + ( "warn-unused-binds", Opt_WarnUnusedBinds ), + ( "warn-unused-imports", Opt_WarnUnusedImports ), + ( "warn-unused-matches", Opt_WarnUnusedMatches ), + ( "warn-deprecations", Opt_WarnDeprecations ), + ( "warn-orphans", Opt_WarnOrphans ), + ( "fi", Opt_FFI ), -- support `-ffi'... + ( "ffi", Opt_FFI ), -- ...and also `-fffi' + ( "arrows", Opt_Arrows ), -- arrow syntax + ( "parr", Opt_PArr ), + ( "th", Opt_TH ), + ( "implicit-prelude", Opt_ImplicitPrelude ), + ( "scoped-type-variables", Opt_ScopedTypeVariables ), + ( "bang-patterns", Opt_BangPatterns ), + ( "monomorphism-restriction", Opt_MonomorphismRestriction ), + ( "implicit-params", Opt_ImplicitParams ), + ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), + ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), + ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), + ( "generics", Opt_Generics ), + ( "strictness", Opt_Strictness ), + ( "full-laziness", Opt_FullLaziness ), + ( "cse", Opt_CSE ), + ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas ), + ( "omit-interface-pragmas", Opt_OmitInterfacePragmas ), + ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion ), + ( "ignore-asserts", Opt_IgnoreAsserts ), + ( "ignore-breakpoints", Opt_IgnoreBreakpoints), + ( "do-eta-reduction", Opt_DoEtaReduction ), + ( "case-merge", Opt_CaseMerge ), + ( "unbox-strict-fields", Opt_UnboxStrictFields ), + ( "excess-precision", Opt_ExcessPrecision ), + ( "asm-mangling", Opt_DoAsmMangling ) + ] + +glasgowExtsFlags = [ + Opt_GlasgowExts, + Opt_FFI, + Opt_TH, + Opt_ImplicitParams, + Opt_ScopedTypeVariables, + Opt_BangPatterns ] + +isFFlag f = f `elem` (map fst fFlags) +getFFlag f = fromJust (lookup f fFlags) + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + +parseDynamicFlags :: DynFlags -> [String] -> IO (DynFlags,[String]) +parseDynamicFlags dflags args = do + let ((leftover,errs),dflags') + = runCmdLine (processArgs dynamic_flags args) dflags + when (not (null errs)) $ do + throwDyn (UsageError (unlines errs)) + return (dflags', leftover) + + +type DynP = CmdLineP DynFlags + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = do + dfs <- getCmdLineState + putCmdLineState $! (f dfs) + +setDynFlag, unSetDynFlag :: DynFlag -> DynP () +setDynFlag f = upd (\dfs -> dopt_set dfs f) +unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) + +setDumpFlag :: DynFlag -> OptKind DynP +setDumpFlag dump_flag + = NoArg (unSetDynFlag Opt_RecompChecking >> setDynFlag dump_flag) + -- Whenver we -ddump, switch off the recompilation checker, + -- else you don't see the dump! + +setVerbosity "" = upd (\dfs -> dfs{ verbosity = 3 }) +setVerbosity n + | all isDigit n = upd (\dfs -> dfs{ verbosity = read n }) + | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)") + +addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) + +extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) + +exposePackage p = + upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) + +-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags +-- (-fvia-C, -fasm, -filx respectively). +setTarget l = upd (\dfs -> case hscTarget dfs of + HscC -> dfs{ hscTarget = l } + HscAsm -> dfs{ hscTarget = l } + HscILX -> dfs{ hscTarget = l } + _ -> dfs) + +setOptLevel :: Int -> DynFlags -> DynFlags +setOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = dflags + -- not in IO any more, oh well: + -- putStr "warning: -O conflicts with --interactive; -O ignored.\n" + | otherwise + = updOptLevel n dflags + + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) -- The arg looked like "Foo.baz" + = upd $ \d -> d{ mainFunIs = Just main_fn, + mainModIs = mkModule main_mod } + + | isUpper (head main_mod) -- The arg looked like "Foo" + = upd $ \d -> d{ mainModIs = mkModule main_mod } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d{ mainFunIs = Just main_mod } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +----------------------------------------------------------------------------- +-- Paths & Libraries + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = includePaths s ++ splitPathList p}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +split_marker = ':' -- not configurable (ToDo) + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#ifndef mingw32_TARGET_OS + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- "<Drive>:/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, d:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir } + where +#if !defined(mingw32_HOST_OS) + canonicalise p = normalisePath p +#else + -- Canonicalisation of temp path under win32 is a bit more + -- involved: (a) strip trailing slash, + -- (b) normalise slashes + -- (c) just in case, if there is a prefix /cygdrive/x/, change to x: + -- + canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path)) + + -- if we're operating under cygwin, and TMP/TEMP is of + -- the form "/cygdrive/drive/path", translate this to + -- "drive:/path" (as GHC isn't a cygwin app and doesn't + -- understand /cygdrive paths.) + xltCygdrive path + | "/cygdrive/" `isPrefixOf` path = + case drop (length "/cygdrive/") path of + drive:xs@('/':_) -> drive:':':xs + _ -> path + | otherwise = path + + -- strip the trailing backslash (awful, but we only do this once). + removeTrailingSlash path = + case last path of + '/' -> init path + '\\' -> init path + _ -> path +#endif + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations + [String]) -- for registerised HC compilations +machdepCCOpts dflags +#if alpha_TARGET_ARCH + = ( ["-w", "-mieee" +#ifdef HAVE_THREADED_RTS_SUPPORT + , "-D_REENTRANT" +#endif + ], [] ) + -- For now, to suppress the gcc warning "call-clobbered + -- register used for global register variable", we simply + -- disable all warnings altogether using the -w flag. Oh well. + +#elif hppa_TARGET_ARCH + -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + -- (very nice, but too bad the HP /usr/include files don't agree.) + = ( ["-D_HPUX_SOURCE"], [] ) + +#elif m68k_TARGET_ARCH + -- -fno-defer-pop : for the .hc files, we want all the pushing/ + -- popping of args to routines to be explicit; if we let things + -- be deferred 'til after an STGJUMP, imminent death is certain! + -- + -- -fomit-frame-pointer : *don't* + -- It's better to have a6 completely tied up being a frame pointer + -- rather than let GCC pick random things to do with it. + -- (If we want to steal a6, then we would try to do things + -- as on iX86, where we *do* steal the frame pointer [%ebp].) + = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) + +#elif i386_TARGET_ARCH + -- -fno-defer-pop : basically the same game as for m68k + -- + -- -fomit-frame-pointer : *must* in .hc files; because we're stealing + -- the fp (%ebp) for our register maps. + = let n_regs = stolen_x86_regs dflags + sta = opt_Static + in + ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" +-- , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" + ], + [ "-fno-defer-pop", +#ifdef HAVE_GCC_MNO_OMIT_LFPTR + -- Some gccs are configured with + -- -momit-leaf-frame-pointer on by default, and it + -- apparently takes precedence over + -- -fomit-frame-pointer, so we disable it first here. + "-mno-omit-leaf-frame-pointer", +#endif + "-fomit-frame-pointer", + -- we want -fno-builtin, because when gcc inlines + -- built-in functions like memcpy() it tends to + -- run out of registers, requiring -monly-n-regs + "-fno-builtin", + "-DSTOLEN_X86_REGS="++show n_regs ] + ) + +#elif ia64_TARGET_ARCH + = ( [], ["-fomit-frame-pointer", "-G0"] ) + +#elif x86_64_TARGET_ARCH + = ( [], ["-fomit-frame-pointer", + "-fno-asynchronous-unwind-tables", + -- the unwind tables are unnecessary for HC code, + -- and get in the way of -split-objs. Another option + -- would be to throw them away in the mangler, but this + -- is easier. + "-fno-unit-at-a-time", + -- unit-at-a-time doesn't do us any good, and screws + -- up -split-objs by moving the split markers around. + -- It's only turned on with -O2, but put it here just + -- in case someone uses -optc-O2. + "-fno-builtin" + -- calling builtins like strlen() using the FFI can + -- cause gcc to run out of regs, so use the external + -- version. + ] ) + +#elif mips_TARGET_ARCH + = ( ["-static"], [] ) + +#elif sparc_TARGET_ARCH + = ( [], ["-w"] ) + -- For now, to suppress the gcc warning "call-clobbered + -- register used for global register variable", we simply + -- disable all warnings altogether using the -w flag. Oh well. + +#elif powerpc_apple_darwin_TARGET + -- -no-cpp-precomp: + -- Disable Apple's precompiling preprocessor. It's a great thing + -- for "normal" programs, but it doesn't support register variable + -- declarations. + = ( [], ["-no-cpp-precomp"] ) +#else + = ( [], [] ) +#endif + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags +#if darwin_TARGET_OS + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | opt_PIC + = ["-fno-common"] + | otherwise + = ["-mdynamic-no-pic"] +#elif mingw32_TARGET_OS + -- no -fPIC for Windows + = [] +#else + | opt_PIC + = ["-fPIC"] + | otherwise + = [] +#endif + +-- ----------------------------------------------------------------------------- +-- Splitting + +can_split :: Bool +can_split = +#if defined(i386_TARGET_ARCH) \ + || defined(x86_64_TARGET_ARCH) \ + || defined(alpha_TARGET_ARCH) \ + || defined(hppa_TARGET_ARCH) \ + || defined(m68k_TARGET_ARCH) \ + || defined(mips_TARGET_ARCH) \ + || defined(powerpc_TARGET_ARCH) \ + || defined(rs6000_TARGET_ARCH) \ + || defined(sparc_TARGET_ARCH) + True +#else + False +#endif + diff --git a/compiler/main/ErrUtils.hi-boot-6 b/compiler/main/ErrUtils.hi-boot-6 new file mode 100644 index 0000000000..fd98ca3950 --- /dev/null +++ b/compiler/main/ErrUtils.hi-boot-6 @@ -0,0 +1,11 @@ +module ErrUtils where + +data Severity + = SevInfo + | SevWarning + | SevError + | SevFatal + +type Message = Outputable.SDoc + +mkLocMessage :: SrcLoc.SrcSpan -> Message -> Message diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs new file mode 100644 index 0000000000..90e5dc87b6 --- /dev/null +++ b/compiler/main/ErrUtils.lhs @@ -0,0 +1,260 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1998 +% +\section[ErrsUtils]{Utilities for error reporting} + +\begin{code} +module ErrUtils ( + Message, mkLocMessage, printError, + Severity(..), + + ErrMsg, WarnMsg, + errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, + Messages, errorsFound, emptyMessages, + mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, + printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + + ghcExit, + doIfSet, doIfSet_dyn, + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, + + -- * Messages during compilation + putMsg, + errorMsg, + fatalErrorMsg, + compilationProgressMsg, + showPass, + debugTraceMsg, + ) where + +#include "HsVersions.h" + +import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) +import SrcLoc ( SrcSpan ) +import Util ( sortLe, global ) +import Outputable +import qualified Pretty +import SrcLoc ( srcSpanStart, noSrcSpan ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import StaticFlags ( opt_ErrorSpans ) +import System ( ExitCode(..), exitWith ) +import DATA_IOREF +import IO ( hPutStrLn, stderr ) +import DYNAMIC + + +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + +type Message = SDoc + +data Severity + = SevInfo + | SevWarning + | SevError + | SevFatal + +mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage locn msg + | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg + -- always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "<no location info>". + +printError :: SrcSpan -> Message -> IO () +printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) + + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +data ErrMsg = ErrMsg { + errMsgSpans :: [SrcSpan], + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: Message, + errMsgExtraInfo :: Message + } + -- The SrcSpan is used for sorting errors into line-number order + -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic + -- whether to qualify an External Name) at the error occurrence + +-- So we can throw these things as exceptions +errMsgTc :: TyCon +errMsgTc = mkTyCon "ErrMsg" +{-# NOINLINE errMsgTc #-} +instance Typeable ErrMsg where +#if __GLASGOW_HASKELL__ < 603 + typeOf _ = mkAppTy errMsgTc [] +#else + typeOf _ = mkTyConApp errMsgTc [] +#endif + +type WarnMsg = ErrMsg + +-- A short (one-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg +mkErrMsg locn print_unqual msg + = ErrMsg [locn] print_unqual msg empty + +-- Variant that doesn't care about qualified/unqualified names +mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg +mkPlainErrMsg locn msg + = ErrMsg [locn] alwaysQualify msg empty + +-- A long (multi-line) error message, with context to tell us whether +-- to qualify names in the message or not. +mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg +mkLongErrMsg locn print_unqual msg extra + = ErrMsg [locn] print_unqual msg extra + +mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg +mkWarnMsg = mkErrMsg + +type Messages = (Bag WarnMsg, Bag ErrMsg) + +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +errorsFound :: DynFlags -> Messages -> Bool +-- The dyn-flags are used to see if the user has specified +-- -Werorr, which says that warnings should be fatal +errorsFound dflags (warns, errs) + | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) + | otherwise = not (isEmptyBag errs) + +printErrorsAndWarnings :: DynFlags -> Messages -> IO () +printErrorsAndWarnings dflags (warns, errs) + | no_errs && no_warns = return () + | no_errs = printBagOfWarnings dflags warns + -- Don't print any warnings if there are errors + | otherwise = printBagOfErrors dflags errs + where + no_warns = isEmptyBag warns + no_errs = isEmptyBag errs + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle unqual + in log_action dflags SevError s style (d $$ e) + | ErrMsg { errMsgSpans = s:ss, + errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] + where + bag_ls = bagToList bag_of_errors + sorted_errs = sortLe occ'ed_before bag_ls + + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False + +printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO () +printBagOfWarnings dflags bag_of_warns + = sequence_ [ let style = mkErrStyle unqual + in log_action dflags SevWarning s style (d $$ e) + | ErrMsg { errMsgSpans = s:ss, + errMsgShortDoc = d, + errMsgExtraInfo = e, + errMsgContext = unqual } <- sorted_errs ] + where + bag_ls = bagToList bag_of_warns + sorted_errs = sortLe occ'ed_before bag_ls + + occ'ed_before err1 err2 = + case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of + LT -> True + EQ -> True + GT -> False +\end{code} + +\begin{code} +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) +\end{code} + +\begin{code} +doIfSet :: Bool -> IO () -> IO () +doIfSet flag action | flag = action + | otherwise = return () + +doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO() +doIfSet_dyn dflags flag action | dopt flag dflags = action + | otherwise = return () +\end{code} + +\begin{code} +dumpIfSet :: Bool -> String -> SDoc -> IO () +dumpIfSet flag hdr doc + | not flag = return () + | otherwise = printDump (mkDumpDoc hdr doc) + +dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () +dumpIfSet_core dflags flag hdr doc + | dopt flag dflags + || verbosity dflags >= 4 + || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc) + | otherwise = return () + +dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () +dumpIfSet_dyn dflags flag hdr doc + | dopt flag dflags || verbosity dflags >= 4 + = printDump (mkDumpDoc hdr doc) + | otherwise + = return () + +dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () +dumpIfSet_dyn_or dflags flags hdr doc + | or [dopt flag dflags | flag <- flags] + || verbosity dflags >= 4 + = printDump (mkDumpDoc hdr doc) + | otherwise = return () + +mkDumpDoc hdr doc + = vcat [text "", + line <+> text hdr <+> line, + doc, + text ""] + where + line = text (replicate 20 '=') + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +putMsg :: DynFlags -> Message -> IO () +putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg + +errorMsg :: DynFlags -> Message -> IO () +errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg + +fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg)) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + +debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg dflags val msg + = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) +\end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot new file mode 100644 index 0000000000..77d6cfdb4a --- /dev/null +++ b/compiler/main/ErrUtils.lhs-boot @@ -0,0 +1,16 @@ +\begin{code} +module ErrUtils where + +import Outputable (SDoc) +import SrcLoc (SrcSpan) + +data Severity + = SevInfo + | SevWarning + | SevError + | SevFatal + +type Message = SDoc + +mkLocMessage :: SrcSpan -> Message -> Message +\end{code} diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs new file mode 100644 index 0000000000..fbde40f6ea --- /dev/null +++ b/compiler/main/Finder.lhs @@ -0,0 +1,499 @@ +% +% (c) The University of Glasgow, 2000 +% +\section[Finder]{Module Finder} + +\begin{code} +module Finder ( + flushFinderCache, -- :: IO () + FindResult(..), + findModule, -- :: ModuleName -> Bool -> IO FindResult + findPackageModule, -- :: ModuleName -> Bool -> IO FindResult + mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation + mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation + addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () + uncacheModule, -- :: HscEnv -> Module -> IO () + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc + ) where + +#include "HsVersions.h" + +import Module +import UniqFM ( filterUFM, delFromUFM ) +import HscTypes +import Packages +import FastString +import Util +import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) +import Outputable +import Maybes ( expectJust ) + +import DATA_IOREF ( IORef, writeIORef, readIORef ) + +import Data.List +import System.Directory +import System.IO +import Control.Monad +import Data.Maybe ( isNothing ) +import Time ( ClockTime ) + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllPackages for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session. +flushFinderCache :: IORef FinderCache -> IO () +flushFinderCache finder_cache = do + fm <- readIORef finder_cache + writeIORef finder_cache $! filterUFM (\(loc,m) -> isNothing m) fm + +addToFinderCache :: IORef FinderCache -> Module -> FinderCacheEntry -> IO () +addToFinderCache finder_cache mod_name entry = do + fm <- readIORef finder_cache + writeIORef finder_cache $! extendModuleEnv fm mod_name entry + +removeFromFinderCache :: IORef FinderCache -> Module -> IO () +removeFromFinderCache finder_cache mod_name = do + fm <- readIORef finder_cache + writeIORef finder_cache $! delFromUFM fm mod_name + +lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FinderCacheEntry) +lookupFinderCache finder_cache mod_name = do + fm <- readIORef finder_cache + return $! lookupModuleEnv fm mod_name + +-- ----------------------------------------------------------------------------- +-- The two external entry points + +-- This is the main interface to the finder, which maps ModuleNames to +-- Modules and ModLocations. +-- +-- The Module contains one crucial bit of information about a module: +-- whether it lives in the current ("home") package or not (see Module +-- for more details). +-- +-- The ModLocation contains the names of all the files associated with +-- that module: its source file, .hi file, object file, etc. + +data FindResult + = Found ModLocation PackageIdH + -- the module was found + | FoundMultiple [PackageId] + -- *error*: both in multiple packages + | PackageHidden PackageId + -- for an explicit source import: the package containing the module is + -- not exposed. + | ModuleHidden PackageId + -- for an explicit source import: the package containing the module is + -- exposed, but the module itself is hidden. + | NotFound [FilePath] + -- the module was not found, the specified places were searched. + +findModule :: HscEnv -> Module -> Bool -> IO FindResult +findModule = findModule' True + +findPackageModule :: HscEnv -> Module -> Bool -> IO FindResult +findPackageModule = findModule' False + + +data LocalFindResult + = Ok FinderCacheEntry + | CantFindAmongst [FilePath] + | MultiplePackages [PackageId] + +findModule' :: Bool -> HscEnv -> Module -> Bool -> IO FindResult +findModule' home_allowed hsc_env name explicit + = do -- First try the cache + mb_entry <- lookupFinderCache cache name + case mb_entry of + Just old_entry -> return $! found old_entry + Nothing -> not_cached + + where + cache = hsc_FC hsc_env + dflags = hsc_dflags hsc_env + + -- We've found the module, so the remaining question is + -- whether it's visible or not + found :: FinderCacheEntry -> FindResult + found (loc, Nothing) + | home_allowed = Found loc HomePackage + | otherwise = NotFound [] + found (loc, Just (pkg, exposed_mod)) + | explicit && not exposed_mod = ModuleHidden pkg_name + | explicit && not (exposed pkg) = PackageHidden pkg_name + | otherwise = + Found loc (ExtPackage (mkPackageId (package pkg))) + where + pkg_name = packageConfigId pkg + + found_new entry = do + addToFinderCache cache name entry + return $! found entry + + not_cached + | not home_allowed = do + j <- findPackageModule' dflags name + case j of + Ok entry -> found_new entry + MultiplePackages pkgs -> return (FoundMultiple pkgs) + CantFindAmongst paths -> return (NotFound paths) + + | otherwise = do + j <- findHomeModule' dflags name + case j of + Ok entry -> found_new entry + MultiplePackages pkgs -> return (FoundMultiple pkgs) + CantFindAmongst home_files -> do + r <- findPackageModule' dflags name + case r of + CantFindAmongst pkg_files -> + return (NotFound (home_files ++ pkg_files)) + MultiplePackages pkgs -> + return (FoundMultiple pkgs) + Ok entry -> + found_new entry + +addHomeModuleToFinder :: HscEnv -> Module -> ModLocation -> IO () +addHomeModuleToFinder hsc_env mod loc + = addToFinderCache (hsc_FC hsc_env) mod (loc, Nothing) + +uncacheModule :: HscEnv -> Module -> IO () +uncacheModule hsc_env mod = removeFromFinderCache (hsc_FC hsc_env) mod + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule' :: DynFlags -> Module -> IO LocalFindResult +findHomeModule' dflags mod = do + let home_path = importPaths dflags + hisuf = hiSuf dflags + + let + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod "hs") + , ("lhs", mkHomeModLocationSearched dflags mod "lhs") + ] + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + + searchPathExts home_path mod exts + +findPackageModule' :: DynFlags -> Module -> IO LocalFindResult +findPackageModule' dflags mod + = case lookupModuleInAllPackages dflags mod of + [] -> return (CantFindAmongst []) + [pkg_info] -> findPackageIface dflags mod pkg_info + many -> return (MultiplePackages (map (mkPackageId.package.fst) many)) + +findPackageIface :: DynFlags -> Module -> (PackageConfig,Bool) -> IO LocalFindResult +findPackageIface dflags mod pkg_info@(pkg_conf, _) = do + let + tag = buildTag dflags + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + hi_exts = + [ (package_hisuf, + mkPackageModLocation dflags pkg_info package_hisuf) ] + + source_exts = + [ ("hs", mkPackageModLocation dflags pkg_info package_hisuf) + , ("lhs", mkPackageModLocation dflags pkg_info package_hisuf) + ] + + -- mkdependHS needs to look for source files in packages too, so + -- that we can make dependencies between package before they have + -- been built. + exts + | MkDepend <- ghcMode dflags = hi_exts ++ source_exts + | otherwise = hi_exts + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + + searchPathExts (importDirs pkg_conf) mod exts + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> Module -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO FinderCacheEntry -- action + ) + ] + -> IO LocalFindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result + + where + basename = dots_to_slashes (moduleString mod) + + to_search :: [(FilePath, IO FinderCacheEntry)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path `joinFileName` basename + file = base `joinFileExt` ext + ] + + search [] = return (CantFindAmongst (map fst to_search)) + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + then do { res <- mk_result; return (Ok res) } + else search rest + +mkHomeModLocationSearched :: DynFlags -> Module -> FileExt + -> FilePath -> BaseName -> IO FinderCacheEntry +mkHomeModLocationSearched dflags mod suff path basename = do + loc <- mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff + return (loc, Nothing) + +mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName + -> IO FinderCacheEntry +mkHiOnlyModLocation dflags hisuf path basename = do + loc <- hiOnlyModLocation dflags path basename hisuf + return (loc, Nothing) + +mkPackageModLocation :: DynFlags -> (PackageConfig, Bool) -> FileExt + -> FilePath -> BaseName -> IO FinderCacheEntry +mkPackageModLocation dflags pkg_info hisuf path basename = do + loc <- hiOnlyModLocation dflags path basename hisuf + return (loc, Just pkg_info) + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): dots_to_slashes (moduleNameUserString mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitFilename src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> Module + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 dflags mod src_basename ext = do + let mod_basename = dots_to_slashes (moduleString mod) + + obj_fn <- mkObjPath dflags src_basename mod_basename + hi_fn <- mkHiPath dflags src_basename mod_basename + + return (ModLocation{ ml_hs_file = Just (src_basename `joinFileExt` ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) + +hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation +hiOnlyModLocation dflags path basename hisuf + = do let full_basename = path `joinFileName` basename + obj_fn <- mkObjPath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename `joinFileExt` hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> IO FilePath +mkObjPath dflags basename mod_basename + = do let + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir `joinFileName` mod_basename + | otherwise = basename + + return (obj_basename `joinFileExt` osuf) + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> IO FilePath +mkHiPath dflags basename mod_basename + = do let + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir `joinFileName` mod_basename + | otherwise = basename + + return (hi_basename `joinFileExt` hisuf) + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> Module + -> ModLocation + -> (FilePath,FilePath) + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = dots_to_slashes (moduleString mod) + src_basename = basenameOf (expectJust "mkStubPaths" + (ml_hs_file location)) + + stub_basename0 + | Just dir <- stubdir = dir `joinFileName` mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + (stub_basename `joinFileExt` "c", + stub_basename `joinFileExt` "h") + -- the _stub.o filename is derived from the ml_obj_file. + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = do + let stub_fn = case splitFilename3 obj_fn of + (dir, base, ext) -> dir ++ "/" ++ base ++ "_stub.o" + stub_exist <- doesFileExist stub_fn + if stub_exist + then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) + else return (LM obj_time mod [DotO obj_fn]) + +-- ----------------------------------------------------------------------------- +-- Utils + +dots_to_slashes = map (\c -> if c == '.' then '/' else c) + + +-- ----------------------------------------------------------------------------- +-- Error messages + +cantFindError :: DynFlags -> Module -> FindResult -> SDoc +cantFindError dflags mod_name (FoundMultiple pkgs) + = hang (ptext SLIT("Cannot import") <+> quotes (ppr mod_name) <> colon) 2 ( + sep [ptext SLIT("it was found in multiple packages:"), + hsep (map (text.packageIdString) pkgs)] + ) +cantFindError dflags mod_name find_result + = hang (ptext SLIT("Could not find module") <+> quotes (ppr mod_name) <> colon) + 2 more_info + where + more_info + = case find_result of + PackageHidden pkg + -> ptext SLIT("it is a member of package") <+> ppr pkg <> comma + <+> ptext SLIT("which is hidden") + + ModuleHidden pkg + -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package") + <+> ppr pkg) + + NotFound files + | null files + -> ptext SLIT("it is not a module in the current program, or in any known package.") + | verbosity dflags < 3 + -> ptext SLIT("use -v to see a list of the files searched for") + | otherwise + -> hang (ptext SLIT("locations searched:")) + 2 (vcat (map text files)) + + _ -> panic "cantFindErr" +\end{code} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs new file mode 100644 index 0000000000..3f91af6cc4 --- /dev/null +++ b/compiler/main/GHC.hs @@ -0,0 +1,2053 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005 +-- +-- The GHC API +-- +-- ----------------------------------------------------------------------------- + +module GHC ( + -- * Initialisation + Session, + defaultErrorHandler, + defaultCleanupHandler, + init, initFromArgs, + newSession, + + -- * Flags and settings + DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, + parseDynamicFlags, + initPackages, + getSessionDynFlags, + setSessionDynFlags, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Loading\/compiling the program + depanal, + load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal + workingDirectoryChanged, + checkModule, CheckedModule(..), + TypecheckedSource, ParsedSource, RenamedSource, + + -- * Inspecting the module structure of the program + ModuleGraph, ModSummary(..), ModLocation(..), + getModuleGraph, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, + modInfoPrintUnqualified, + modInfoExports, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, + lookupGlobalName, + + -- * Printing + PrintUnqualified, alwaysQualify, + + -- * Interactive evaluation + getBindings, getPrintUnqual, +#ifdef GHCI + setContext, getContext, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + RunResult(..), + runStmt, + showModule, + compileExpr, HValue, + lookupName, +#endif + + -- * Abstract syntax elements + + -- ** Modules + Module, mkModule, pprModule, + + -- ** Names + Name, + nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + recordSelectorFieldLabel, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + synTyConDefn, synTyConRhs, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, + dataConStrictMarks, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, + pprFundeps, + + -- ** Instances + Instance, + instanceDFunId, pprInstance, pprInstanceHdr, + + -- ** Types and Kinds + Type, dropForAlls, splitForAllTys, funResultTy, pprParendType, + Kind, + PredType, + ThetaType, pprThetaArrow, + + -- ** Entities + TyThing(..), + + -- ** Syntax + module HsSyn, -- ToDo: remove extraneous bits + + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, + + -- ** Source locations + SrcLoc, pprDefnLoc, + + -- * Exceptions + GhcException(..), showGhcException, + + -- * Miscellaneous + sessionHscEnv, + cyclicModuleErr, + ) where + +{- + ToDo: + + * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. + * we need to expose DynFlags, so should parseDynamicFlags really be + part of this interface? + * what StaticFlags should we expose, if any? +-} + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker +import Linker ( HValue, extendLinkEnv ) +import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, + tcRnLookupName, getModuleExports ) +import RdrName ( plusGlobalRdrEnv, Provenance(..), + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + emptyGlobalRdrEnv, mkGlobalRdrEnv ) +import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) +import Type ( tidyType ) +import VarEnv ( emptyTidyEnv ) +import GHC.Exts ( unsafeCoerce# ) +#endif + +import Packages ( initPackages ) +import NameSet ( NameSet, nameSetToList, elemNameSet ) +import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), + globalRdrEnvElts ) +import HsSyn +import Type ( Kind, Type, dropForAlls, PredType, ThetaType, + pprThetaArrow, pprParendType, splitForAllTys, + funResultTy ) +import Id ( Id, idType, isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, recordSelectorFieldLabel, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId ) +import Var ( TyVar ) +import TysPrim ( alphaTyVars ) +import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, + isPrimTyCon, isFunTyCon, tyConArity, + tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs ) +import Class ( Class, classSCTheta, classTvsFds, classMethods ) +import FunDeps ( pprFundeps ) +import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, + dataConFieldLabels, dataConStrictMarks, + dataConIsInfix, isVanillaDataCon ) +import Name ( Name, nameModule, NamedThing(..), nameParent_maybe, + nameSrcLoc, nameOccName ) +import OccName ( parenSymOcc ) +import NameEnv ( nameEnvElts ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +import SrcLoc +import DriverPipeline +import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) +import HeaderInfo ( getImports, getOptions ) +import Packages ( isHomePackage ) +import Finder +import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) +import HscTypes +import DynFlags +import SysTools ( initSysTools, cleanTempFiles ) +import Module +import FiniteMap +import Panic +import Digraph +import Bag ( unitBag ) +import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, + mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings ) +import qualified ErrUtils +import Util +import StringBuffer ( StringBuffer, hGetStringBuffer ) +import Outputable +import SysTools ( cleanTempFilesExcept ) +import BasicTypes +import TcType ( tcSplitSigmaTy, isDictTy ) +import Maybes ( expectJust, mapCatMaybes ) + +import Control.Concurrent +import System.Directory ( getModificationTime, doesFileExist ) +import Data.Maybe ( isJust, isNothing ) +import Data.List ( partition, nub ) +import qualified Data.List as List +import Control.Monad ( unless, when ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Time ( ClockTime ) +import Control.Exception as Exception hiding (handle) +import Data.IORef +import System.IO +import System.IO.Error ( isDoesNotExistError ) +import Prelude hiding (init) + +#if __GLASGOW_HASKELL__ < 600 +import System.IO as System.IO.Error ( try ) +#else +import System.IO.Error ( try ) +#endif + +-- ----------------------------------------------------------------------------- +-- Exception handlers + +-- | Install some default exception handlers and run the inner computation. +-- Unless you want to handle exceptions yourself, you should wrap this around +-- the top level of your program. The default handlers output the error +-- message(s) to stderr and exit cleanly. +defaultErrorHandler :: DynFlags -> IO a -> IO a +defaultErrorHandler dflags inner = + -- top-level exception handler: any unrecognised exception is a compiler bug. + handle (\exception -> do + hFlush stdout + case exception of + -- an IO exception probably isn't our fault, so don't panic + IOException _ -> + fatalErrorMsg dflags (text (show exception)) + AsyncException StackOverflow -> + fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it") + _other -> + fatalErrorMsg dflags (text (show (Panic (show exception)))) + exitWith (ExitFailure 1) + ) $ + + -- program errors: messages with locations attached. Sometimes it is + -- convenient to just throw these as exceptions. + handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn) + exitWith (ExitFailure 1)) $ + + -- error messages propagated as exceptions + handleDyn (\dyn -> do + hFlush stdout + case dyn of + PhaseFailed _ code -> exitWith code + Interrupted -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException))) + exitWith (ExitFailure 1) + ) $ + inner + +-- | Install a default cleanup handler to remove temporary files +-- deposited by a GHC run. This is seperate from +-- 'defaultErrorHandler', because you might want to override the error +-- handling, but still get the ordinary cleanup behaviour. +defaultCleanupHandler :: DynFlags -> IO a -> IO a +defaultCleanupHandler dflags inner = + -- make sure we clean up after ourselves + later (unless (dopt Opt_KeepTmpFiles dflags) $ + cleanTempFiles dflags) + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. + inner + + +-- | Initialises GHC. This must be done /once/ only. Takes the +-- TopDir path without the '-B' prefix. + +init :: Maybe String -> IO () +init mbMinusB = do + -- catch ^C + main_thread <- myThreadId + putMVar interruptTargetThread [main_thread] + installSignalHandlers + + dflags0 <- initSysTools mbMinusB defaultDynFlags + writeIORef v_initDynFlags dflags0 + +-- | Initialises GHC. This must be done /once/ only. Takes the +-- command-line arguments. All command-line arguments which aren't +-- understood by GHC will be returned. + +initFromArgs :: [String] -> IO [String] +initFromArgs args + = do init mbMinusB + return argv1 + where -- Grab the -B option if there is one + (minusB_args, argv1) = partition (prefixMatch "-B") args + mbMinusB | null minusB_args + = Nothing + | otherwise + = Just (drop 2 (last minusB_args)) + +GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags) + -- stores the DynFlags between the call to init and subsequent + -- calls to newSession. + +-- | Starts a new session. A session consists of a set of loaded +-- modules, a set of options (DynFlags), and an interactive context. +-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed +-- code". +newSession :: GhcMode -> IO Session +newSession mode = do + dflags0 <- readIORef v_initDynFlags + dflags <- initDynFlags dflags0 + env <- newHscEnv dflags{ ghcMode=mode } + ref <- newIORef env + return (Session ref) + +-- tmp: this breaks the abstraction, but required because DriverMkDepend +-- needs to call the Finder. ToDo: untangle this. +sessionHscEnv :: Session -> IO HscEnv +sessionHscEnv (Session ref) = readIORef ref + +withSession :: Session -> (HscEnv -> IO a) -> IO a +withSession (Session ref) f = do h <- readIORef ref; f h + +modifySession :: Session -> (HscEnv -> HscEnv) -> IO () +modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h + +-- ----------------------------------------------------------------------------- +-- Flags & settings + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: Session -> IO DynFlags +getSessionDynFlags s = withSession s (return . hsc_dflags) + +-- | Updates the DynFlags in a Session +setSessionDynFlags :: Session -> DynFlags -> IO () +setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags }) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: Session -> IO () +guessOutputFile s = modifySession s $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath, guessedName :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + guessedName = fmap basenameOf mainModuleSrcPath + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = guessedName } } + +-- ----------------------------------------------------------------------------- +-- Targets + +-- ToDo: think about relative vs. absolute file paths. And what +-- happens when the current directory changes. + +-- | Sets the targets for this session. Each target may be a module name +-- or a filename. The targets correspond to the set of root modules for +-- the program\/library. Unloading the current program is achieved by +-- setting the current set of targets to be empty, followed by load. +setTargets :: Session -> [Target] -> IO () +setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets }) + +-- | returns the current set of targets +getTargets :: Session -> IO [Target] +getTargets s = withSession s (return . hsc_targets) + +-- | Add another target +addTarget :: Session -> Target -> IO () +addTarget s target + = modifySession s (\h -> h{ hsc_targets = target : hsc_targets h }) + +-- | Remove a target +removeTarget :: Session -> TargetId -> IO () +removeTarget s target_id + = modifySession s (\h -> h{ hsc_targets = filter (hsc_targets h) }) + where + filter targets = [ t | t@(Target id _) <- targets, id /= target_id ] + +-- Attempts to guess what Target a string refers to. This function implements +-- the --make/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret +-- it as such +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- - otherwise interpret the string as a module name +-- +guessTarget :: String -> Maybe Phase -> IO Target +guessTarget file (Just phase) + = return (Target (TargetFile file (Just phase)) Nothing) +guessTarget file Nothing + | isHaskellSrcFilename file + = return (Target (TargetFile file Nothing) Nothing) + | otherwise + = do exists <- doesFileExist hs_file + if exists + then return (Target (TargetFile hs_file Nothing) Nothing) + else do + exists <- doesFileExist lhs_file + if exists + then return (Target (TargetFile lhs_file Nothing) Nothing) + else do + return (Target (TargetModule (mkModule file)) Nothing) + where + hs_file = file `joinFileExt` "hs" + lhs_file = file `joinFileExt` "lhs" + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph) +depanal (Session ref) excluded_mods allow_dup_roots = do + hsc_env <- readIORef ref + let + dflags = hsc_dflags hsc_env + gmode = ghcMode (hsc_dflags hsc_env) + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + showPass dflags "Chasing dependencies" + when (gmode == BatchCompile) $ + debugTraceMsg dflags 1 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots + case r of + Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph } + _ -> return () + return r + +{- +-- | The result of load. +data LoadResult + = LoadOk Errors -- ^ all specified targets were loaded successfully. + | LoadFailed Errors -- ^ not all modules were loaded. + +type Errors = [String] + +data ErrMsg = ErrMsg { + errMsgSeverity :: Severity, -- warning, error, etc. + errMsgSpans :: [SrcSpan], + errMsgShortDoc :: Doc, + errMsgExtraInfo :: Doc + } +-} + +data LoadHowMuch + = LoadAllTargets + | LoadUpTo Module + | LoadDependenciesOf Module + +-- | Try to load the program. If a Module is supplied, then just +-- attempt to load up to this target. If no Module is supplied, +-- then try to load all targets. +load :: Session -> LoadHowMuch -> IO SuccessFlag +load s@(Session ref) how_much + = do + -- Dependency analysis first. Note that this fixes the module graph: + -- even if we don't get a fully successful upsweep, the full module + -- graph is still retained in the Session. We can tell which modules + -- were successfully loaded by inspecting the Session's HPT. + mb_graph <- depanal s [] False + case mb_graph of + Just mod_graph -> load2 s how_much mod_graph + Nothing -> return Failed + +load2 s@(Session ref) how_much mod_graph = do + guessOutputFile s + hsc_env <- readIORef ref + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + let ghci_mode = ghcMode dflags -- this never changes + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)] +#ifdef DEBUG + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod s `elem` all_home_mods)] +#endif + ASSERT( null bad_boot_mods ) return () + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + | BatchCompile <- ghci_mode = ([],[]) + | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + evaluate pruned_hpt + + debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupModuleEnv pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod ms == mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod ms `elem` stable_obj++stable_bco, + ms_mod ms `notElem` [ ms_mod ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup = cleanTempFilesExcept dflags + (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) + + (upsweep_ok, hsc_env1, modsUpswept) + <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) + pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main + + when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ + debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ moduleString main_mod ++ " module.")) + + -- link everything together + linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult ref hsc_env1 + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (moduleEnvElts (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- link ghci_mode dflags False hpt4 + + let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } + loadFinish Failed linkresult ref hsc_env4 + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish all_ok Failed ref hsc_env + = do unload hsc_env [] + writeIORef ref $! discardProg hsc_env + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded ref hsc_env + = do writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } + return all_ok + + +-- Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = hsc_env { hsc_mod_graph = emptyMG, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable } + +-- used to fish out the preprocess output files for the purposes of +-- cleaning up. The preprocessed file *might* be the same as the +-- source file, but that doesn't do any harm. +ppFilesFromSummaries summaries = map ms_hspp_file summaries + +-- ----------------------------------------------------------------------------- +-- Check module + +data CheckedModule = + CheckedModule { parsedSource :: ParsedSource, + renamedSource :: Maybe RenamedSource, + typecheckedSource :: Maybe TypecheckedSource, + checkedModuleInfo :: Maybe ModuleInfo + } + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields within CheckedModule. + +type ParsedSource = Located (HsModule RdrName) +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name]) +type TypecheckedSource = LHsBinds Id + +-- NOTE: +-- - things that aren't in the output of the typechecker right now: +-- - the export list +-- - the imports +-- - type signatures +-- - type/data/newtype declarations +-- - class declarations +-- - instances +-- - extra things in the typechecker's output: +-- - default methods are turned into top-level decls. +-- - dictionary bindings + + +-- | This is the way to get access to parsed and typechecked source code +-- for a module. 'checkModule' loads all the dependencies of the specified +-- module in the Session, and then attempts to typecheck the module. If +-- successful, it returns the abstract syntax for the module. +checkModule :: Session -> Module -> IO (Maybe CheckedModule) +checkModule session@(Session ref) mod = do + -- load up the dependencies first + r <- load session (LoadDependenciesOf mod) + if (failed r) then return Nothing else do + + -- now parse & typecheck the module + hsc_env <- readIORef ref + let mg = hsc_mod_graph hsc_env + case [ ms | ms <- mg, ms_mod ms == mod ] of + [] -> return Nothing + (ms:_) -> do + mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms + case mbChecked of + Nothing -> return Nothing + Just (HscChecked parsed renamed Nothing) -> + return (Just (CheckedModule { + parsedSource = parsed, + renamedSource = renamed, + typecheckedSource = Nothing, + checkedModuleInfo = Nothing })) + Just (HscChecked parsed renamed + (Just (tc_binds, rdr_env, details))) -> do + let minf = ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = Just rdr_env, + minf_instances = md_insts details + } + return (Just (CheckedModule { + parsedSource = parsed, + renamedSource = renamed, + typecheckedSource = Just tc_binds, + checkedModuleInfo = Just minf })) + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcMode (hsc_dflags hsc_env) of + BatchCompile -> return () + JustTypecheck -> return () +#ifdef GHCI + Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + Interactive -> panic "unload: no interpreter" +#endif + other -> panic "unload: strange mode" + +-- ----------------------------------------------------------------------------- +-- checkStability + +{- + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + NB. stability is of no importance to BatchCompile at all, only Interactive. + (ToDo: what about JustTypecheck?) + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + + ------------------- + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) + ------------------- + + These properties embody the following ideas: + + - if a module is stable: + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a ModDetails. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the upsweep. + All non-stable modules can (and should) therefore be unlinked + before the upsweep. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [Module] -- all home modules + -> ([Module], -- stableObject + [Module]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + + bco_ok ms + = case lookupModuleEnv hpt (ms_mod ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +ms_allimps :: ModSummary -> [Module] +ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) + +-- ----------------------------------------------------------------------------- +-- Prune the HomePackageTable + +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([Module],[Module]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapModuleEnv prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = mi_module (hm_iface hmi) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupModuleEnv ms_map modl) + + ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ] + + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- + +-- Return (names of) all those in modsDone who are part of a cycle +-- as defined by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] +findPartiallyCompletedCycles modsDone theGraph + = chew theGraph + where + chew [] = [] + chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. + chew ((CyclicSCC vs):rest) + = let names_in_this_cycle = nub (map ms_mod vs) + mods_in_this_cycle + = nub ([done | done <- modsDone, + done `elem` names_in_this_cycle]) + chewed_rest = chew rest + in + if notNull mods_in_this_cycle + && length mods_in_this_cycle < length names_in_this_cycle + then mods_in_this_cycle ++ chewed_rest + else chewed_rest + +-- ----------------------------------------------------------------------------- +-- The upsweep + +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. + +-- There better had not be any cyclic groups here -- we check for them. + +upsweep + :: HscEnv -- Includes initially-empty HPT + -> HomePackageTable -- HPT from last time round (pruned) + -> ([Module],[Module]) -- stable modules (see checkStability) + -> IO () -- How to clean up unwanted tmp files + -> [SCC ModSummary] -- Mods to do (the worklist) + -> IO (SuccessFlag, + HscEnv, -- With an updated HPT + [ModSummary]) -- Mods which succeeded + +upsweep hsc_env old_hpt stable_mods cleanup mods + = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods) + +upsweep' hsc_env old_hpt stable_mods cleanup + [] _ _ + = return (Succeeded, hsc_env, []) + +upsweep' hsc_env old_hpt stable_mods cleanup + (CyclicSCC ms:_) _ _ + = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) + return (Failed, hsc_env, []) + +upsweep' hsc_env old_hpt stable_mods cleanup + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + + mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod + mod_index nmods + + cleanup -- Remove unwanted tmp files between compilations + + case mb_mod_info of + Nothing -> return (Failed, hsc_env, []) + Just mod_info -> do + { let this_mod = ms_mod mod + + -- Add new info to hsc_env + hpt1 = extendModuleEnv (hsc_HPT hsc_env) + this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force .. (what?? --SDM) + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delModuleEnv old_hpt this_mod + + ; (restOK, hsc_env2, modOKs) + <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup + mods (mod_index+1) nmods + ; return (restOK, hsc_env2, mod:modOKs) + } + + +-- Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([Module],[Module]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO (Maybe HomeModInfo) -- Nothing => Failed + +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = do + let + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) + compile_it = upsweep_compile hsc_env old_hpt this_mod + summary mod_index nmods + + case ghcMode (hsc_dflags hsc_env) of + BatchCompile -> + case () of + -- Batch-compilating is easy: just check whether we have + -- an up-to-date object file. If we do, then the compiler + -- needs to do a recompilation check. + _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do + linkable <- + findObjectLinkable this_mod obj_fn obj_date + compile_it (Just linkable) + + | otherwise -> + compile_it Nothing + + interactive -> + case () of + _ | is_stable_obj, isJust old_hmi -> + return old_hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + linkable <- + findObjectLinkable this_mod obj_fn + (expectJust "upseep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | is_stable_bco -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + return old_hmi + -- BCO is stable: nothing to do + + | Just hmi <- old_hmi, + Just l <- hm_linkable hmi, not (isObjectLinkable l), + linkableTime l >= ms_hs_date summary -> + compile_it (Just l) + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + | otherwise -> + compile_it Nothing + -- no existing code at all: we must recompile. + where + is_stable_obj = this_mod `elem` stable_obj + is_stable_bco = this_mod `elem` stable_bco + + old_hmi = lookupModuleEnv old_hpt this_mod + +-- Run hsc to compile a module +upsweep_compile hsc_env old_hpt this_mod summary + mod_index nmods + mb_old_linkable = do + let + -- The old interface is ok if it's in the old HPT + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case lookupModuleEnv old_hpt this_mod of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compresult <- compile hsc_env summary mb_old_linkable mb_old_iface + mod_index nmods + + case compresult of + -- Compilation failed. Compile may still have updated the PCS, tho. + CompErrs -> return Nothing + + -- Compilation "succeeded", and may or may not have returned a new + -- linkable (depending on whether compilation was actually performed + -- or not). + CompOK new_details new_iface new_linkable + -> do let new_info = HomeModInfo { hm_iface = new_iface, + hm_details = new_details, + hm_linkable = new_linkable } + return (Just new_info) + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupModuleEnv hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Topological sort of the module graph + +topSortModuleGraph + :: Bool -- Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe Module + -> [SCC ModSummary] +-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- False: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- True: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can by cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries Nothing + = stronglyConnComp (fst (moduleGraphNodes drop_hs_boot_nodes summaries)) +topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) + = stronglyConnComp (map vertex_fn (reachable graph root)) + where + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + (nodes, lookup_key) = moduleGraphNodes drop_hs_boot_nodes summaries + (graph, vertex_fn, key_fn) = graphFromEdges' nodes + root + | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v + | otherwise = throwDyn (ProgramError "module does not exist") + +moduleGraphNodes :: Bool -> [ModSummary] + -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int) +moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) + where + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + -- We use integers as the keys for the SCC algorithm + nodes :: [(ModSummary, Int, [Int])] + nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), + out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) + | s <- summaries + , not (isBootSummary s && drop_hs_boot_nodes) ] + -- Drop the hi-boot ones if told to do so + + key_map :: NodeMap Int + key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries] + `zip` [1..]) + + lookup_key :: HscSource -> Module -> Maybe Int + lookup_key hs_src mod = lookupFM key_map (mod, hs_src) + + out_edge_keys :: HscSource -> [Module] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False + + +type NodeKey = (Module, HscSource) -- The nodes of the graph are +type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = eltsFM + +----------------------------------------------------------------------------- +-- Downsweep (dependency analysis) + +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. + +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. + +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [Module] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO (Maybe [ModSummary]) + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = -- catch error messages and return them + handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return (Just summs) + where + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) maybe_buf) + = do exists <- doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase maybe_buf + else throwDyn $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan FSLIT("<command line>") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located Module,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- lookupFM done key + = if isSingleton summs then + loop ss done + else + do { multiRootsErr summs; return [] } + | otherwise = do { mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod Nothing excl_mods + ; case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) + (addToFM done key [s]) } + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + +mkRootMap :: [ModSummary] -> NodeMap [ModSummary] +mkRootMap summaries = addListToFM_C (++) emptyFM + [ (msKey s, [s]) | s <- summaries ] + +msDeps :: ModSummary -> [(Located Module, IsBootInterface)] +-- (msDeps s) returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps s = + concat [ [(m,True), (m,False)] | m <- ms_srcimps s ] + ++ [ (m,False) | m <- ms_imps s ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location False + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env + + (dflags', hspp_fn, buf) + <- preprocessFile dflags file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn + + -- Make a ModLocation for this file + location <- mkHomeModLocation dflags mod file + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + addHomeModuleToFinder hsc_env mod location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> getModificationTime file + -- getMofificationTime may fail + + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:xs) -> Just x + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located Module -- Imported module to be summarised + -> Maybe (StringBuffer, ClockTime) + -> [Module] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- System.IO.Error.try (getModificationTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + hsc_src = if is_boot then HsBootFile else HsSrcFile + + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- getObjTimestamp location is_boot + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: find and re-summarise. We call the finder + -- again, because the user may have moved the source file. + new_summary location src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findModule hsc_env wanted_mod True {-explicit-} + case found of + Found location pkg + | not (isHomePackage pkg) -> return Nothing + -- Drop external-pkg + | isJust (ml_hs_file location) -> just_found location + -- Home package + err -> noModError dflags loc wanted_mod err + -- Not found + + just_found location = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr loc src_fn + Just t -> new_summary location' src_fn t + + + new_summary location src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn + + when (mod_name /= wanted_mod) $ + throwDyn $ mkPlainErrMsg mod_loc $ + text "file name does not match module name" + <+> quotes (ppr mod_name) + + -- Find the object timestamp, and return the summary + obj_timestamp <- getObjTimestamp location is_boot + + return (Just ( ModSummary { ms_mod = wanted_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: DynFlags -> FilePath -> Maybe Phase -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile dflags src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess dflags (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile dflags src_fn mb_phase (Just (buf, time)) + = do + -- case we bypass the preprocessing stage? + let + local_opts = getOptions buf src_fn + -- + (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) + + let + needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | dopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err + +noHsFileErr loc path + = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr mod + = throwDyn $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr summs@(summ1:_) + = throwDyn $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +cyclicModuleErr :: [ModSummary] -> SDoc +cyclicModuleErr ms + = hang (ptext SLIT("Module imports form a cycle for modules:")) + 2 (vcat (map show_one ms)) + where + show_one ms = sep [ show_mod (ms_hsc_src ms) (ms_mod ms), + nest 2 $ ptext SLIT("imports:") <+> + (pp_imps HsBootFile (ms_srcimps ms) + $$ pp_imps HsSrcFile (ms_imps ms))] + show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) + pp_imps src mods = fsep (map (show_mod src) mods) + + +-- | Inform GHC that the working directory has changed. GHC will flush +-- its cache of module locations, since it may no longer be valid. +-- Note: if you change the working directory, you should also unload +-- the current program (set targets to empty, followed by load). +workingDirectoryChanged :: Session -> IO () +workingDirectoryChanged s = withSession s $ \hsc_env -> + flushFinderCache (hsc_FC hsc_env) + +-- ----------------------------------------------------------------------------- +-- inspecting the session + +-- | Get the module dependency graph. +getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph s = withSession s (return . hsc_mod_graph) + +isLoaded :: Session -> Module -> IO Bool +isLoaded s m = withSession s $ \hsc_env -> + return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m) + +getBindings :: Session -> IO [TyThing] +getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) + +getPrintUnqual :: Session -> IO PrintUnqualified +getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: NameSet, + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [Instance] + -- ToDo: this should really contain the ModIface too + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) +getModuleInfo s mdl = withSession s $ \hsc_env -> do + let mg = hsc_mod_graph hsc_env + if mdl `elem` map ms_mod mg + then getHomeModuleInfo hsc_env mdl + else do + {- if isHomeModule (hsc_dflags hsc_env) mdl + then return Nothing + else -} getPackageModuleInfo hsc_env mdl + -- getPackageModuleInfo will attempt to find the interface, so + -- we don't want to call it for a home module, just in case there + -- was a problem loading the module and the interface doesn't + -- exist... hence the isHomeModule test here. (ToDo: reinstate) + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl = do +#ifdef GHCI + (_msgs, mb_names) <- getModuleExports hsc_env mdl + case mb_names of + Nothing -> return Nothing + Just names -> do + eps <- readIORef (hsc_EPS hsc_env) + let + pte = eps_PTE eps + n_list = nameSetToList names + tys = [ ty | name <- n_list, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl, + minf_instances = error "getModuleInfo: instances for package module unimplemented" + })) +#else + -- bogusly different for non-GHCI (ToDo) + return Nothing +#endif + +getHomeModuleInfo hsc_env mdl = + case lookupModuleEnv (hsc_HPT hsc_env) mdl of + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] +modInfoTopLevelScope minf + = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = nameSetToList $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [Instance] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) + +modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified +modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) + +modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) +modInfoLookupName s minf name = withSession s $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + +isDictonaryId :: Id -> Bool +isDictonaryId id + = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + +-- | Looks up a global name: that is, any top-level name in any +-- visible module. Unlike 'lookupName', lookupGlobalName does not use +-- the interactive context, and therefore does not require a preceding +-- 'setContext'. +lookupGlobalName :: Session -> Name -> IO (Maybe TyThing) +lookupGlobalName s name = withSession s $ \hsc_env -> do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + +-- ----------------------------------------------------------------------------- +-- Misc exported utils + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +-- | print a 'NamedThing', adding parentheses if the name is an operator. +pprParenSymName :: NamedThing a => a -> SDoc +pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) + +-- ---------------------------------------------------------------------------- + +#if 0 + +-- ToDo: +-- - Data and Typeable instances for HsSyn. + +-- ToDo: check for small transformations that happen to the syntax in +-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral) + +-- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way +-- to get from TyCons, Ids etc. to TH syntax (reify). + +-- :browse will use either lm_toplev or inspect lm_interface, depending +-- on whether the module is interpreted or not. + +-- This is for reconstructing refactored source code +-- Calls the lexer repeatedly. +-- ToDo: add comment tokens to token stream +getTokenStream :: Session -> Module -> IO [Located Token] +#endif + +-- ----------------------------------------------------------------------------- +-- Interactive evaluation + +#ifdef GHCI + +-- | Set the interactive evaluation context. +-- +-- Setting the context doesn't throw away any bindings; the bindings +-- we've built up in the InteractiveContext simply move to the new +-- module. They always shadow anything in scope in the current context. +setContext :: Session + -> [Module] -- entire top level scope of these modules + -> [Module] -- exports only of these modules + -> IO () +setContext (Session ref) toplevs exports = do + hsc_env <- readIORef ref + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + + mapM_ (checkModuleExists hsc_env hpt) exports + export_env <- mkExportEnv hsc_env exports + toplev_envs <- mapM (mkTopLevEnv hpt) toplevs + let all_env = foldr plusGlobalRdrEnv export_env toplev_envs + writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs, + ic_exports = exports, + ic_rn_gbl_env = all_env }} + + +-- Make a GlobalRdrEnv based on the exports of the modules only. +mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv +mkExportEnv hsc_env mods = do + stuff <- mapM (getModuleExports hsc_env) mods + let + (_msgs, mb_name_sets) = unzip stuff + gres = [ nameSetToGlobalRdrEnv name_set mod + | (Just name_set, mod) <- zip mb_name_sets mods ] + -- + return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres + +nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv +nameSetToGlobalRdrEnv names mod = + mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } + | name <- nameSetToList names ] + +vanillaProv :: Module -> Provenance +-- We're building a GlobalRdrEnv as if the user imported +-- all the specified modules into the global interactive module +vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] + where + decl = ImpDeclSpec { is_mod = mod, is_as = mod, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } + +checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO () +checkModuleExists hsc_env hpt mod = + case lookupModuleEnv hpt mod of + Just mod_info -> return () + _not_a_home_module -> do + res <- findPackageModule hsc_env mod True + case res of + Found _ _ -> return () + err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in + throwDyn (CmdLineError (showSDoc msg)) + +mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv hpt modl + = case lookupModuleEnv hpt modl of + Nothing -> + throwDyn (ProgramError ("mkTopLevEnv: not a home module " + ++ showSDoc (pprModule modl))) + Just details -> + case mi_globals (hm_iface details) of + Nothing -> + throwDyn (ProgramError ("mkTopLevEnv: not interpreted " + ++ showSDoc (pprModule modl))) + Just env -> return env + +-- | Get the interactive evaluation context, consisting of a pair of the +-- set of modules from which we take the full top-level scope, and the set +-- of modules from which we take just the exports respectively. +getContext :: Session -> IO ([Module],[Module]) +getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> + return (ic_toplev_scope ic, ic_exports ic)) + +-- | Returns 'True' if the specified module is interpreted, and hence has +-- its full top-level scope available. +moduleIsInterpreted :: Session -> Module -> IO Bool +moduleIsInterpreted s modl = withSession s $ \h -> + case lookupModuleEnv (hsc_HPT h) modl of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False + +-- | Looks up an identifier in the current interactive context (for :info) +getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) +getInfo s name = withSession s $ \hsc_env -> tcRnGetInfo hsc_env name + +-- | Returns all names in scope in the current interactive context +getNamesInScope :: Session -> IO [Name] +getNamesInScope s = withSession s $ \hsc_env -> do + return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) + +getRdrNamesInScope :: Session -> IO [RdrName] +getRdrNamesInScope s = withSession s $ \hsc_env -> do + let env = ic_rn_gbl_env (hsc_IC hsc_env) + return (concat (map greToRdrNames (globalRdrEnvElts env))) + +-- ToDo: move to RdrName +greToRdrNames :: GlobalRdrElt -> [RdrName] +greToRdrNames GRE{ gre_name = name, gre_prov = prov } + = case prov of + LocalDef -> [unqual] + Imported specs -> concat (map do_spec (map is_decl specs)) + where + occ = nameOccName name + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- | Parses a string as an identifier, and returns the list of 'Name's that +-- the identifier can refer to in the current interactive context. +parseName :: Session -> String -> IO [Name] +parseName s str = withSession s $ \hsc_env -> do + maybe_rdr_name <- hscParseIdentifier (hsc_dflags hsc_env) str + case maybe_rdr_name of + Nothing -> return [] + Just (L _ rdr_name) -> do + mb_names <- tcRnLookupRdrName hsc_env rdr_name + case mb_names of + Nothing -> return [] + Just ns -> return ns + -- ToDo: should return error messages + +-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any +-- entity known to GHC, including 'Name's defined using 'runStmt'. +lookupName :: Session -> Name -> IO (Maybe TyThing) +lookupName s name = withSession s $ \hsc_env -> tcRnLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Getting the type of an expression + +-- | Get the type of an expression +exprType :: Session -> String -> IO (Maybe Type) +exprType s expr = withSession s $ \hsc_env -> do + maybe_stuff <- hscTcExpr hsc_env expr + case maybe_stuff of + Nothing -> return Nothing + Just ty -> return (Just tidy_ty) + where + tidy_ty = tidyType emptyTidyEnv ty + +-- ----------------------------------------------------------------------------- +-- Getting the kind of a type + +-- | Get the kind of a type +typeKind :: Session -> String -> IO (Maybe Kind) +typeKind s str = withSession s $ \hsc_env -> do + maybe_stuff <- hscKcType hsc_env str + case maybe_stuff of + Nothing -> return Nothing + Just kind -> return (Just kind) + +----------------------------------------------------------------------------- +-- cmCompileExpr: compile an expression and deliver an HValue + +compileExpr :: Session -> String -> IO (Maybe HValue) +compileExpr s expr = withSession s $ \hsc_env -> do + maybe_stuff <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) + case maybe_stuff of + Nothing -> return Nothing + Just (new_ic, names, hval) -> do + -- Run it! + hvals <- (unsafeCoerce# hval) :: IO [HValue] + + case (names,hvals) of + ([n],[hv]) -> return (Just hv) + _ -> panic "compileExpr" + +-- ----------------------------------------------------------------------------- +-- running a statement interactively + +data RunResult + = RunOk [Name] -- ^ names bound by this evaluation + | RunFailed -- ^ statement failed compilation + | RunException Exception -- ^ statement raised an exception + +-- | Run a statement in the current interactive context. Statemenet +-- may bind multple values. +runStmt :: Session -> String -> IO RunResult +runStmt (Session ref) expr + = do + hsc_env <- readIORef ref + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + maybe_stuff <- hscStmt hsc_env' expr + + case maybe_stuff of + Nothing -> return RunFailed + Just (new_hsc_env, names, hval) -> do + + let thing_to_run = unsafeCoerce# hval :: IO [HValue] + either_hvals <- sandboxIO thing_to_run + + case either_hvals of + Left e -> do + -- on error, keep the *old* interactive context, + -- so that 'it' is not bound to something + -- that doesn't exist. + return (RunException e) + + Right hvals -> do + -- Get the newly bound things, and bind them. + -- Don't need to delete any shadowed bindings; + -- the new ones override the old ones. + extendLinkEnv (zip names hvals) + + writeIORef ref new_hsc_env + return (RunOk names) + +-- When running a computation, we redirect ^C exceptions to the running +-- thread. ToDo: we might want a way to continue even if the target +-- thread doesn't die when it receives the exception... "this thread +-- is not responding". +sandboxIO :: IO a -> IO (Either Exception a) +sandboxIO thing = do + m <- newEmptyMVar + ts <- takeMVar interruptTargetThread + child <- forkIO (do res <- Exception.try thing; putMVar m res) + putMVar interruptTargetThread (child:ts) + takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail) + +{- +-- This version of sandboxIO runs the expression in a completely new +-- RTS main thread. It is disabled for now because ^C exceptions +-- won't be delivered to the new thread, instead they'll be delivered +-- to the (blocked) GHCi main thread. + +-- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception + +sandboxIO :: IO a -> IO (Either Int (Either Exception a)) +sandboxIO thing = do + st_thing <- newStablePtr (Exception.try thing) + alloca $ \ p_st_result -> do + stat <- rts_evalStableIO st_thing p_st_result + freeStablePtr st_thing + if stat == 1 + then do st_result <- peek p_st_result + result <- deRefStablePtr st_result + freeStablePtr st_result + return (Right result) + else do + return (Left (fromIntegral stat)) + +foreign import "rts_evalStableIO" {- safe -} + rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt + -- more informative than the C type! +-} + +----------------------------------------------------------------------------- +-- show a module and it's source/object filenames + +showModule :: Session -> ModSummary -> IO String +showModule s mod_summary = withSession s $ \hsc_env -> do + case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of + Nothing -> panic "missing linkable" + Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + +#endif /* GHCI */ diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs new file mode 100644 index 0000000000..913ac33a33 --- /dev/null +++ b/compiler/main/HeaderInfo.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- +-- Parsing the top of a Haskell source file to get its module name, +-- imports and options. +-- +-- (c) Simon Marlow 2005 +-- (c) Lemmih 2006 +-- +----------------------------------------------------------------------------- + +module HeaderInfo ( getImportsFromFile, getImports + , getOptionsFromFile, getOptions + , optionsErrorMsgs ) where + +#include "HsVersions.h" + +import Parser ( parseHeader ) +import Lexer ( P(..), ParseResult(..), mkPState, pragState + , lexer, Token(..), PState(..) ) +import FastString +import HsSyn ( ImportDecl(..), HsModule(..) ) +import Module ( Module, mkModule ) +import PrelNames ( gHC_PRIM ) +import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock + , appendStringBuffers ) +import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan ) +import FastString ( mkFastString ) +import DynFlags ( DynFlags ) +import ErrUtils +import Util +import Outputable +import Pretty () +import Panic +import Bag ( unitBag, emptyBag, listToBag ) + +import Distribution.Compiler + +import TRACE + +import EXCEPTION ( throwDyn ) +import IO +import List + +#if __GLASGOW_HASKELL__ >= 601 +import System.IO ( openBinaryFile ) +#else +import IOExts ( openFileEx, IOModeEx(..) ) +#endif + +#if __GLASGOW_HASKELL__ < 601 +openBinaryFile fp mode = openFileEx fp (BinaryMode mode) +#endif + +-- getImportsFromFile is careful to close the file afterwards, otherwise +-- we can end up with a large number of open handles before the garbage +-- collector gets around to closing them. +getImportsFromFile :: DynFlags -> FilePath + -> IO ([Located Module], [Located Module], Located Module) +getImportsFromFile dflags filename = do + buf <- hGetStringBuffer filename + getImports dflags buf filename + +getImports :: DynFlags -> StringBuffer -> FilePath + -> IO ([Located Module], [Located Module], Located Module) +getImports dflags buf filename = do + let loc = mkSrcLoc (mkFastString filename) 1 0 + case unP parseHeader (mkPState buf loc dflags) of + PFailed span err -> parseError span err + POk _ rdr_module -> + case rdr_module of + L _ (HsModule mod _ imps _ _) -> + let + mod_name | Just located_mod <- mod = located_mod + | otherwise = L noSrcSpan (mkModule "Main") + (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) + source_imps = map getImpMod src_idecls + ordinary_imps = filter ((/= gHC_PRIM) . unLoc) + (map getImpMod ord_idecls) + -- GHC.Prim doesn't exist physically, so don't go looking for it. + in + return (source_imps, ordinary_imps, mod_name) + +parseError span err = throwDyn $ mkPlainErrMsg span err + +isSourceIdecl (ImportDecl _ s _ _ _) = s + +getImpMod (ImportDecl located_mod _ _ _ _) = located_mod + +-------------------------------------------------------------- +-- Get options +-------------------------------------------------------------- + + +getOptionsFromFile :: FilePath -- input file + -> IO [Located String] -- options, if any +getOptionsFromFile filename + = bracket (openBinaryFile filename ReadMode) + (hClose) + (\handle -> + do buf <- hGetStringBufferBlock handle blockSize + loop handle buf) + where blockSize = 1024 + loop handle buf + | len buf == 0 = return [] + | otherwise + = case getOptions' buf filename of + (Nothing, opts) -> return opts + (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize + newBuf <- appendStringBuffers buf' nextBlock + if len newBuf == len buf + then return opts + else do opts' <- loop handle newBuf + return (opts++opts') + +getOptions :: StringBuffer -> FilePath -> [Located String] +getOptions buf filename + = case getOptions' buf filename of + (_,opts) -> opts + +-- The token parser is written manually because Happy can't +-- return a partial result when it encounters a lexer error. +-- We want to extract options before the buffer is passed through +-- CPP, so we can't use the same trick as 'getImports'. +getOptions' :: StringBuffer -- Input buffer + -> FilePath -- Source file. Used for msgs only. + -> ( Maybe StringBuffer -- Just => we can use more input + , [Located String] -- Options. + ) +getOptions' buf filename + = parseToks (lexAll (pragState buf loc)) + where loc = mkSrcLoc (mkFastString filename) 1 0 + + getToken (buf,L _loc tok) = tok + getLoc (buf,L loc _tok) = loc + getBuf (buf,_tok) = buf + combine opts (flag, opts') = (flag, opts++opts') + add opt (flag, opts) = (flag, opt:opts) + + parseToks (open:close:xs) + | IToptions_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) (words str) `combine` + parseToks xs + parseToks (open:close:xs) + | ITinclude_prag str <- getToken open + , ITclose_prag <- getToken close + = map (L (getLoc open)) ["-#include",removeSpaces str] `combine` + parseToks xs + parseToks (open:xs) + | ITlanguage_prag <- getToken open + = parseLanguage xs + -- The last token before EOF could have been truncated. + -- We ignore it to be on the safe side. + parseToks [tok,eof] + | ITeof <- getToken eof + = (Just (getBuf tok),[]) + parseToks (eof:_) + | ITeof <- getToken eof + = (Just (getBuf eof),[]) + parseToks _ = (Nothing,[]) + parseLanguage ((_buf,L loc (ITconid fs)):rest) + = checkExtension (L loc fs) `add` + case rest of + (_,L loc ITcomma):more -> parseLanguage more + (_,L loc ITclose_prag):more -> parseToks more + (_,L loc _):_ -> languagePragParseError loc + parseLanguage (tok:_) + = languagePragParseError (getLoc tok) + lexToken t = return t + lexAll state = case unP (lexer lexToken) state of + POk state' t@(L _ ITeof) -> [(buffer state,t)] + POk state' t -> (buffer state,t):lexAll state' + _ -> [(buffer state,L (last_loc state) ITeof)] + +checkExtension :: Located FastString -> Located String +checkExtension (L l ext) + = case reads (unpackFS ext) of + [] -> languagePragParseError l + (okExt,""):_ -> case extensionsToGHCFlag [okExt] of + ([],[opt]) -> L l opt + _ -> unsupportedExtnError l okExt + +languagePragParseError loc = + pgmError (showSDoc (mkLocMessage loc ( + text "cannot parse LANGUAGE pragma"))) + +unsupportedExtnError loc unsup = + pgmError (showSDoc (mkLocMessage loc ( + text "unsupported extension: " <> + (text.show) unsup))) + + +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs unhandled_flags flags_lines filename + = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = + ErrUtils.mkPlainErrMsg flagSpan $ + text "unknown flag in {-# OPTIONS #-} pragma:" <+> text flag + diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs new file mode 100644 index 0000000000..e170f8fa31 --- /dev/null +++ b/compiler/main/HscMain.lhs @@ -0,0 +1,965 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +% + +\section[GHC_Main]{Main driver for Glasgow Haskell compiler} + +\begin{code} +module HscMain + ( newHscEnv, hscCmmFile + , hscFileCheck + , hscParseIdentifier +#ifdef GHCI + , hscStmt, hscTcExpr, hscKcType + , compileExpr +#endif + , hscCompileOneShot -- :: Compiler HscStatus + , hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails) + , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) + , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) + , HscStatus (..) + , InteractiveStatus (..) + , HscChecked (..) + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) +import Module ( Module ) +import CodeOutput ( outputForeignStubs ) +import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import Linker ( HValue, linkExpr ) +import CoreTidy ( tidyExpr ) +import CorePrep ( corePrepExpr ) +import Flattening ( flattenExpr ) +import Desugar ( deSugarExpr ) +import SimplCore ( simplifyExpr ) +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) +import Type ( Type ) +import PrelNames ( iNTERACTIVE ) +import Kind ( Kind ) +import CoreLint ( lintUnfolding ) +import DsMeta ( templateHaskellNames ) +import SrcLoc ( noSrcLoc ) +import VarEnv ( emptyTidyEnv ) +#endif + +import Var ( Id ) +import Module ( emptyModuleEnv, ModLocation(..) ) +import RdrName ( GlobalRdrEnv, RdrName ) +import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl ) +import SrcLoc ( Located(..) ) +import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) +import Parser +import Lexer ( P(..), ParseResult(..), mkPState ) +import SrcLoc ( mkSrcLoc ) +import TcRnDriver ( tcRnModule, tcRnExtCore ) +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import MkIface ( checkOldIface, mkIface, writeIfaceFile ) +import Desugar ( deSugar ) +import Flattening ( flatten ) +import SimplCore ( core2core ) +import TidyPgm ( tidyProgram, mkBootModDetails ) +import CorePrep ( corePrepPgm ) +import CoreToStg ( coreToStg ) +import TyCon ( isDataTyCon ) +import Packages ( mkHomeModules ) +import Name ( Name, NamedThing(..) ) +import SimplStg ( stg2stg ) +import CodeGen ( codeGen ) +import CmmParse ( parseCmmFile ) +import CodeOutput ( codeOutput ) + +import DynFlags +import ErrUtils +import UniqSupply ( mkSplitUniqSupply ) + +import Outputable +import HscStats ( ppSourceStats ) +import HscTypes +import MkExternalCore ( emitExternalCore ) +import ParserCore +import ParserCoreUtils +import FastString +import Maybes ( expectJust ) +import Bag ( unitBag ) +import Monad ( unless ) +import IO +import DATA_IOREF ( newIORef, readIORef ) +\end{code} + + +%************************************************************************ +%* * + Initialisation +%* * +%************************************************************************ + +\begin{code} +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags + = do { eps_var <- newIORef initExternalPackageState + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; fc_var <- newIORef emptyModuleEnv + ; return (HscEnv { hsc_dflags = dflags, + hsc_targets = [], + hsc_mod_graph = [], + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var } ) } + + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames = map getName wiredInThings + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif +\end{code} + + +%************************************************************************ +%* * + The main compiler pipeline +%* * +%************************************************************************ + + -------------------------------- + The compilation proper + -------------------------------- + + +It's the task of the compilation proper to compile Haskell, hs-boot and +core files to either byte-code, hard-code (C, asm, Java, ect) or to +nothing at all (the module is still parsed and type-checked. This +feature is mostly used by IDE's and the likes). +Compilation can happen in either 'one-shot', 'batch', 'nothing', +or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' mode +targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. +The modes are kept separate because of their different types and meanings. +In 'one-shot' mode, we're only compiling a single file and can therefore +discard the new ModIface and ModDetails. This is also the reason it only +targets hard-code; compiling to byte-code or nothing doesn't make sense +when we discard the result. +'Batch' mode is like 'one-shot' except that we keep the resulting ModIface +and ModDetails. 'Batch' mode doesn't target byte-code since that require +us to return the newly compiled byte-code. +'Nothing' mode has exactly the same type as 'batch' mode but they're still +kept separate. This is because compiling to nothing is fairly special: We +don't output any interface files, we don't run the simplifier and we don't +generate any code. +'Interactive' mode is similar to 'batch' mode except that we return the +compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time +error. This is the only thing that isn't caught by the type-system. + +\begin{code} + +data HscChecked + = HscChecked + -- parsed + (Located (HsModule RdrName)) + -- renamed + (Maybe (HsGroup Name,[LImportDecl Name],Maybe [LIE Name])) + -- typechecked + (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) + + +-- Status of a compilation to hard-code or nothing. +data HscStatus + = HscNoRecomp + | HscRecomp Bool -- Has stub files. + -- This is a hack. We can't compile C files here + -- since it's done in DriverPipeline. For now we + -- just return True if we want the caller to compile + -- it for us. + +-- Status of a compilation to byte-code. +data InteractiveStatus + = InteractiveNoRecomp + | InteractiveRecomp Bool -- Same as HscStatus + CompiledByteCode + + +-- I want Control.Monad.State! --Lemmih 03/07/2006 +newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)} + +instance Monad Comp where + g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s' + return a = Comp $ \s -> return (a,s) + fail = error + +evalComp :: Comp a -> CompState -> IO a +evalComp comp st = do (val,_st') <- runComp comp st + return val + +data CompState + = CompState + { compHscEnv :: HscEnv + , compModSummary :: ModSummary + , compOldIface :: Maybe ModIface + } + +get :: Comp CompState +get = Comp $ \s -> return (s,s) + +gets :: (CompState -> a) -> Comp a +gets getter = do st <- get + return (getter st) + +liftIO :: IO a -> Comp a +liftIO ioA = Comp $ \s -> do a <- ioA + return (a,s) + +type NoRecomp result = ModIface -> Comp result +type FrontEnd core = Comp (Maybe core) + +-- FIXME: The old interface and module index are only using in 'batch' and +-- 'interactive' mode. They should be removed from 'oneshot' mode. +type Compiler result = HscEnv + -> ModSummary + -> Bool -- True <=> source unchanged + -> Maybe ModIface -- Old interface, if available + -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) + -> IO (Maybe result) + + +-- This functions checks if recompilation is necessary and +-- then combines the FrontEnd and BackEnd to a working compiler. +hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required. + -> (Maybe (Int,Int) -> Bool -> Comp ()) + -> FrontEnd core + -> (core -> Comp result) -- Backend. + -> Compiler result +hscMkCompiler norecomp messenger frontend backend + hsc_env mod_summary source_unchanged + mbOldIface mbModIndex + = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ + do (recomp_reqd, mbCheckedIface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_unchanged mbOldIface + case mbCheckedIface of + Just iface | not recomp_reqd + -> do messenger mbModIndex False + result <- norecomp iface + return (Just result) + _otherwise + -> do messenger mbModIndex True + mbCore <- frontend + case mbCore of + Nothing + -> return Nothing + Just core + -> do result <- backend core + return (Just result) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +-- 1 2 3 4 5 6 7 8 9 +-- Compile Haskell, boot and extCore in OneShot mode. +hscCompileOneShot :: Compiler HscStatus +hscCompileOneShot hsc_env mod_summary = + compiler hsc_env mod_summary + where mkComp = hscMkCompiler norecompOneShot oneShotMsg + -- How to compile nonBoot files. + nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= + hscWriteIface >>= hscOneShot + -- How to compile boot files. + bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscConst (HscRecomp False) + compiler + = case ms_hsc_src mod_summary of + ExtCoreFile + -> mkComp hscCoreFrontEnd nonBootComp + HsSrcFile + -> mkComp hscFileFrontEnd nonBootComp + HsBootFile + -> mkComp hscFileFrontEnd bootComp + +-- Compile Haskell, boot and extCore in batch mode. +hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileBatch hsc_env mod_summary + = compiler hsc_env mod_summary + where mkComp = hscMkCompiler norecompBatch batchMsg + nonBootComp inp = hscSimplify inp >>= hscNormalIface >>= + hscWriteIface >>= hscBatch + bootComp inp = hscSimpleIface inp >>= hscWriteIface >>= hscNothing + compiler + = case ms_hsc_src mod_summary of + ExtCoreFile + -> mkComp hscCoreFrontEnd nonBootComp + HsSrcFile + -> mkComp hscFileFrontEnd nonBootComp + HsBootFile + -> mkComp hscFileFrontEnd bootComp + +-- Type-check Haskell, boot and extCore. +-- Does it make sense to compile extCore to nothing? +hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) +hscCompileNothing hsc_env mod_summary + = compiler hsc_env mod_summary + where mkComp = hscMkCompiler norecompBatch batchMsg + pipeline inp = hscSimpleIface inp >>= hscIgnoreIface >>= hscNothing + compiler + = case ms_hsc_src mod_summary of + ExtCoreFile + -> mkComp hscCoreFrontEnd pipeline + HsSrcFile + -> mkComp hscFileFrontEnd pipeline + HsBootFile + -> mkComp hscFileFrontEnd pipeline + +-- Compile Haskell, extCore to bytecode. +hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) +hscCompileInteractive hsc_env mod_summary = + hscMkCompiler norecompInteractive batchMsg + frontend backend + hsc_env mod_summary + where backend inp = hscSimplify inp >>= hscNormalIface >>= hscIgnoreIface >>= hscInteractive + frontend = case ms_hsc_src mod_summary of + ExtCoreFile -> hscCoreFrontEnd + HsSrcFile -> hscFileFrontEnd + HsBootFile -> panic bootErrorMsg + bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++ + "Use 'hscCompileBatch' instead." + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + +norecompOneShot :: NoRecomp HscStatus +norecompOneShot old_iface + = do hsc_env <- gets compHscEnv + liftIO $ do + dumpIfaceStats hsc_env + return HscNoRecomp + +norecompBatch :: NoRecomp (HscStatus, ModIface, ModDetails) +norecompBatch = norecompWorker HscNoRecomp False + +norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) +norecompInteractive = norecompWorker InteractiveNoRecomp True + +norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails) +norecompWorker a isInterp old_iface + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceCheck hsc_env $ + typecheckIface old_iface + dumpIfaceStats hsc_env + return (a, old_iface, new_details) + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: Maybe (Int,Int) -> Bool -> Comp () +oneShotMsg _mb_mod_index recomp + = do hsc_env <- gets compHscEnv + liftIO $ do + if recomp + then return () + else compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + +batchMsg :: Maybe (Int,Int) -> Bool -> Comp () +batchMsg mb_mod_index recomp + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ + (showModuleIndex mb_mod_index ++ + msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) + liftIO $ do + if recomp + then showMsg "Compiling " + else showMsg "Skipping " + + + +-------------------------------------------------------------- +-- FrontEnds +-------------------------------------------------------------- + +hscCoreFrontEnd :: FrontEnd ModGuts +hscCoreFrontEnd = + do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + ------------------- + -- PARSE + ------------------- + inp <- readFile (ms_hspp_file mod_summary) + case parseCore inp 1 of + FailP s + -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) + return Nothing + OkP rdr_module + ------------------- + -- RENAME and TYPECHECK + ------------------- + -> do (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} + tcRnExtCore hsc_env rdr_module + printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs + case maybe_tc_result of + Nothing -> return Nothing + Just mod_guts -> return (Just mod_guts) -- No desugaring to do! + + +hscFileFrontEnd :: FrontEnd ModGuts +hscFileFrontEnd = + do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + ------------------- + -- PARSE + ------------------- + let dflags = hsc_dflags hsc_env + hspp_file = ms_hspp_file mod_summary + hspp_buf = ms_hspp_buf mod_summary + maybe_parsed <- myParseModule dflags hspp_file hspp_buf + case maybe_parsed of + Left err + -> do printBagOfErrors dflags (unitBag err) + return Nothing + Right rdr_module + ------------------- + -- RENAME and TYPECHECK + ------------------- + -> do (tc_msgs, maybe_tc_result) + <- {-# SCC "Typecheck-Rename" #-} + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + printErrorsAndWarnings dflags tc_msgs + case maybe_tc_result of + Nothing + -> return Nothing + Just tc_result + ------------------- + -- DESUGAR + ------------------- + -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} + deSugar hsc_env tc_result + printBagOfWarnings dflags warns + return maybe_ds_result + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +hscSimplify :: ModGuts -> Comp ModGuts +hscSimplify ds_result + = do hsc_env <- gets compHscEnv + liftIO $ do + flat_result <- {-# SCC "Flattening" #-} + flatten hsc_env ds_result + ------------------- + -- SIMPLIFY + ------------------- + simpl_result <- {-# SCC "Core2Core" #-} + core2core hsc_env flat_result + return simpl_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- HACK: we return ModGuts even though we know it's not gonna be used. +-- We do this because the type signature needs to be identical +-- in structure to the type of 'hscNormalIface'. +hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts) +hscSimpleIface ds_result + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + maybe_old_iface <- gets compOldIface + liftIO $ do + details <- mkBootModDetails hsc_env ds_result + (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + mkIface hsc_env maybe_old_iface ds_result details + -- And the answer is ... + dumpIfaceStats hsc_env + return (new_iface, no_change, details, ds_result) + +hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts) +hscNormalIface simpl_result + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + maybe_old_iface <- gets compOldIface + liftIO $ do + ------------------- + -- TIDY + ------------------- + (cg_guts, details) <- {-# SCC "CoreTidy" #-} + tidyProgram hsc_env simpl_result + + ------------------- + -- BUILD THE NEW ModIface and ModDetails + -- and emit external core if necessary + -- This has to happen *after* code gen so that the back-end + -- info has been set. Not yet clear if it matters waiting + -- until after code output + (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + mkIface hsc_env maybe_old_iface simpl_result details + -- Emit external core + emitExternalCore (hsc_dflags hsc_env) cg_guts -- Move this? --Lemmih 03/07/2006 + dumpIfaceStats hsc_env + + ------------------- + -- Return the prepared code. + return (new_iface, no_change, details, cg_guts) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- + +hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) +hscWriteIface (iface, no_change, details, a) + = do mod_summary <- gets compModSummary + liftIO $ do + unless no_change + $ writeIfaceFile (ms_location mod_summary) iface + return (iface, details, a) + +hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) +hscIgnoreIface (iface, no_change, details, a) + = return (iface, details, a) + +-- Don't output any code. +hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails) +hscNothing (iface, details, a) + = return (HscRecomp False, iface, details) + +-- Generate code and return both the new ModIface and the ModDetails. +hscBatch :: (ModIface, ModDetails, CgGuts) -> Comp (HscStatus, ModIface, ModDetails) +hscBatch (iface, details, cgguts) + = do hasStub <- hscCompile cgguts + return (HscRecomp hasStub, iface, details) + +-- Here we don't need the ModIface and ModDetails anymore. +hscOneShot :: (ModIface, ModDetails, CgGuts) -> Comp HscStatus +hscOneShot (_, _, cgguts) + = do hasStub <- hscCompile cgguts + return (HscRecomp hasStub) + +-- Compile to hard-code. +hscCompile :: CgGuts -> Comp Bool +hscCompile cgguts + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_dir_imps = dir_imps, + cg_foreign = foreign_stubs, + cg_home_mods = home_mods, + cg_dep_pkgs = dependencies } = cgguts + dflags = hsc_dflags hsc_env + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm dflags core_binds data_tycons ; + ----------------- Convert to STG ------------------ + (stg_binds, cost_centre_info) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags home_mods this_mod prepd_binds + ------------------ Code generation ------------------ + abstractC <- {-# SCC "CodeGen" #-} + codeGen dflags home_mods this_mod data_tycons + foreign_stubs dir_imps cost_centre_info + stg_binds + ------------------ Code output ----------------------- + (stub_h_exists,stub_c_exists) + <- codeOutput dflags this_mod location foreign_stubs + dependencies abstractC + return stub_c_exists + +hscConst :: b -> a -> Comp b +hscConst b a = return b + +hscInteractive :: (ModIface, ModDetails, CgGuts) + -> Comp (InteractiveStatus, ModIface, ModDetails) +hscInteractive (iface, details, cgguts) +#ifdef GHCI + = do hsc_env <- gets compHscEnv + mod_summary <- gets compModSummary + liftIO $ do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs } = cgguts + dflags = hsc_dflags hsc_env + location = ms_location mod_summary + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm dflags core_binds data_tycons ; + ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen dflags prepd_binds data_tycons + ------------------ Create f-x-dynamic C-side stuff --- + (istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (InteractiveRecomp istub_c_exists comp_bc, iface, details) +#else + = panic "GHC not compiled with interpreter" +#endif + +------------------------------ + +hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked) +hscFileCheck hsc_env mod_summary = do { + ------------------- + -- PARSE + ------------------- + ; let dflags = hsc_dflags hsc_env + hspp_file = ms_hspp_file mod_summary + hspp_buf = ms_hspp_buf mod_summary + + ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf + + ; case maybe_parsed of { + Left err -> do { printBagOfErrors dflags (unitBag err) + ; return Nothing } ; + Right rdr_module -> do { + + ------------------- + -- RENAME and TYPECHECK + ------------------- + (tc_msgs, maybe_tc_result) + <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env (ms_hsc_src mod_summary) + True{-save renamed syntax-} + rdr_module + + ; printErrorsAndWarnings dflags tc_msgs + ; case maybe_tc_result of { + Nothing -> return (Just (HscChecked rdr_module Nothing Nothing)); + Just tc_result -> do + let md = ModDetails { + md_types = tcg_type_env tc_result, + md_exports = tcg_exports tc_result, + md_insts = tcg_insts tc_result, + md_rules = [panic "no rules"] } + -- Rules are CoreRules, not the + -- RuleDecls we get out of the typechecker + rnInfo = do decl <- tcg_rn_decls tc_result + imports <- tcg_rn_imports tc_result + let exports = tcg_rn_exports tc_result + return (decl,imports,exports) + return (Just (HscChecked rdr_module + rnInfo + (Just (tcg_binds tc_result, + tcg_rdr_env tc_result, + md)))) + }}}} + + +hscCmmFile :: DynFlags -> FilePath -> IO Bool +hscCmmFile dflags filename = do + maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename + case maybe_cmm of + Nothing -> return False + Just cmm -> do + codeOutput dflags no_mod no_loc NoStubs [] [cmm] + return True + where + no_mod = panic "hscCmmFile: no_mod" + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCmmFile: no hi file", + ml_obj_file = panic "hscCmmFile: no obj file" } + + +myParseModule dflags src_filename maybe_src_buf + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP parseModule (mkPState buf loc dflags) of { + + PFailed span err -> return (Left (mkPlainErrMsg span err)); + + POk _ rdr_module -> do { + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} + + +myCoreToStg dflags home_mods this_mod prepd_binds + = do + stg_binds <- {-# SCC "Core2Stg" #-} + coreToStg home_mods prepd_binds + + (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} + stg2stg dflags home_mods this_mod stg_binds + + return (stg_binds2, cost_centre_info) +\end{code} + + +%************************************************************************ +%* * +\subsection{Compiling a do-statement} +%* * +%************************************************************************ + +When the UnlinkedBCOExpr is linked you get an HValue of type + IO [HValue] +When you run it you get a list of HValues that should be +the same length as the list of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ v -> return [v] + [NB: result not printed] bindings: [it] + + + expr (of non-IO type, + result showable) ==> let v = expr in print v >> return [v] + bindings: [it] + + expr (of non-IO type, + result not showable) ==> error + +\begin{code} +#ifdef GHCI +hscStmt -- Compile a stmt all the way to an HValue, but don't run it + :: HscEnv + -> String -- The statement + -> IO (Maybe (HscEnv, [Name], HValue)) + +hscStmt hsc_env stmt + = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt + ; case maybe_stmt of { + Nothing -> return Nothing ; -- Parse error + Just Nothing -> return Nothing ; -- Empty line + Just (Just parsed_stmt) -> do { -- The real stuff + + -- Rename and typecheck it + let icontext = hsc_IC hsc_env + ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt + + ; case maybe_tc_result of { + Nothing -> return Nothing ; + Just (new_ic, bound_names, tc_expr) -> do { + + -- Then desugar, code gen, and link it + ; hval <- compileExpr hsc_env iNTERACTIVE + (ic_rn_gbl_env new_ic) + (ic_type_env new_ic) + tc_expr + + ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval)) + }}}}} + +hscTcExpr -- Typecheck an expression (but don't run it) + :: HscEnv + -> String -- The expression + -> IO (Maybe Type) + +hscTcExpr hsc_env expr + = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr + ; let icontext = hsc_IC hsc_env + ; case maybe_stmt of { + Nothing -> return Nothing ; -- Parse error + Just (Just (L _ (ExprStmt expr _ _))) + -> tcRnExpr hsc_env icontext expr ; + Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; + return Nothing } ; + } } + +hscKcType -- Find the kind of a type + :: HscEnv + -> String -- The type + -> IO (Maybe Kind) + +hscKcType hsc_env str + = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str + ; let icontext = hsc_IC hsc_env + ; case maybe_type of { + Just ty -> tcRnType hsc_env icontext ty ; + Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ; + return Nothing } ; + Nothing -> return Nothing } } +#endif +\end{code} + +\begin{code} +#ifdef GHCI +hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName))) +hscParseStmt = hscParseThing parseStmt + +hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName)) +hscParseType = hscParseThing parseType +#endif + +hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName)) +hscParseIdentifier = hscParseThing parseIdentifier + +hscParseThing :: Outputable thing + => Lexer.P thing + -> DynFlags -> String + -> IO (Maybe thing) + -- Nothing => Parse error (message already printed) + -- Just x => success +hscParseThing parser dflags str + = showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + buf <- stringToStringBuffer str + + let loc = mkSrcLoc FSLIT("<interactive>") 1 0 + + case unP parser (mkPState buf loc dflags) of { + + PFailed span err -> do { printError span err; + return Nothing }; + + POk _ thing -> do { + + --ToDo: can't free the string buffer until we've finished this + -- compilation sweep and all the identifiers have gone away. + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing); + return (Just thing) + }} +\end{code} + +%************************************************************************ +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%************************************************************************ + +\begin{code} +#ifdef GHCI +compileExpr :: HscEnv + -> Module -> GlobalRdrEnv -> TypeEnv + -> LHsExpr Id + -> IO HValue + +compileExpr hsc_env this_mod rdr_env type_env tc_expr + = do { let { dflags = hsc_dflags hsc_env ; + lint_on = dopt Opt_DoCoreLinting dflags } + + -- Desugar it + ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr + + -- Flatten it + ; flat_expr <- flattenExpr hsc_env ds_expr + + -- Simplify it + ; simpl_expr <- simplifyExpr dflags flat_expr + + -- Tidy it (temporary, until coreSat does cloning) + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + -- Prepare for codegen + ; prepd_expr <- corePrepExpr dflags tidy_expr + + -- Lint if necessary + -- ToDo: improve SrcLoc + ; if lint_on then + case lintUnfolding noSrcLoc [] prepd_expr of + Just err -> pprPanic "compileExpr" err + Nothing -> return () + else + return () + + -- Convert to BCOs + ; bcos <- coreExprToBCOs dflags prepd_expr + + -- link it + ; hval <- linkExpr hsc_env bcos + + ; return hval + } +#endif +\end{code} + + +%************************************************************************ +%* * + Statistics on reading interfaces +%* * +%************************************************************************ + +\begin{code} +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env + = do { eps <- readIORef (hsc_EPS hsc_env) + ; dumpIfSet (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) } + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags +\end{code} + +%************************************************************************ +%* * + Progress Messages: Module i of n +%* * +%************************************************************************ + +\begin{code} +showModuleIndex Nothing = "" +showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str +\end{code} + diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs new file mode 100644 index 0000000000..750744af44 --- /dev/null +++ b/compiler/main/HscStats.lhs @@ -0,0 +1,160 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +% +\section[GHC_Stats]{Statistics for per-module compilations} + +\begin{code} +module HscStats ( ppSourceStats ) where + +#include "HsVersions.h" + +import HsSyn +import Outputable +import SrcLoc ( unLoc, Located(..) ) +import Char ( isSpace ) +import Bag ( bagToList ) +import Util ( count ) +\end{code} + +%************************************************************************ +%* * +\subsection{Statistics} +%* * +%************************************************************************ + +\begin{code} +ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", import_no), + (" ImpQual ", import_qual), + (" ImpAs ", import_as), + (" ImpAll ", import_all), + (" ImpPartial ", import_partial), + (" ImpHiding ", import_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("TypeSigs ", bind_tys), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), +-- ("SpecialisedData ", data_specs), +-- ("SpecialisedInsts ", inst_specs), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (str, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines) + = count_sigs [d | SigD d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD d <- decls] + (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls + + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just es -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; other -> 0 } + + (val_bind_ds, fn_bind_ds) + = foldr add2 (0,0) (map count_bind val_decls) + + (import_no, import_qual, import_as, import_all, import_partial, import_hiding) + = foldr add6 (0,0,0,0,0,0) (map import_info imports) + (data_constrs, data_derivs) + = foldr add2 (0,0) (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = foldr add2 (0,0) (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines) + = foldr add3 (0,0,0) (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat n) }) = (1,0) + count_bind (PatBind {}) = (0,1) + count_bind (FunBind {}) = (0,1) + + count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) + + sig_info (FixSig _) = (1,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0) + sig_info (InlineSig _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) + + import_info (L _ (ImportDecl _ _ qual as spec)) + = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) + qual_info False = 0 + qual_info True = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,1) + + data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) + = (length cs, case derivs of Nothing -> 0 + Just ds -> length ds) + data_info other = (0,0) + + class_info decl@(ClassDecl {}) + = case count_sigs (map unLoc (tcdSigs decl)) of + (_,classops,_,_) -> + (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) + class_info other = (0,0) + + inst_info (InstDecl _ inst_meths inst_sigs) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is) -> + (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is) + + addpr :: (Int,Int) -> Int + add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) + add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int) + add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) + add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) + + addpr (x,y) = x+y + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) + add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) + add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) +\end{code} + + + + + + + + + diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs new file mode 100644 index 0000000000..ee5438b319 --- /dev/null +++ b/compiler/main/HscTypes.lhs @@ -0,0 +1,1083 @@ + +% (c) The University of Glasgow, 2000 +% +\section[HscTypes]{Types for the per-module compiler} + +\begin{code} +module HscTypes ( + -- * Sessions and compilation state + Session(..), HscEnv(..), hscEPS, + FinderCache, FinderCacheEntry, + Target(..), TargetId(..), pprTarget, pprTargetId, + ModuleGraph, emptyMG, + + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..), + + ModSummary(..), showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + + HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases + + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + hptInstances, hptRules, + + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIface, lookupIfaceByModule, emptyModIface, + + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, unQualInScope, + + ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, + emptyIfaceDepCache, + + Deprecs(..), IfaceDeprecs, + + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + implicitTyThings, + + TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, + TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, + extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, + typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, + + WhetherHasOrphans, IsBootInterface, Usage(..), + Dependencies(..), noDependencies, + NameCache(..), OrigNameCache, OrigIParamCache, + Avails, availsToNameSet, availName, availNames, + GenAvailInfo(..), AvailInfo, RdrAvailInfo, + IfaceExport, + + Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, + + PackageInstEnv, PackageRuleBase, + + -- Linker stuff + Linkable(..), isObjectLinkable, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import ByteCodeAsm ( CompiledByteCode ) +#endif + +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv, + GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule ) +import NameEnv +import NameSet +import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, + extendOccEnv ) +import Module +import InstEnv ( InstEnv, Instance ) +import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) +import Id ( Id ) +import Type ( TyThing(..) ) + +import Class ( Class, classSelIds, classTyCon ) +import TyCon ( TyCon, tyConSelIds, tyConDataCons ) +import DataCon ( dataConImplicitIds ) +import PrelNames ( gHC_PRIM ) +import Packages ( PackageIdH, PackageId, PackageConfig, HomeModules ) +import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) +import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) +import BasicTypes ( Version, initialVersion, IPName, + Fixity, defaultFixity, DeprecTxt ) + +import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) + +import FiniteMap ( FiniteMap ) +import CoreSyn ( CoreRule ) +import Maybes ( orElse, expectJust, expectJust ) +import Outputable +import SrcLoc ( SrcSpan, Located ) +import UniqSupply ( UniqSupply ) +import FastString ( FastString ) + +import DATA_IOREF ( IORef, readIORef ) +import StringBuffer ( StringBuffer ) +import Time ( ClockTime ) +\end{code} + + +%************************************************************************ +%* * +\subsection{Compilation environment} +%* * +%************************************************************************ + + +\begin{code} +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +newtype Session = Session (IORef HscEnv) +\end{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 +code (after preprocessing) to either C, assembly or C--. Things like +the module graph don't change during a single compilation. + +Historical note: "hsc" used to be the name of the compiler binary, +when there was a separate driver and compiler. To compile a single +module, the driver would invoke hsc on the source code... so nowadays +we think of hsc as the layer of the compiler that deals with compiling +a single module. + +\begin{code} +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- The dynamic flag settings + + hsc_targets :: [Target], + -- The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- The module graph of the current session + + hsc_IC :: InteractiveContext, + -- The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- The home package table describes already-compiled + -- home-packge modules, *excluding* the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as "external-package" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loadeded into the external-package table.) + -- + -- hsc_HPT is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by --make + -- but not actually below the current module in the dependency + -- graph. (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- These are side-effected by compiling to reflect + -- sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache) + -- The finder's cache. This caches the location of modules, + -- so we don't have to search the filesystem multiple times. + } + +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target = Target TargetId (Maybe (StringBuffer,ClockTime)) + +data TargetId + = TargetModule Module + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +pprTarget :: Target -> SDoc +pprTarget (Target id _) = pprTargetId id + +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +type FinderCache = ModuleEnv FinderCacheEntry +type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) + -- The finder's cache (see module Finder) + +type HomePackageTable = ModuleEnv HomeModInfo + -- Domain = modules in the home package +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +emptyHomePackageTable = emptyModuleEnv +emptyPackageIfaceTable = emptyModuleEnv + +data HomeModInfo + = HomeModInfo { hm_iface :: !ModIface, + hm_details :: !ModDetails, + hm_linkable :: !(Maybe Linkable) } + -- hm_linkable might be Nothing if: + -- a) this is an .hs-boot module + -- b) temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- after a complete compilation (GHC.load), all hm_linkable + -- fields in the HPT will be Just. + -- + -- When re-linking a module (hscNoRecomp), we construct + -- the HomModInfo by building a new ModDetails from the + -- old ModIface (only). +\end{code} + +Simple lookups in the symbol table. + +\begin{code} +lookupIface :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIface hpt pit mod + = case lookupModuleEnv hpt mod of + Just mod_info -> Just (hm_iface mod_info) + Nothing -> lookupModuleEnv pit mod + +lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIfaceByModule hpt pit mod + = case lookupModuleEnv hpt mod of + Just mod_info -> Just (hm_iface mod_info) + Nothing -> lookupModuleEnv pit mod +\end{code} + + +\begin{code} +hptInstances :: HscEnv -> (Module -> Bool) -> [Instance] +-- Find all the instance declarations that are in modules imported +-- by this one, directly or indirectly, and are in the Home Package Table +-- This ensures that we don't see instances from modules --make compiled +-- before this one, but which are not below this one +hptInstances hsc_env want_this_module + = [ ispec + | mod_info <- moduleEnvElts (hsc_HPT hsc_env) + , want_this_module (mi_module (hm_iface mod_info)) + , ispec <- md_insts (hm_details mod_info) ] + +hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [CoreRule] +-- Get rules from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptRules hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + | otherwise + = let + hpt = hsc_HPT hsc_env + in + [ rule + | -- Find each non-hi-boot module below me + (mod, False) <- deps + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus + -- filter: + , mod /= gHC_PRIM + + -- Look it up in the HPT + , let mod_info = case lookupModuleEnv hpt mod of + Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps) + Just x -> x + + -- And get its dfuns + , rule <- md_rules (hm_details mod_info) ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Symbol tables and Module details} +%* * +%************************************************************************ + +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 +linking; it is the "linked" form of the mi_decls field.) + +When we *read* an interface file, we also construct a @ModIface@ from it, +except that the mi_decls part is empty; when reading we consolidate +the declarations into a single indexed map in the @PersistentRenamerState@. + +\begin{code} +data ModIface + = ModIface { + mi_package :: !PackageIdH, -- Which package the module comes from + mi_module :: !Module, + mi_mod_vers :: !Version, -- Module version: changes when anything changes + + mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans + mi_boot :: !IsBootInterface, -- Read from an hi-boot file? + + mi_deps :: Dependencies, + -- This is consulted for directly-imported modules, + -- but not for anything else (hence lazy) + + -- Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the version of this module) + mi_usages :: [Usage], + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + -- Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + mi_exports :: ![IfaceExport], + mi_exp_vers :: !Version, -- Version number of export list + + -- Fixities + mi_fixities :: [(OccName,Fixity)], + -- NOT STRICT! we read this field lazily from the interface file + + -- Deprecations + mi_deprecs :: IfaceDeprecs, + -- NOT STRICT! we read this field lazily from the interface file + + -- Type, class and variable declarations + -- The version of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the version of the parent class/tycon changes + mi_decls :: [(Version,IfaceDecl)], -- Sorted + + mi_globals :: !(Maybe GlobalRdrEnv), + -- Binds all the things defined at the top level in + -- the *original source* code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains Nothing). + -- + -- Strictly speaking this field should live in the + -- HomeModInfo, but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceInst], -- Sorted + mi_rules :: [IfaceRule], -- Sorted + mi_rule_vers :: !Version, -- Version number for rules and instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs + mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities + mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + -- The Nothing in mi_ver_fn means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt the old interface + } + +-- Should be able to construct ModDetails from mi_decls in ModIface +data ModDetails + = ModDetails { + -- The next three fields are created by the typechecker + md_exports :: NameSet, + md_types :: !TypeEnv, + md_insts :: ![Instance], -- Dfun-ids for the instances in this module + md_rules :: ![CoreRule] -- Domain may include Ids from other modules + } + +emptyModDetails = ModDetails { md_types = emptyTypeEnv, + md_exports = emptyNameSet, + md_insts = [], + md_rules = [] } + +-- A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a ModIface and +-- ModDetails are extracted and the ModGuts is dicarded. + +data ModGuts + = ModGuts { + mg_module :: !Module, + mg_boot :: IsBootInterface, -- Whether it's an hs-boot module + mg_exports :: !NameSet, -- What it exports + mg_deps :: !Dependencies, -- What is below it, directly or otherwise + mg_home_mods :: !HomeModules, -- For calling isHomeModule etc. + mg_dir_imps :: ![Module], -- Directly-imported modules; used to + -- generate initialisation code + mg_usages :: ![Usage], -- Version info for what it needed + + mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment + mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + + mg_types :: !TypeEnv, + mg_insts :: ![Instance], -- Instances + mg_rules :: ![CoreRule], -- Rules from this module + mg_binds :: ![CoreBind], -- Bindings for this module + mg_foreign :: !ForeignStubs + } + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) +data CgGuts + = CgGuts { + cg_module :: !Module, + + cg_tycons :: [TyCon], + -- Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: [CoreBind], + -- The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data construtor wrappers. But *not* + -- data constructor workers; reason: we we regard them + -- as part of the code-gen of tycons + + cg_dir_imps :: ![Module], + -- Directly-imported modules; used to generate + -- initialisation code + + cg_foreign :: !ForeignStubs, + cg_home_mods :: !HomeModules, -- for calling isHomeModule etc. + cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen + } + +----------------------------------- +data ModImports + = ModImports { + imp_direct :: ![(Module,Bool)], -- Explicitly-imported modules + -- Boolean is true if we imported the whole + -- module (apart, perhaps, from hiding some) + imp_pkg_mods :: !ModuleSet, -- Non-home-package modules on which we depend, + -- directly or indirectly + imp_home_names :: !NameSet -- Home package things on which we depend, + -- directly or indirectly + } + +----------------------------------- +data ForeignStubs = NoStubs + | ForeignStubs + SDoc -- Header file prototypes for + -- "foreign exported" functions + SDoc -- C stubs to use when calling + -- "foreign exported" functions + [FastString] -- Headers that need to be included + -- into C code generated for this module + [Id] -- Foreign-exported binders + -- we have to generate code to register these + +\end{code} + +\begin{code} +emptyModIface :: PackageIdH -> Module -> ModIface +emptyModIface pkg mod + = ModIface { mi_package = pkg, + mi_module = mod, + mi_mod_vers = initialVersion, + mi_orphan = False, + mi_boot = False, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_exp_vers = initialVersion, + mi_fixities = [], + mi_deprecs = NoDeprecs, + mi_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_rule_vers = initialVersion, + mi_dep_fn = emptyIfaceDepCache, + mi_fix_fn = emptyIfaceFixCache, + mi_ver_fn = emptyIfaceVerCache + } +\end{code} + + +%************************************************************************ +%* * +\subsection{The interactive context} +%* * +%************************************************************************ + +\begin{code} +data InteractiveContext + = InteractiveContext { + ic_toplev_scope :: [Module], -- Include the "top-level" scope of + -- these modules + + ic_exports :: [Module], -- Include just the exports of these + -- modules + + ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from + -- ic_toplev_scope and ic_exports + + ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound + -- during interaction + + ic_type_env :: TypeEnv -- Ditto for types + } + +emptyInteractiveContext + = InteractiveContext { ic_toplev_scope = [], + ic_exports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_rn_local_env = emptyLocalRdrEnv, + ic_type_env = emptyTypeEnv } + +icPrintUnqual :: InteractiveContext -> PrintUnqualified +icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) +\end{code} + +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> PrintUnqualified +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- [Out of date] Also checks for built-in syntax, which is always 'in scope' +unQualInScope env mod occ + = case lookupGRE_RdrName (mkRdrUnqual occ) env of + [gre] -> nameModule (gre_name gre) == mod + other -> False +\end{code} + + +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +\begin{code} +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId id) = [] + + -- For type constructors, add the data cons (and their extras), + -- and the selectors and generic-programming Ids too + -- + -- Newtypes don't have a worker Id, so don't generate that? +implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ + concatMap (extras_plus . ADataCon) (tyConDataCons tc) + + -- For classes, add the class TyCon too (and its extras) + -- and the class selector Ids +implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + extras_plus (ATyCon (classTyCon cl)) + + + -- For data cons add the worker and wrapper (if any) +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + +extras_plus thing = thing : implicitTyThings thing + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] +\end{code} + +%************************************************************************ +%* * + TypeEnv +%* * +%************************************************************************ + +\begin{code} +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvClasses :: TypeEnv -> [Class] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvIds :: TypeEnv -> [Id] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl extendTypeEnv env things +\end{code} + +\begin{code} +lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing +lookupType hpt pte name + = case lookupModuleEnv hpt (nameModule name) of + Just details -> lookupNameEnv (md_types (hm_details details)) name + Nothing -> lookupNameEnv pte name +\end{code} + + +\begin{code} +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +tyThingClass (AClass cls) = cls +tyThingClass other = pprPanic "tyThingClass" (ppr other) + +tyThingDataCon (ADataCon dc) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +tyThingId (AnId id) = id +tyThingId other = pprPanic "tyThingId" (ppr other) +\end{code} + +%************************************************************************ +%* * +\subsection{Auxiliary types} +%* * +%************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere + +\begin{code} +mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl add emptyOccEnv pairs + add env (v,d) = extendOccEnv env (ifName d) v + +emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache occ = Nothing + +------------------ Deprecations ------------------------- +data Deprecs a + = NoDeprecs + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome a -- Some specific things deprecated + deriving( Eq ) + +type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] +type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) + -- Keep the OccName so we can flatten the NameEnv to + -- get an IfaceDeprecs from a Deprecations + -- Only an OccName is needed, because a deprecation always + -- applies to things defined in the module in which the + -- deprecation appears. + +mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt +mkIfaceDepCache NoDeprecs = \n -> Nothing +mkIfaceDepCache (DeprecAll t) = \n -> Just t +mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName + +emptyIfaceDepCache :: Name -> Maybe DeprecTxt +emptyIfaceDepCache n = Nothing + +lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt +lookupDeprec NoDeprecs name = Nothing +lookupDeprec (DeprecAll txt) name = Just txt +lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of + Just (_, txt) -> Just txt + Nothing -> Nothing + +plusDeprecs :: Deprecations -> Deprecations -> Deprecations +plusDeprecs d NoDeprecs = d +plusDeprecs NoDeprecs d = d +plusDeprecs d (DeprecAll t) = DeprecAll t +plusDeprecs (DeprecAll t) d = DeprecAll t +plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) +\end{code} + + +\begin{code} +type Avails = [AvailInfo] +type AvailInfo = GenAvailInfo Name +type RdrAvailInfo = GenAvailInfo OccName + +data GenAvailInfo name = Avail name -- An ordinary identifier + | AvailTC name -- The name of the type or class + [name] -- The available pieces of type/class. + -- NB: If the type or class is itself + -- to be in scope, it must be in this list. + -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving( Eq ) + -- Equality used when deciding if the interface has changed + +type IfaceExport = (Module, [GenAvailInfo OccName]) + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldl add emptyNameSet avails + where + add set avail = addListToNameSet set (availNames avail) + +availName :: GenAvailInfo name -> name +availName (Avail n) = n +availName (AvailTC n _) = n + +availNames :: GenAvailInfo name -> [name] +availNames (Avail n) = [n] +availNames (AvailTC n ns) = ns + +instance Outputable n => Outputable (GenAvailInfo n) where + ppr = pprAvail + +pprAvail :: Outputable n => GenAvailInfo n -> SDoc +pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of + [] -> empty + ns' -> braces (hsep (punctuate comma (map ppr ns'))) + +pprAvail (Avail n) = ppr n +\end{code} + +\begin{code} +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n `orElse` defaultFixity + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Fixity +emptyIfaceFixCache n = defaultFixity + +-- This fixity environment is for source code only +type FixityEnv = NameEnv FixItem + +-- We keep the OccName in the range so that we can generate an interface from it +data FixItem = FixItem OccName Fixity SrcSpan + +instance Outputable FixItem where + ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix _) -> fix + Nothing -> defaultFixity +\end{code} + + +%************************************************************************ +%* * +\subsection{WhatsImported} +%* * +%************************************************************************ + +\begin{code} +type WhetherHasOrphans = Bool + -- An "orphan" is + -- * an instance decl in a module other than the defn module for + -- one of the tycons or classes in the instance head + -- * a transformation rule in a module other than the one defining + -- the function in the head of the rule. + +type IsBootInterface = Bool + +-- Dependency info about modules and packages below this one +-- in the import hierarchy. See TcRnTypes.ImportAvails for details. +-- +-- Invariant: the dependencies of a module M never includes M +-- Invariant: the lists are unordered, with no duplicates +data Dependencies + = Deps { dep_mods :: [(Module,IsBootInterface)], -- Home-package module dependencies + dep_pkgs :: [PackageId], -- External package dependencies + dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) + deriving( Eq ) + -- Equality used only for old/new comparison in MkIface.addVersionInfo + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] + +data Usage + = Usage { usg_name :: Module, -- Name of the module + usg_mod :: Version, -- Module version + usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) + } deriving( Eq ) + -- This type doesn't let you say "I imported f but none of the rules in + -- the module". If you use anything in the module you get its rule version + -- So if the rules change, you'll recompile, even if you don't use them. + -- This is easy to implement, and it's safer: you might not have used the rules last + -- time round, but if someone has added a new rule you might need it this time + + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash in the + -- importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists +\end{code} + + +%************************************************************************ +%* * + The External Package State +%* * +%************************************************************************ + +\begin{code} +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv + +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleEnv (Module, IsBootInterface)), + -- In OneShot mode (only), home-package modules accumulate in the + -- external package state, and are sucked in lazily. + -- For these home-pkg modules (only) we need to record which are + -- boot modules. We set this field after loading all the + -- explicitly-imported interfaces, but before doing anything else + -- + -- The Module part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from TcRnTypes.ImportAvails.imp_dep_mods + + eps_PIT :: !PackageIfaceTable, + -- The ModuleIFaces for modules in external packages + -- whose interfaces we have opened + -- The declarations in these interface files are held in + -- eps_decls, eps_inst_env, eps_rules (below), not in the + -- mi_decls fields of the iPIT. + -- What _is_ in the iPIT is: + -- * The Module + -- * Version info + -- * Its exports + -- * Fixities + -- * Deprecations + + eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules + + eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from + -- all the external-package modules + eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + + eps_stats :: !EpsStats + } + +-- "In" means read from iface files +-- "Out" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } +\end{code} + +The NameCache makes sure that there is just one Unique assigned for +each original name; i.e. (module-name, occ-name) pair. The Name is +always stored as a Global, and has the SrcLoc of its binding location. +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. + +\begin{code} +data NameCache + = NameCache { nsUniqs :: UniqSupply, + -- Supply of uniques + nsNames :: OrigNameCache, + -- Ensures that one original name gets one unique + nsIPs :: OrigIParamCache + -- Ensures that one implicit parameter name gets one unique + } + +type OrigNameCache = ModuleEnv (OccEnv Name) +type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) +\end{code} + + + +%************************************************************************ +%* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +%* * +%************************************************************************ + +A ModuleGraph contains all the nodes from the home package (only). +There will be a node for each source module, plus a node for each hi-boot +module. + +\begin{code} +type ModuleGraph = [ModSummary] -- The module graph, + -- NOT NECESSARILY IN TOPOLOGICAL ORDER + +emptyMG :: ModuleGraph +emptyMG = [] + +-- The nodes of the module graph are +-- EITHER a regular Haskell source module +-- OR a hi-boot source module + +data ModSummary + = ModSummary { + ms_mod :: Module, -- Name of the module + ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core + ms_location :: ModLocation, -- Location + ms_hs_date :: ClockTime, -- Timestamp of source file + ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe + ms_srcimps :: [Located Module], -- Source imports + ms_imps :: [Located Module], -- Non-source imports + ms_hspp_file :: FilePath, -- Filename of preprocessed source. + ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE + -- and LANGUAGE pragmas. + ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. + } + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +isBootSummary :: ModSummary -> Bool +isBootSummary ms = isHsBoot (ms_hsc_src ms) + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: HscTarget -> Bool -> ModSummary -> String +showModMsg target recomp mod_summary + = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), + char '(', text (msHsFilePath mod_summary) <> comma, + case target of + HscInterpreted | recomp + -> text "interpreted" + HscNothing -> text "nothing" + _other -> text (msObjFilePath mod_summary), + char ')']) + where + mod = ms_mod mod_summary + mod_str = moduleString mod ++ hscSourceString (ms_hsc_src mod_summary) +\end{code} + + +%************************************************************************ +%* * +\subsection{Linkable stuff} +%* * +%************************************************************************ + +This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler + +\begin{code} +data Linkable = LM { + linkableTime :: ClockTime, -- Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- Should be Module, but see below + linkableUnlinked :: [Unlinked] + } + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +------------------------------------------- +data Unlinked + = DotO FilePath + | DotA FilePath + | DotDLL FilePath + | BCOs CompiledByteCode + +#ifndef GHCI +data CompiledByteCode = NoByteCode +#endif + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path +#ifdef GHCI + ppr (BCOs bcos) = text "BCOs" <+> ppr bcos +#else + ppr (BCOs bcos) = text "No byte code" +#endif + +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +isInterpretable = not . isObject + +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn + +byteCodeOfObject (BCOs bc) = bc +\end{code} + + + diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs new file mode 100644 index 0000000000..ec5a116894 --- /dev/null +++ b/compiler/main/Main.hs @@ -0,0 +1,476 @@ +{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} +----------------------------------------------------------------------------- +-- +-- GHC Driver program +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module Main (main) where + +#include "HsVersions.h" + +-- The official GHC API +import qualified GHC +import GHC ( Session, DynFlags(..), GhcMode(..), HscTarget(..), + LoadHowMuch(..), dopt, DynFlag(..) ) +import CmdLineParser + +-- Implementations of the various modes (--show-iface, mkdependHS. etc.) +import MkIface ( showIface ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) +import SysTools ( getTopDir, getUsageMsgPaths ) +#ifdef GHCI +import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) +#endif + +-- Various other random stuff that we need +import Config ( cProjectVersion, cBooterVersion, cProjectName ) +import Packages ( dumpPackages, initPackages ) +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) +import StaticFlags ( staticFlags, v_Ld_inputs, parseStaticFlags ) +import DynFlags ( defaultDynFlags ) +import BasicTypes ( failed ) +import ErrUtils ( Message, debugTraceMsg, putMsg ) +import FastString ( getFastStringTable, isZEncoded, hasZEncoding ) +import Outputable +import Util +import Panic + +-- Standard Haskell libraries +import EXCEPTION ( throwDyn ) +import IO +import Directory ( doesDirectoryExist ) +import System ( getArgs, exitWith, ExitCode(..) ) +import Monad +import List +import Maybe + +----------------------------------------------------------------------------- +-- ToDo: + +-- time commands when run with -v +-- user ways +-- Win32 support: proper signal handling +-- reading the package configuration file is too slow +-- -K<size> + +----------------------------------------------------------------------------- +-- GHC's command-line interface + +main = + GHC.defaultErrorHandler defaultDynFlags $ do + + argv0 <- getArgs + argv1 <- parseStaticFlags =<< GHC.initFromArgs argv0 + + -- 2. Parse the "mode" flags (--make, --interactive etc.) + (cli_mode, argv2) <- parseModeFlags argv1 + + let mode = case cli_mode of + DoInteractive -> Interactive + DoEval _ -> Interactive + DoMake -> BatchCompile + DoMkDependHS -> MkDepend + _ -> OneShot + + -- start our GHC session + session <- GHC.newSession mode + + dflags0 <- GHC.getSessionDynFlags session + + -- set the default HscTarget. The HscTarget can be further + -- adjusted on a module by module basis, using only the -fvia-C and + -- -fasm flags. If the default HscTarget is not HscC or HscAsm, + -- -fvia-C and -fasm have no effect. + let lang = case cli_mode of + DoInteractive -> HscInterpreted + DoEval _ -> HscInterpreted + _other -> hscTarget dflags0 + + let dflags1 = dflags0{ ghcMode = mode, + hscTarget = lang, + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case cli_mode of + DoEval _ -> 0 + _other -> 1 + } + + -- The rest of the arguments are "dynamic" + -- Leftover ones are presumably files + (dflags2, fileish_args) <- GHC.parseDynamicFlags dflags1 argv2 + + -- make sure we clean up after ourselves + GHC.defaultCleanupHandler dflags2 $ do + + -- Display banner + showBanner cli_mode dflags2 + + -- Read the package config(s), and process the package-related + -- command-line flags + dflags <- initPackages dflags2 + + -- we've finished manipulating the DynFlags, update the session + GHC.setSessionDynFlags session dflags + + let + -- To simplify the handling of filepaths, we normalise all filepaths right + -- away - e.g., for win32 platforms, backslashes are converted + -- into forward slashes. + normal_fileish_paths = map normalisePath fileish_args + (srcs, objs) = partition_args normal_fileish_paths [] [] + + -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on + -- the command-line. + mapM_ (consIORef v_Ld_inputs) (reverse objs) + + ---------------- Display configuration ----------- + when (verbosity dflags >= 4) $ + dumpPackages dflags + + when (verbosity dflags >= 3) $ do + hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + + ---------------- Final sanity checking ----------- + checkOptions cli_mode dflags srcs objs + + ---------------- Do the business ----------- + case cli_mode of + ShowUsage -> showGhcUsage cli_mode + PrintLibdir -> do d <- getTopDir; putStrLn d + ShowVersion -> showVersion + ShowNumVersion -> putStrLn cProjectVersion + ShowInterface f -> showIface f + DoMake -> doMake session srcs + DoMkDependHS -> doMkDependHS session (map fst srcs) + StopBefore p -> oneShot dflags p srcs + DoInteractive -> interactiveUI session srcs Nothing + DoEval expr -> interactiveUI session srcs (Just expr) + + dumpFinalStats dflags + exitWith ExitSuccess + +#ifndef GHCI +interactiveUI _ _ _ = + throwDyn (CmdLineError "not built for interactive use") +#endif + +-- ----------------------------------------------------------------------------- +-- Splitting arguments into source files and object files. This is where we +-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source +-- file indicating the phase specified by the -x option in force, if any. + +partition_args [] srcs objs = (reverse srcs, reverse objs) +partition_args ("-x":suff:args) srcs objs + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) +partition_args (arg:args) srcs objs + | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs + | otherwise = partition_args args srcs (arg:objs) + + {- + We split out the object files (.o, .dll) and add them + to v_Ld_inputs for use by the linker. + + The following things should be considered compilation manager inputs: + + - haskell source files (strings ending in .hs, .lhs or other + haskellish extension), + + - module names (not forgetting hierarchical module names), + + - and finally we consider everything not containing a '.' to be + a comp manager input, as shorthand for a .hs or .lhs filename. + + Everything else is considered to be a linker object, and passed + straight through to the linker. + -} +looks_like_an_input m = isSourceFilename m + || looksLikeModuleName m + || '.' `notElem` m + +-- ----------------------------------------------------------------------------- +-- Option sanity checks + +checkOptions :: CmdLineMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () + -- Final sanity checking before kicking off a compilation (pipeline). +checkOptions cli_mode dflags srcs objs = do + -- Complain about any unknown flags + let unknown_opts = [ f | (f@('-':_), _) <- srcs ] + when (notNull unknown_opts) (unknownFlagsErr unknown_opts) + + -- -prof and --interactive are not a good combination + when (notNull (wayNames dflags) && isInterpretiveMode cli_mode) $ + do throwDyn (UsageError + "--interactive can't be used with -prof, -ticky, -unreg or -smp.") + -- -ohi sanity check + if (isJust (outputHi dflags) && + (isCompManagerMode cli_mode || srcs `lengthExceeds` 1)) + then throwDyn (UsageError "-ohi can only be used when compiling a single source file") + else do + + -- -o sanity checking + if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) + && not (isLinkMode cli_mode)) + then throwDyn (UsageError "can't apply -o to multiple source files") + else do + + -- Check that there are some input files + -- (except in the interactive case) + if null srcs && null objs && needsInputsMode cli_mode + then throwDyn (UsageError "no input files") + else do + + -- Verify that output files point somewhere sensible. + verifyOutputFiles dflags + + +-- Compiler output options + +-- called to verify that the output files & directories +-- point somewhere valid. +-- +-- The assumption is that the directory portion of these output +-- options will have to exist by the time 'verifyOutputFiles' +-- is invoked. +-- +verifyOutputFiles :: DynFlags -> IO () +verifyOutputFiles dflags = do + let odir = objectDir dflags + when (isJust odir) $ do + let dir = fromJust odir + flg <- doesDirectoryExist dir + when (not flg) (nonExistentDir "-odir" dir) + let ofile = outputFile dflags + when (isJust ofile) $ do + let fn = fromJust ofile + flg <- doesDirNameExist fn + when (not flg) (nonExistentDir "-o" fn) + let ohi = outputHi dflags + when (isJust ohi) $ do + let hi = fromJust ohi + flg <- doesDirNameExist hi + when (not flg) (nonExistentDir "-ohi" hi) + where + nonExistentDir flg dir = + throwDyn (CmdLineError ("error: directory portion of " ++ + show dir ++ " does not exist (used with " ++ + show flg ++ " option.)")) + +----------------------------------------------------------------------------- +-- GHC modes of operation + +data CmdLineMode + = ShowUsage -- ghc -? + | PrintLibdir -- ghc --print-libdir + | ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowInterface String -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval String -- ghc -e + deriving (Show) + +isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool +isLinkMode, isCompManagerMode :: CmdLineMode -> Bool + +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +needsInputsMode DoMkDependHS = True +needsInputsMode (StopBefore _) = True +needsInputsMode DoMake = True +needsInputsMode _ = False + +-- True if we are going to attempt to link in this mode. +-- (we might not actually link, depending on the GhcLink flag) +isLinkMode (StopBefore StopLn) = True +isLinkMode DoMake = True +isLinkMode _ = False + +isCompManagerMode DoMake = True +isCompManagerMode DoInteractive = True +isCompManagerMode (DoEval _) = True +isCompManagerMode _ = False + + +-- ----------------------------------------------------------------------------- +-- Parsing the mode flag + +parseModeFlags :: [String] -> IO (CmdLineMode, [String]) +parseModeFlags args = do + let ((leftover, errs), (mode, _, flags)) = + runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) + when (not (null errs)) $ do + throwDyn (UsageError (unlines errs)) + return (mode, flags ++ leftover) + +type ModeM a = CmdLineP (CmdLineMode, String, [String]) a + -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) + -- so we collect the new ones and return them. + +mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))] +mode_flags = + [ ------- help / version ---------------------------------------------- + ( "?" , PassFlag (setMode ShowUsage)) + , ( "-help" , PassFlag (setMode ShowUsage)) + , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) + , ( "V" , PassFlag (setMode ShowVersion)) + , ( "-version" , PassFlag (setMode ShowVersion)) + , ( "-numeric-version", PassFlag (setMode ShowNumVersion)) + + ------- interfaces ---------------------------------------------------- + , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f) + "--show-iface")) + + ------- primary modes ------------------------------------------------ + , ( "M" , PassFlag (setMode DoMkDependHS)) + , ( "E" , PassFlag (setMode (StopBefore anyHsc))) + , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + , ( "S" , PassFlag (setMode (StopBefore As))) + , ( "-make" , PassFlag (setMode DoMake)) + , ( "-interactive" , PassFlag (setMode DoInteractive)) + , ( "e" , HasArg (\s -> setMode (DoEval s) "-e")) + + -- -fno-code says to stop after Hsc but don't generate any code. + , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-no-recomp")) + ] + +setMode :: CmdLineMode -> String -> ModeM () +setMode m flag = do + (old_mode, old_flag, flags) <- getCmdLineState + when (notNull old_flag && flag /= old_flag) $ + throwDyn (UsageError + ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) + putCmdLineState (m, flag, flags) + +addFlag :: String -> ModeM () +addFlag s = do + (m, f, flags) <- getCmdLineState + putCmdLineState (m, f, s:flags) + + +-- ---------------------------------------------------------------------------- +-- Run --make mode + +doMake :: Session -> [(String,Maybe Phase)] -> IO () +doMake sess [] = throwDyn (UsageError "no input files") +doMake sess srcs = do + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (f,Just phase) = + phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn] + + dflags <- GHC.getSessionDynFlags sess + o_files <- mapM (compileFile dflags StopLn) non_hs_srcs + mapM_ (consIORef v_Ld_inputs) (reverse o_files) + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets sess targets + ok_flag <- GHC.load sess LoadAllTargets + when (failed ok_flag) (exitWith (ExitFailure 1)) + return () + +-- --------------------------------------------------------------------------- +-- Various banners and verbosity output. + +showBanner :: CmdLineMode -> DynFlags -> IO () +showBanner cli_mode dflags = do + let verb = verbosity dflags + -- Show the GHCi banner +# ifdef GHCI + when (isInteractiveMode cli_mode && verb >= 1) $ + hPutStrLn stdout ghciWelcomeMsg +# endif + + -- Display details of the configuration in verbose mode + when (not (isInteractiveMode cli_mode) && verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, compiled by GHC version " +#ifdef GHCI + -- GHCI is only set when we are bootstrapping... + hPutStrLn stderr cProjectVersion +#else + hPutStrLn stderr cBooterVersion +#endif + +showVersion :: IO () +showVersion = do + putStrLn (cProjectName ++ ", version " ++ cProjectVersion) + exitWith ExitSuccess + +showGhcUsage cli_mode = do + (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths + let usage_path + | DoInteractive <- cli_mode = ghci_usage_path + | otherwise = ghc_usage_path + usage <- readFile usage_path + dump usage + exitWith ExitSuccess + where + dump "" = return () + dump ('$':'$':s) = putStr progName >> dump s + dump (c:s) = putChar c >> dump s + +dumpFinalStats :: DynFlags -> IO () +dumpFinalStats dflags = + when (dopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags + +dumpFastStringStats :: DynFlags -> IO () +dumpFastStringStats dflags = do + buckets <- getFastStringTable + let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets + msg = text "FastString stats:" $$ + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "z-encoded: " <+> (is_z `pcntOf` entries), + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which will is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. + putMsg dflags msg + where + x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' + +countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) +countFS entries longest is_z has_z (b:bs) = + let + len = length b + longest' = max len longest + entries' = entries + len + is_zs = length (filter isZEncoded b) + has_zs = length (filter hasZEncoding b) + in + countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs + +-- ----------------------------------------------------------------------------- +-- Util + +unknownFlagsErr :: [String] -> a +unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs)) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs new file mode 100644 index 0000000000..e19a10dbc5 --- /dev/null +++ b/compiler/main/PackageConfig.hs @@ -0,0 +1,69 @@ +-- +-- (c) The University of Glasgow, 2004 +-- + +module PackageConfig ( + -- * PackageId + PackageId, + mkPackageId, stringToPackageId, packageIdString, packageConfigId, + packageIdFS, fsToPackageId, + + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo(..), showPackageId, + Version(..), + PackageIdentifier(..), + defaultPackageConfig + ) where + +#include "HsVersions.h" + +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version +import FastString + +-- ----------------------------------------------------------------------------- +-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we +-- might need to extend it with some GHC-specific stuff, but for now it's fine. + +type PackageConfig = InstalledPackageInfo +defaultPackageConfig = emptyInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- PackageId (package names with versions) + +-- Mostly the compiler deals in terms of PackageNames, which don't +-- have the version suffix. This is so that we don't need to know the +-- version for the -package-name flag, or know the versions of +-- wired-in packages like base & rts. Versions are confined to the +-- package sub-system. +-- +-- This means that in theory you could have multiple base packages installed +-- (for example), and switch between them using -package/-hide-package. +-- +-- A PackageId is a string of the form <pkg>-<version>. + +newtype PackageId = PId FastString deriving( Eq, Ord ) -- includes the version + -- easier not to use a newtype here, because we need instances of + -- Binary & Outputable, and we're too early to define them + +fsToPackageId :: FastString -> PackageId +fsToPackageId = PId + +packageIdFS :: PackageId -> FastString +packageIdFS (PId fs) = fs + +stringToPackageId :: String -> PackageId +stringToPackageId = fsToPackageId . mkFastString + +packageIdString :: PackageId -> String +packageIdString = unpackFS . packageIdFS + +mkPackageId :: PackageIdentifier -> PackageId +mkPackageId = stringToPackageId . showPackageId + +packageConfigId :: PackageConfig -> PackageId +packageConfigId = mkPackageId . package + + diff --git a/compiler/main/Packages.hi-boot-5 b/compiler/main/Packages.hi-boot-5 new file mode 100644 index 0000000000..62f020cddb --- /dev/null +++ b/compiler/main/Packages.hi-boot-5 @@ -0,0 +1,3 @@ +__interface Packages 1 0 where +__export Packages PackageState ; +1 data PackageState ; diff --git a/compiler/main/Packages.hi-boot-6 b/compiler/main/Packages.hi-boot-6 new file mode 100644 index 0000000000..6b12f1496e --- /dev/null +++ b/compiler/main/Packages.hi-boot-6 @@ -0,0 +1,2 @@ +module Packages where +data PackageState diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs new file mode 100644 index 0000000000..ae6b18863e --- /dev/null +++ b/compiler/main/Packages.lhs @@ -0,0 +1,705 @@ +% +% (c) The University of Glasgow, 2000 +% +\section{Package manipulation} + +\begin{code} +module Packages ( + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageIdH(..), isHomePackage, + PackageState(..), + mkPackageState, + initPackages, + getPackageDetails, + checkForPackageConflicts, + lookupModuleInAllPackages, + + HomeModules, mkHomeModules, isHomeModule, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageCIncludes, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getExplicitPackagesAnd, + + -- * Utils + isDllName + ) +where + +#include "HsVersions.h" + +import PackageConfig +import SysTools ( getTopDir, getPackageConfigPath ) +import ParsePkgConf ( loadPackageConfig ) +import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) +import StaticFlags ( opt_Static ) +import Config ( cProjectVersion ) +import Name ( Name, nameModule_maybe ) +import UniqFM +import Module +import FiniteMap +import UniqSet +import Util +import Maybes ( expectJust, MaybeErr(..) ) +import Panic +import Outputable + +#if __GLASGOW_HASKELL__ >= 603 +import System.Directory ( getAppUserDataDirectory ) +#else +import Compat.Directory ( getAppUserDataDirectory ) +#endif + +import System.Environment ( getEnv ) +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.Version +import System.Directory ( doesFileExist, doesDirectoryExist, + getDirectoryContents ) +import Control.Monad ( foldM ) +import Data.List ( nub, partition, sortBy, isSuffixOf ) +import FastString +import EXCEPTION ( throwDyn ) +import ErrUtils ( debugTraceMsg, putMsg, Message ) + +-- --------------------------------------------------------------------------- +-- The Package state + +-- Package state is all stored in DynFlags, including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. + +-- The package state is computed by initPackages, and kept in DynFlags. +-- +-- * -package <pkg> causes <pkg> to become exposed, and all other packages +-- with the same name to become hidden. +-- +-- * -hide-package <pkg> causes <pkg> to become hidden. +-- +-- * Let exposedPackages be the set of packages thus exposed. +-- Let depExposedPackages be the transitive closure from exposedPackages of +-- their dependencies. +-- +-- * It is an error for any two packages in depExposedPackages to provide the +-- same module. +-- +-- * When searching for a module from an explicit import declaration, +-- only the exposed modules in exposedPackages are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from depExposedPackages are valid. +-- +-- * When linking in a comp manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with explicit -package flags on the command-line, +-- or are a transitive dependency of same, or are "base"/"rts". +-- The reason for (b) is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + + +-- One important thing that the package state provides is a way to +-- tell, for a given module, whether it is part of the current package +-- or not. We need to know this for two reasons: +-- +-- * generating cross-DLL calls is different from intra-DLL calls +-- (see below). +-- * we don't record version information in interface files for entities +-- in a different package. +-- +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +data PackageState = PackageState { + + explicitPackages :: [PackageId], + -- The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + + origPkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- the full package database + + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- Derived from origPkgIdMap. + -- The exposed flags are adjusted according to -package and + -- -hide-package flags, and -ignore-package removes packages. + + moduleToPkgConfAll :: ModuleEnv [(PackageConfig,Bool)], + -- Derived from pkgIdMap. + -- Maps Module to (pkgconf,exposed), where pkgconf is the + -- PackageConfig for the package containing the module, and + -- exposed is True if the package exposes that module. + + -- The PackageIds of some known packages + basePackageId :: PackageIdH, + rtsPackageId :: PackageIdH, + haskell98PackageId :: PackageIdH, + thPackageId :: PackageIdH + } + +data PackageIdH + = HomePackage -- The "home" package is the package curently + -- being compiled + | ExtPackage PackageId -- An "external" package is any other package + + +isHomePackage :: PackageIdH -> Bool +isHomePackage HomePackage = True +isHomePackage (ExtPackage _) = False + +-- A PackageConfigMap maps a PackageId to a PackageConfig +type PackageConfigMap = UniqFM PackageConfig + +emptyPackageConfigMap :: PackageConfigMap +emptyPackageConfigMap = emptyUFM + +lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig +lookupPackage = lookupUFM + +extendPackageConfigMap + :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap +extendPackageConfigMap pkg_map new_pkgs + = foldl add pkg_map new_pkgs + where add pkg_map p = addToUFM pkg_map (packageConfigId p) p + +getPackageDetails :: PackageState -> PackageId -> PackageConfig +getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkgIdMap dflags) ps) + +-- ---------------------------------------------------------------------------- +-- Loading the package config files and building up the package state + +-- | Call this after parsing the DynFlags. It reads the package +-- configuration files, and sets up various internal tables of package +-- information, according to the package-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +initPackages :: DynFlags -> IO DynFlags +initPackages dflags = do + pkg_map <- readPackageConfigs dflags; + state <- mkPackageState dflags pkg_map + return dflags{ pkgState = state } + +-- ----------------------------------------------------------------------------- +-- Reading the package database(s) + +readPackageConfigs :: DynFlags -> IO PackageConfigMap +readPackageConfigs dflags = do + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + system_pkgconfs <- getSystemPackageConfigs dflags + + let pkgconfs = case e_pkg_path of + Left _ -> system_pkgconfs + Right path + | last cs == "" -> init cs ++ system_pkgconfs + | otherwise -> cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- the we tack on the system paths. + + -- Read all the ones mentioned in -package-conf flags + pkg_map <- foldM (readPackageConfig dflags) emptyPackageConfigMap + (reverse pkgconfs ++ extraPkgConfs dflags) + + return pkg_map + + +getSystemPackageConfigs :: DynFlags -> IO [FilePath] +getSystemPackageConfigs dflags = do + -- System one always comes first + system_pkgconf <- getPackageConfigPath + + -- allow package.conf.d to contain a bunch of .conf files + -- containing package specifications. This is an easier way + -- to maintain the package database on systems with a package + -- management system, or systems that don't want to run ghc-pkg + -- to register or unregister packages. Undocumented feature for now. + let system_pkgconf_dir = system_pkgconf ++ ".d" + system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir + system_pkgconfs <- + if system_pkgconf_dir_exists + then do files <- getDirectoryContents system_pkgconf_dir + return [ system_pkgconf_dir ++ '/' : file + | file <- files + , isSuffixOf ".conf" file] + else return [] + + -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) + -- unless the -no-user-package-conf flag was given. + -- We only do this when getAppUserDataDirectory is available + -- (GHC >= 6.3). + user_pkgconf <- handle (\_ -> return []) $ do + appdir <- getAppUserDataDirectory "ghc" + let + pkgconf = appdir + `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + `joinFileName` "package.conf" + flg <- doesFileExist pkgconf + if (flg && dopt Opt_ReadUserPackageConf dflags) + then return [pkgconf] + else return [] + + return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf]) + + +readPackageConfig + :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap +readPackageConfig dflags pkg_map conf_file = do + debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) + proto_pkg_configs <- loadPackageConfig conf_file + top_dir <- getTopDir + let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs + pkg_configs2 = maybeHidePackages dflags pkg_configs1 + return (extendPackageConfigMap pkg_map pkg_configs2) + +maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig] +maybeHidePackages dflags pkgs + | dopt Opt_HideAllPackages dflags = map hide pkgs + | otherwise = pkgs + where + hide pkg = pkg{ exposed = False } + +mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] +-- Replace the string "$topdir" at the beginning of a path +-- with the current topdir (obtained from the -B option). +mungePackagePaths top_dir ps = map munge_pkg ps + where + munge_pkg p = p{ importDirs = munge_paths (importDirs p), + includeDirs = munge_paths (includeDirs p), + libraryDirs = munge_paths (libraryDirs p), + frameworkDirs = munge_paths (frameworkDirs p) } + + munge_paths = map munge_path + + munge_path p + | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' + | otherwise = p + + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our package +-- settings and populate the package state. + +mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState +mkPackageState dflags orig_pkg_db = do + -- + -- Modify the package database according to the command-line flags + -- (-package, -hide-package, -ignore-package, -hide-all-packages). + -- + -- Also, here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "explicit" packages. + -- we link these packages in eagerly. The explicit set should contain + -- at least rts & base, which is why we pretend that the command line + -- contains -package rts & -package base. + -- + let + flags = reverse (packageFlags dflags) + + procflags pkgs expl [] = return (pkgs,expl) + procflags pkgs expl (ExposePackage str : flags) = do + case pick str pkgs of + Nothing -> missingPackageErr str + Just (p,ps) -> procflags (p':ps') expl' flags + where pkgid = packageConfigId p + p' = p {exposed=True} + ps' = hideAll (pkgName (package p)) ps + expl' = addOneToUniqSet expl pkgid + procflags pkgs expl (HidePackage str : flags) = do + case partition (matches str) pkgs of + ([],_) -> missingPackageErr str + (ps,qs) -> procflags (map hide ps ++ qs) expl flags + where hide p = p {exposed=False} + procflags pkgs expl (IgnorePackage str : flags) = do + case partition (matches str) pkgs of + (ps,qs) -> procflags qs expl flags + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + + pick str pkgs + = case partition (matches str) pkgs of + ([],_) -> Nothing + (ps,rest) -> + case sortBy (flip (comparing (pkgVersion.package))) ps of + (p:ps) -> Just (p, ps ++ rest) + _ -> panic "Packages.pick" + + comparing f a b = f a `compare` f b + + -- A package named on the command line can either include the + -- version, or just the name if it is unambiguous. + matches str p + = str == showPackageId (package p) + || str == pkgName (package p) + + -- When a package is requested to be exposed, we hide all other + -- packages with the same name. + hideAll name ps = map maybe_hide ps + where maybe_hide p | pkgName (package p) == name = p {exposed=False} + | otherwise = p + -- + (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) emptyUniqSet flags + -- + -- hide all packages for which there is also a later version + -- that is already exposed. This just makes it non-fatal to have two + -- versions of a package exposed, which can happen if you install a + -- later version of a package in the user database, for example. + -- + let maybe_hide p + | not (exposed p) = return p + | (p' : _) <- later_versions = do + debugTraceMsg dflags 2 $ + (ptext SLIT("hiding package") <+> text (showPackageId (package p)) <+> + ptext SLIT("to avoid conflict with later version") <+> + text (showPackageId (package p'))) + return (p {exposed=False}) + | otherwise = return p + where myname = pkgName (package p) + myversion = pkgVersion (package p) + later_versions = [ p | p <- pkgs1, exposed p, + let pkg = package p, + pkgName pkg == myname, + pkgVersion pkg > myversion ] + a_later_version_is_exposed + = not (null later_versions) + + pkgs2 <- mapM maybe_hide pkgs1 + -- + -- Eliminate any packages which have dangling dependencies (perhaps + -- because the package was removed by -ignore-package). + -- + let + elimDanglingDeps pkgs = + case partition (not.null.snd) (map (getDanglingDeps pkgs) pkgs) of + ([],ps) -> return (map fst ps) + (ps,qs) -> do + mapM_ reportElim ps + elimDanglingDeps (map fst qs) + + reportElim (p, deps) = + debugTraceMsg dflags 2 $ + (ptext SLIT("package") <+> pprPkg p <+> + ptext SLIT("will be ignored due to missing dependencies:") $$ + nest 2 (hsep (map (text.showPackageId) deps))) + + getDanglingDeps pkgs p = (p, filter dangling (depends p)) + where dangling pid = pid `notElem` all_pids + all_pids = map package pkgs + -- + pkgs <- elimDanglingDeps pkgs2 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs + -- + -- Find the transitive closure of dependencies of exposed + -- + let exposed_pkgids = [ packageConfigId p | p <- pkgs, exposed p ] + dep_exposed <- closeDeps pkg_db exposed_pkgids + -- + -- Look up some known PackageIds + -- + let + lookupPackageByName :: FastString -> PackageIdH + lookupPackageByName nm = + case [ conf | p <- dep_exposed, + Just conf <- [lookupPackage pkg_db p], + nm == mkFastString (pkgName (package conf)) ] of + [] -> HomePackage + (p:ps) -> ExtPackage (mkPackageId (package p)) + + -- Get the PackageIds for some known packages (we know the names, + -- but we don't know the versions). Some of these packages might + -- not exist in the database, so they are Maybes. + basePackageId = lookupPackageByName basePackageName + rtsPackageId = lookupPackageByName rtsPackageName + haskell98PackageId = lookupPackageByName haskell98PackageName + thPackageId = lookupPackageByName thPackageName + + -- add base & rts to the explicit packages + basicLinkedPackages = [basePackageId,rtsPackageId] + explicit' = addListToUniqSet explicit + [ p | ExtPackage p <- basicLinkedPackages ] + -- + -- Close the explicit packages with their dependencies + -- + dep_explicit <- closeDeps pkg_db (uniqSetToList explicit') + -- + -- Build up a mapping from Module -> PackageConfig for all modules. + -- Discover any conflicts at the same time, and factor in the new exposed + -- status of each package. + -- + let mod_map = mkModuleMap pkg_db dep_exposed + + return PackageState{ explicitPackages = dep_explicit, + origPkgIdMap = orig_pkg_db, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mod_map, + basePackageId = basePackageId, + rtsPackageId = rtsPackageId, + haskell98PackageId = haskell98PackageId, + thPackageId = thPackageId + } + -- done! + +basePackageName = FSLIT("base") +rtsPackageName = FSLIT("rts") +haskell98PackageName = FSLIT("haskell98") +thPackageName = FSLIT("template-haskell") + -- Template Haskell libraries in here + +mkModuleMap + :: PackageConfigMap + -> [PackageId] + -> ModuleEnv [(PackageConfig, Bool)] +mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs + where + extend_modmap pkgname modmap = + addListToUFM_C (++) modmap + [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname) + exposed_mods = map mkModule (exposedModules pkg) + hidden_mods = map mkModule (hiddenModules pkg) + all_mods = exposed_mods ++ hidden_mods + +-- ----------------------------------------------------------------------------- +-- Check for conflicts in the program. + +-- | A conflict arises if the program contains two modules with the same +-- name, which can arise if the program depends on multiple packages that +-- expose the same module, or if the program depends on a package that +-- contains a module also present in the program (the "home package"). +-- +checkForPackageConflicts + :: DynFlags + -> [Module] -- modules in the home package + -> [PackageId] -- packages on which the program depends + -> MaybeErr Message () + +checkForPackageConflicts dflags mods pkgs = do + let + state = pkgState dflags + pkg_db = pkgIdMap state + -- + dep_pkgs <- closeDepsErr pkg_db pkgs + + let + extend_modmap pkgname modmap = + addListToFM_C (++) modmap + [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + where + pkg = expectJust "checkForPackageConflicts" + (lookupPackage pkg_db pkgname) + exposed_mods = map mkModule (exposedModules pkg) + hidden_mods = map mkModule (hiddenModules pkg) + all_mods = exposed_mods ++ hidden_mods + + mod_map = foldr extend_modmap emptyFM pkgs + mod_map_list :: [(Module,[(PackageConfig,Bool)])] + mod_map_list = fmToList mod_map + + overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ] + -- + if not (null overlaps) + then Failed (pkgOverlapError overlaps) + else do + + let + overlap_mods = [ (mod,pkg) + | mod <- mods, + Just ((pkg,_):_) <- [lookupFM mod_map mod] ] + -- will be only one package here + if not (null overlap_mods) + then Failed (modOverlapError overlap_mods) + else do + + return () + +pkgOverlapError overlaps = vcat (map msg overlaps) + where + msg (mod,pkgs) = + text "conflict: module" <+> quotes (ppr mod) + <+> ptext SLIT("is present in multiple packages:") + <+> hsep (punctuate comma (map pprPkg pkgs)) + +modOverlapError overlaps = vcat (map msg overlaps) + where + msg (mod,pkg) = fsep [ + text "conflict: module", + quotes (ppr mod), + ptext SLIT("belongs to the current program/library"), + ptext SLIT("and also to package"), + pprPkg pkg ] + +pprPkg :: PackageConfig -> SDoc +pprPkg p = text (showPackageId (package p)) + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of explicit (command-line) packages to determine which packages to +-- use. + +getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] +getPackageIncludePath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap includeDirs ps))) + + -- includes are in reverse dependency order (i.e. rts first) +getPackageCIncludes :: [PackageConfig] -> IO [String] +getPackageCIncludes pkg_configs = do + return (reverse (nub (filter notNull (concatMap includes pkg_configs)))) + +getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String] +getPackageLibraryPath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap libraryDirs ps))) + +getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageLinkOpts dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + let tag = buildTag dflags + rts_tag = rtsBuildTag dflags + let + imp = if opt_Static then "" else "_dyn" + libs p = map ((++imp) . addSuffix) (hsLibraries p) + ++ hACK_dyn (extraLibraries p) + all_opts p = map ("-l" ++) (libs p) ++ ldOptions p + + suffix = if null tag then "" else '_':tag + rts_suffix = if null rts_tag then "" else '_':rts_tag + + addSuffix rts@"HSrts" = rts ++ rts_suffix + addSuffix other_lib = other_lib ++ suffix + + -- This is a hack that's even more horrible (and hopefully more temporary) + -- than the one below [referring to previous splittage of HSbase into chunks + -- to work around GNU ld bug]. HSbase_cbits and friends require the _dyn suffix + -- for dynamic linking, but not _p or other 'way' suffix. So we just add + -- _dyn to extraLibraries if they already have a _cbits suffix. + + hACK_dyn = map hack + where hack lib | not opt_Static && "_cbits" `isSuffixOf` lib = lib ++ "_dyn" + | otherwise = lib + + return (concat (map all_opts ps)) + +getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (concatMap ccOptions ps) + +getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap frameworkDirs ps))) + +getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (concatMap frameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a Module, and if the module is in a package returns +-- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package, +-- and exposed is True if the package exposes the module. +lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)] +lookupModuleInAllPackages dflags m = + case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of + Nothing -> [] + Just ps -> ps + +getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] +getExplicitPackagesAnd dflags pkgids = + let + state = pkgState dflags + pkg_map = pkgIdMap state + expl = explicitPackages state + in do + all_pkgs <- throwErr (foldM (add_package pkg_map) expl pkgids) + return (map (getPackageDetails state) all_pkgs) + +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId] +closeDeps pkg_map ps = throwErr (closeDepsErr pkg_map ps) + +throwErr :: MaybeErr Message a -> IO a +throwErr m = case m of + Failed e -> throwDyn (CmdLineError (showSDoc e)) + Succeeded r -> return r + +closeDepsErr :: PackageConfigMap -> [PackageId] + -> MaybeErr Message [PackageId] +closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps + +-- internal helper +add_package :: PackageConfigMap -> [PackageId] -> PackageId + -> MaybeErr Message [PackageId] +add_package pkg_db ps p + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupPackage pkg_db p of + Nothing -> Failed (missingPackageMsg (packageIdString p)) + Just pkg -> do + -- Add the package's dependents also + let deps = map mkPackageId (depends pkg) + ps' <- foldM (add_package pkg_db) ps deps + return (p : ps') + +missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageMsg p = ptext SLIT("unknown package:") <+> text p + +-- ----------------------------------------------------------------------------- +-- The home module set + +newtype HomeModules = HomeModules ModuleSet + +mkHomeModules :: [Module] -> HomeModules +mkHomeModules = HomeModules . mkModuleSet + +isHomeModule :: HomeModules -> Module -> Bool +isHomeModule (HomeModules set) mod = elemModuleSet mod set + +-- Determining whether a Name refers to something in another package or not. +-- Cross-package references need to be handled differently when dynamically- +-- linked libraries are involved. + +isDllName :: HomeModules -> Name -> Bool +isDllName pdeps name + | opt_Static = False + | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod) + | otherwise = False -- no, it is not even an external name + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +dumpPackages :: DynFlags -> IO () +-- Show package info on console, if verbosity is >= 3 +dumpPackages dflags + = do let pkg_map = pkgIdMap (pkgState dflags) + putMsg dflags $ + vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) +\end{code} diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.lhs-boot new file mode 100644 index 0000000000..3a1712e2da --- /dev/null +++ b/compiler/main/Packages.lhs-boot @@ -0,0 +1,4 @@ +\begin{code} +module Packages where +data PackageState +\end{code} diff --git a/compiler/main/ParsePkgConf.y b/compiler/main/ParsePkgConf.y new file mode 100644 index 0000000000..901a5bc943 --- /dev/null +++ b/compiler/main/ParsePkgConf.y @@ -0,0 +1,153 @@ +{ +module ParsePkgConf( loadPackageConfig ) where + +#include "HsVersions.h" + +import PackageConfig +import Lexer +import DynFlags +import FastString +import StringBuffer +import ErrUtils ( mkLocMessage ) +import SrcLoc +import Outputable +import Panic ( GhcException(..) ) +import EXCEPTION ( throwDyn ) + +} + +%token + '{' { L _ ITocurly } + '}' { L _ ITccurly } + '[' { L _ ITobrack } + ']' { L _ ITcbrack } + ',' { L _ ITcomma } + '=' { L _ ITequal } + VARID { L _ (ITvarid $$) } + CONID { L _ (ITconid $$) } + STRING { L _ (ITstring $$) } + INT { L _ (ITinteger $$) } + +%monad { P } { >>= } { return } +%lexer { lexer } { L _ ITeof } +%name parse +%tokentype { Located Token } +%% + +pkgconf :: { [ PackageConfig ] } + : '[' ']' { [] } + | '[' pkgs ']' { reverse $2 } + +pkgs :: { [ PackageConfig ] } + : pkg { [ $1 ] } + | pkgs ',' pkg { $3 : $1 } + +pkg :: { PackageConfig } + : CONID '{' fields '}' { $3 defaultPackageConfig } + +fields :: { PackageConfig -> PackageConfig } + : field { \p -> $1 p } + | fields ',' field { \p -> $1 ($3 p) } + +field :: { PackageConfig -> PackageConfig } + : VARID '=' pkgid + {% case unpackFS $1 of + "package" -> return (\p -> p{package = $3}) + _other -> happyError + } + + | VARID '=' STRING { id } + -- we aren't interested in the string fields, they're all + -- boring (copyright, maintainer etc.) + + | VARID '=' CONID + {% case unpackFS $1 of { + "exposed" -> + case unpackFS $3 of { + "True" -> return (\p -> p{exposed=True}); + "False" -> return (\p -> p{exposed=False}); + _ -> happyError }; + "license" -> return id; -- not interested + _ -> happyError } + } + + | VARID '=' CONID STRING { id } + -- another case of license + + | VARID '=' strlist + {\p -> case unpackFS $1 of + "exposedModules" -> p{exposedModules = $3} + "hiddenModules" -> p{hiddenModules = $3} + "importDirs" -> p{importDirs = $3} + "libraryDirs" -> p{libraryDirs = $3} + "hsLibraries" -> p{hsLibraries = $3} + "extraLibraries" -> p{extraLibraries = $3} + "extraGHCiLibraries"-> p{extraGHCiLibraries= $3} + "includeDirs" -> p{includeDirs = $3} + "includes" -> p{includes = $3} + "hugsOptions" -> p{hugsOptions = $3} + "ccOptions" -> p{ccOptions = $3} + "ldOptions" -> p{ldOptions = $3} + "frameworkDirs" -> p{frameworkDirs = $3} + "frameworks" -> p{frameworks = $3} + "haddockInterfaces" -> p{haddockInterfaces = $3} + "haddockHTMLs" -> p{haddockHTMLs = $3} + "depends" -> p{depends = []} + -- empty list only, non-empty handled below + other -> p + } + + | VARID '=' pkgidlist + {% case unpackFS $1 of + "depends" -> return (\p -> p{depends = $3}) + _other -> happyError + } + +pkgid :: { PackageIdentifier } + : CONID '{' VARID '=' STRING ',' VARID '=' version '}' + { PackageIdentifier{ pkgName = unpackFS $5, + pkgVersion = $9 } } + +version :: { Version } + : CONID '{' VARID '=' intlist ',' VARID '=' strlist '}' + { Version{ versionBranch=$5, versionTags=$9 } } + +pkgidlist :: { [PackageIdentifier] } + : '[' pkgids ']' { $2 } + -- empty list case is covered by strlist, to avoid conflicts + +pkgids :: { [PackageIdentifier] } + : pkgid { [ $1 ] } + | pkgid ',' pkgids { $1 : $3 } + +intlist :: { [Int] } + : '[' ']' { [] } + | '[' ints ']' { $2 } + +ints :: { [Int] } + : INT { [ fromIntegral $1 ] } + | INT ',' ints { fromIntegral $1 : $3 } + +strlist :: { [String] } + : '[' ']' { [] } + | '[' strs ']' { $2 } + +strs :: { [String] } + : STRING { [ unpackFS $1 ] } + | STRING ',' strs { unpackFS $1 : $3 } + +{ +happyError :: P a +happyError = srcParseFail + +loadPackageConfig :: FilePath -> IO [PackageConfig] +loadPackageConfig conf_filename = do + buf <- hGetStringBuffer conf_filename + let loc = mkSrcLoc (mkFastString conf_filename) 1 0 + case unP parse (mkPState buf loc defaultDynFlags) of + PFailed span err -> + throwDyn (InstallationError (showSDoc (mkLocMessage span err))) + + POk _ pkg_details -> do + return pkg_details +} diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs new file mode 100644 index 0000000000..2763b052fd --- /dev/null +++ b/compiler/main/PprTyThing.hs @@ -0,0 +1,223 @@ +----------------------------------------------------------------------------- +-- +-- Pretty-printing TyThings +-- +-- (c) The GHC Team 2005 +-- +----------------------------------------------------------------------------- + +module PprTyThing ( + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr + ) where + +#include "HsVersions.h" + +import qualified GHC +import GHC ( TyThing(..), SrcLoc ) +import Outputable + +-- ----------------------------------------------------------------------------- +-- Pretty-printing entities that we get from the GHC API + +-- This should be a good source of sample code for using the GHC API to +-- inspect source code entities. + +-- | Pretty-prints a 'TyThing' with its defining location. +pprTyThingLoc :: Bool -> TyThing -> SDoc +pprTyThingLoc exts tyThing + = showWithLoc loc (pprTyThing exts tyThing) + where loc = GHC.nameSrcLoc (GHC.getName tyThing) + +-- | Pretty-prints a 'TyThing'. +pprTyThing :: Bool -> TyThing -> SDoc +pprTyThing exts (AnId id) = pprId exts id +pprTyThing exts (ADataCon dataCon) = pprDataConSig exts dataCon +pprTyThing exts (ATyCon tyCon) = pprTyCon exts tyCon +pprTyThing exts (AClass cls) = pprClass exts cls + +-- | Like 'pprTyThingInContext', but adds the defining location. +pprTyThingInContextLoc :: Bool -> TyThing -> SDoc +pprTyThingInContextLoc exts tyThing + = showWithLoc loc (pprTyThingInContext exts tyThing) + where loc = GHC.nameSrcLoc (GHC.getName tyThing) + +-- | Pretty-prints a 'TyThing' in context: that is, if the entity +-- is a data constructor, record selector, or class method, then +-- the entity's parent declaration is pretty-printed with irrelevant +-- parts omitted. +pprTyThingInContext :: Bool -> TyThing -> SDoc +pprTyThingInContext exts (AnId id) = pprIdInContext exts id +pprTyThingInContext exts (ADataCon dataCon) = pprDataCon exts dataCon +pprTyThingInContext exts (ATyCon tyCon) = pprTyCon exts tyCon +pprTyThingInContext exts (AClass cls) = pprClass exts cls + +-- | Pretty-prints the 'TyThing' header. For functions and data constructors +-- the function is equivalent to 'pprTyThing' but for type constructors +-- and classes it prints only the header part of the declaration. +pprTyThingHdr :: Bool -> TyThing -> SDoc +pprTyThingHdr exts (AnId id) = pprId exts id +pprTyThingHdr exts (ADataCon dataCon) = pprDataConSig exts dataCon +pprTyThingHdr exts (ATyCon tyCon) = pprTyConHdr exts tyCon +pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls + +pprTyConHdr exts tyCon = + ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars) + where + vars | GHC.isPrimTyCon tyCon || + GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars + | otherwise = GHC.tyConTyVars tyCon + + keyword | GHC.isSynTyCon tyCon = SLIT("type") + | GHC.isNewTyCon tyCon = SLIT("newtype") + | otherwise = SLIT("data") + +pprDataConSig exts dataCon = + ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon) + +pprClassHdr exts cls = + let (tyVars, funDeps) = GHC.classTvsFds cls + in ptext SLIT("class") <+> + GHC.pprThetaArrow (GHC.classSCTheta cls) <+> + ppr_bndr cls <+> + hsep (map ppr tyVars) <+> + GHC.pprFundeps funDeps + +pprIdInContext exts id + | GHC.isRecordSelector id = pprRecordSelector exts id + | Just cls <- GHC.isClassOpId_maybe id = pprClassOneMethod exts cls id + | otherwise = pprId exts id + +pprRecordSelector exts id + = pprAlgTyCon exts tyCon show_con show_label + where + (tyCon,label) = GHC.recordSelectorFieldLabel id + show_con dataCon = label `elem` GHC.dataConFieldLabels dataCon + show_label label' = label == label' + +pprId exts id + = hang (ppr_bndr id <+> dcolon) 2 + (pprType exts (GHC.idType id)) + +pprType True ty = ppr ty +pprType False ty = ppr (GHC.dropForAlls ty) + +pprTyCon exts tyCon + | GHC.isSynTyCon tyCon + = let rhs_type = GHC.synTyConRhs tyCon + in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type) + | otherwise + = pprAlgTyCon exts tyCon (const True) (const True) + +pprAlgTyCon exts tyCon ok_con ok_label + | gadt = pprTyConHdr exts tyCon <+> ptext SLIT("where") $$ + nest 2 (vcat (ppr_trim show_con datacons)) + | otherwise = hang (pprTyConHdr exts tyCon) + 2 (add_bars (ppr_trim show_con datacons)) + where + datacons = GHC.tyConDataCons tyCon + gadt = any (not . GHC.isVanillaDataCon) datacons + + show_con dataCon + | ok_con dataCon = Just (pprDataConDecl exts gadt ok_label dataCon) + | otherwise = Nothing + +pprDataCon exts dataCon = pprAlgTyCon exts tyCon (== dataCon) (const True) + where tyCon = GHC.dataConTyCon dataCon + +pprDataConDecl exts gadt_style show_label dataCon + | not gadt_style = ppr_fields tys_w_strs + | otherwise = ppr_bndr dataCon <+> dcolon <+> + sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ] + where + (tyvars, theta, argTypes, tyCon, res_tys) = GHC.dataConSig dataCon + labels = GHC.dataConFieldLabels dataCon + qualVars = filter (flip notElem (GHC.tyConTyVars tyCon)) tyvars + stricts = GHC.dataConStrictMarks dataCon + tys_w_strs = zip stricts argTypes + + ppr_tvs + | null qualVars = empty + | otherwise = ptext SLIT("forall") <+> + hsep (map ppr qualVars) <> dot + + -- printing out the dataCon as a type signature, in GADT style + pp_tau = foldr add pp_res_ty tys_w_strs + pp_res_ty = ppr_bndr tyCon <+> hsep (map GHC.pprParendType res_tys) + add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty + + pprParendBangTy (strict,ty) + | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty + | otherwise = GHC.pprParendType ty + + pprBangTy strict ty + | GHC.isMarkedStrict strict = char '!' <> ppr ty + | otherwise = ppr ty + + maybe_show_label (lbl,(strict,tp)) + | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp) + | otherwise = Nothing + + ppr_fields [ty1, ty2] + | GHC.dataConIsInfix dataCon && null labels + = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2] + ppr_fields fields + | null labels + = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) + | otherwise + = ppr_bndr dataCon <+> + braces (sep (punctuate comma (ppr_trim maybe_show_label + (zip labels fields)))) + +pprClass exts cls + | null methods = + pprClassHdr exts cls + | otherwise = + hang (pprClassHdr exts cls <+> ptext SLIT("where")) + 2 (vcat (map (pprClassMethod exts) methods)) + where + methods = GHC.classMethods cls + +pprClassOneMethod exts cls this_one = + hang (pprClassHdr exts cls <+> ptext SLIT("where")) + 2 (vcat (ppr_trim show_meth methods)) + where + methods = GHC.classMethods cls + show_meth id | id == this_one = Just (pprClassMethod exts id) + | otherwise = Nothing + +pprClassMethod exts id = + hang (ppr_bndr id <+> dcolon) 2 (pprType exts (classOpType id)) + where + -- Here's the magic incantation to strip off the dictionary + -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. + classOpType id = GHC.funResultTy rho_ty + where (_sel_tyvars, rho_ty) = GHC.splitForAllTys (GHC.idType id) + +ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] +ppr_trim show xs + = snd (foldr go (False, []) xs) + where + go x (eliding, so_far) + | Just doc <- show x = (False, doc : so_far) + | otherwise = if eliding then (True, so_far) + else (True, ptext SLIT("...") : so_far) + +add_bars [] = empty +add_bars [c] = equals <+> c +add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) + +-- Wrap operators in () +ppr_bndr :: GHC.NamedThing a => a -> SDoc +ppr_bndr a = GHC.pprParenSymName a + +showWithLoc :: SrcLoc -> SDoc -> SDoc +showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> GHC.pprDefnLoc loc) + -- The tab tries to make them line up a bit + where + comment = ptext SLIT("--") + diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs new file mode 100644 index 0000000000..3067063f7b --- /dev/null +++ b/compiler/main/StaticFlags.hs @@ -0,0 +1,584 @@ +----------------------------------------------------------------------------- +-- +-- Static flags +-- +-- Static flags can only be set once, on the command-line. Inside GHC, +-- each static flag corresponds to a top-level value, usually of type Bool. +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module StaticFlags ( + parseStaticFlags, + staticFlags, + + -- Ways + WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag, + + -- Output style options + opt_PprUserLength, + opt_PprStyle_Debug, + + -- profiling opts + opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, + opt_AutoSccsOnIndividualCafs, + opt_SccProfilingOn, + opt_DoTickyProfiling, + + -- language opts + opt_DictsStrict, + opt_MaxContextReductionDepth, + opt_IrrefutableTuples, + opt_Parallel, + opt_RuntimeTypes, + opt_Flatten, + + -- optimisation opts + opt_NoMethodSharing, + opt_NoStateHack, + opt_LiberateCaseThreshold, + opt_CprOff, + opt_RulesOff, + opt_SimplNoPreInlining, + opt_SimplExcessPrecision, + opt_MaxWorkerArgs, + + -- Unfolding control + opt_UF_CreationThreshold, + opt_UF_UseThreshold, + opt_UF_FunAppDiscount, + opt_UF_KeenessFactor, + opt_UF_UpdateInPlace, + opt_UF_DearOp, + + -- misc opts + opt_IgnoreDotGhci, + opt_ErrorSpans, + opt_EmitCExternDecls, + opt_GranMacros, + opt_HiVersion, + opt_HistorySize, + opt_OmitBlackHoling, + opt_Static, + opt_Unregisterised, + opt_EmitExternalCore, + opt_PIC, + v_Ld_inputs, + ) where + +#include "HsVersions.h" + +import Util ( consIORef ) +import CmdLineParser +import Config ( cProjectVersionInt, cProjectPatchLevel, + cGhcUnregisterised ) +import FastString ( FastString, mkFastString ) +import Util +import Maybes ( firstJust ) +import Panic ( GhcException(..), ghcError ) +import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) + +import EXCEPTION ( throwDyn ) +import DATA_IOREF +import UNSAFE_IO ( unsafePerformIO ) +import Monad ( when ) +import Char ( isDigit ) +import List ( sort, intersperse ) + +----------------------------------------------------------------------------- +-- Static flags + +parseStaticFlags :: [String] -> IO [String] +parseStaticFlags args = do + (leftover, errs) <- processArgs static_flags args + when (not (null errs)) $ throwDyn (UsageError (unlines errs)) + + -- deal with the way flags: the way (eg. prof) gives rise to + -- futher flags, some of which might be static. + way_flags <- findBuildTag + + -- if we're unregisterised, add some more flags + let unreg_flags | cGhcUnregisterised == "YES" = unregFlags + | otherwise = [] + + (more_leftover, errs) <- processArgs static_flags (unreg_flags ++ way_flags) + when (not (null errs)) $ ghcError (UsageError (unlines errs)) + return (more_leftover++leftover) + + +-- note that ordering is important in the following list: any flag which +-- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override +-- flags further down the list with the same prefix. + +static_flags :: [(String, OptKind IO)] +static_flags = [ + ------- GHCi ------------------------------------------------------- + ( "ignore-dot-ghci", PassFlag addOpt ) + , ( "read-dot-ghci" , NoArg (removeOpt "-ignore-dot-ghci") ) + + ------- ways -------------------------------------------------------- + , ( "prof" , NoArg (addWay WayProf) ) + , ( "unreg" , NoArg (addWay WayUnreg) ) + , ( "ticky" , NoArg (addWay WayTicky) ) + , ( "parallel" , NoArg (addWay WayPar) ) + , ( "gransim" , NoArg (addWay WayGran) ) + , ( "smp" , NoArg (addWay WayThreaded) ) -- backwards compat. + , ( "debug" , NoArg (addWay WayDebug) ) + , ( "ndp" , NoArg (addWay WayNDP) ) + , ( "threaded" , NoArg (addWay WayThreaded) ) + -- ToDo: user ways + + ------ Debugging ---------------------------------------------------- + , ( "dppr-noprags", PassFlag addOpt ) + , ( "dppr-debug", PassFlag addOpt ) + , ( "dppr-user-length", AnySuffix addOpt ) + -- rest of the debugging flags are dynamic + + --------- Profiling -------------------------------------------------- + , ( "auto-all" , NoArg (addOpt "-fauto-sccs-on-all-toplevs") ) + , ( "auto" , NoArg (addOpt "-fauto-sccs-on-exported-toplevs") ) + , ( "caf-all" , NoArg (addOpt "-fauto-sccs-on-individual-cafs") ) + -- "ignore-sccs" doesn't work (ToDo) + + , ( "no-auto-all" , NoArg (removeOpt "-fauto-sccs-on-all-toplevs") ) + , ( "no-auto" , NoArg (removeOpt "-fauto-sccs-on-exported-toplevs") ) + , ( "no-caf-all" , NoArg (removeOpt "-fauto-sccs-on-individual-cafs") ) + + ------- Miscellaneous ----------------------------------------------- + , ( "no-link-chk" , NoArg (return ()) ) -- ignored for backwards compat + + ----- Linker -------------------------------------------------------- + , ( "static" , PassFlag addOpt ) + , ( "dynamic" , NoArg (removeOpt "-static") ) + , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc + + ----- RTS opts ------------------------------------------------------ + , ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) ) + , ( "Rghc-timing" , NoArg (enableTimingStats) ) + + ------ Compiler flags ----------------------------------------------- + -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline + , ( "fno-", PrefixPred (\s -> isStaticFlag ("f"++s)) + (\s -> removeOpt ("-f"++s)) ) + + -- Pass all remaining "-f<blah>" options to hsc + , ( "f", AnySuffixPred (isStaticFlag) addOpt ) + ] + +addOpt = consIORef v_opt_C + +addWay = consIORef v_Ways + +removeOpt f = do + fs <- readIORef v_opt_C + writeIORef v_opt_C $! filter (/= f) fs + +lookUp :: FastString -> Bool +lookup_def_int :: String -> Int -> Int +lookup_def_float :: String -> Float -> Float +lookup_str :: String -> Maybe String + +-- holds the static opts while they're being collected, before +-- being unsafely read by unpacked_static_opts below. +GLOBAL_VAR(v_opt_C, defaultStaticOpts, [String]) +staticFlags = unsafePerformIO (readIORef v_opt_C) + +-- -static is the default +defaultStaticOpts = ["-static"] + +packed_static_opts = map mkFastString staticFlags + +lookUp sw = sw `elem` packed_static_opts + +-- (lookup_str "foo") looks for the flag -foo=X or -fooX, +-- and returns the string X +lookup_str sw + = case firstJust (map (startsWith sw) staticFlags) of + Just ('=' : str) -> Just str + Just str -> Just str + Nothing -> Nothing + +lookup_def_int sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + +lookup_def_float sw def = case (lookup_str sw) of + Nothing -> def -- Use default + Just xx -> try_read sw xx + + +try_read :: Read a => String -> String -> a +-- (try_read sw str) tries to read s; if it fails, it +-- bleats about flag sw +try_read sw str + = case reads str of + ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses + [] -> ghcError (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) + -- ToDo: hack alert. We should really parse the arugments + -- and announce errors in a more civilised way. + + +{- + Putting the compiler options into temporary at-files + may turn out to be necessary later on if we turn hsc into + a pure Win32 application where I think there's a command-line + length limit of 255. unpacked_opts understands the @ option. + +unpacked_opts :: [String] +unpacked_opts = + concat $ + map (expandAts) $ + map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts + where + expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) + expandAts l = [l] +-} + + +opt_IgnoreDotGhci = lookUp FSLIT("-ignore-dot-ghci") + +-- debugging opts +opt_PprStyle_Debug = lookUp FSLIT("-dppr-debug") +opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name + +-- profiling opts +opt_AutoSccsOnAllToplevs = lookUp FSLIT("-fauto-sccs-on-all-toplevs") +opt_AutoSccsOnExportedToplevs = lookUp FSLIT("-fauto-sccs-on-exported-toplevs") +opt_AutoSccsOnIndividualCafs = lookUp FSLIT("-fauto-sccs-on-individual-cafs") +opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling") +opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky") + +-- language opts +opt_DictsStrict = lookUp FSLIT("-fdicts-strict") +opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") +opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH +opt_Parallel = lookUp FSLIT("-fparallel") +opt_Flatten = lookUp FSLIT("-fflatten") + +-- optimisation opts +opt_NoStateHack = lookUp FSLIT("-fno-state-hack") +opt_NoMethodSharing = lookUp FSLIT("-fno-method-sharing") +opt_CprOff = lookUp FSLIT("-fcpr-off") +opt_RulesOff = lookUp FSLIT("-frules-off") + -- Switch off CPR analysis in the new demand analyser +opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) +opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) + +opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") +opt_GranMacros = lookUp FSLIT("-fgransim") +opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Int +opt_HistorySize = lookup_def_int "-fhistory-size" 20 +opt_OmitBlackHoling = lookUp FSLIT("-dno-black-holing") +opt_RuntimeTypes = lookUp FSLIT("-fruntime-types") + +-- Simplifier switches +opt_SimplNoPreInlining = lookUp FSLIT("-fno-pre-inlining") + -- NoPreInlining is there just to see how bad things + -- get if you don't do it! +opt_SimplExcessPrecision = lookUp FSLIT("-fexcess-precision") + +-- Unfolding control +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn +opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) +opt_UF_UpdateInPlace = lookUp FSLIT("-funfolding-update-in-place") + +opt_UF_DearOp = ( 4 :: Int) + +opt_Static = lookUp FSLIT("-static") +opt_Unregisterised = lookUp FSLIT("-funregisterised") +opt_EmitExternalCore = lookUp FSLIT("-fext-core") + +-- Include full span info in error messages, instead of just the start position. +opt_ErrorSpans = lookUp FSLIT("-ferror-spans") + +opt_PIC = lookUp FSLIT("-fPIC") + +-- object files and libraries to be linked in are collected here. +-- ToDo: perhaps this could be done without a global, it wasn't obvious +-- how to do it though --SDM. +GLOBAL_VAR(v_Ld_inputs, [], [String]) + +isStaticFlag f = + f `elem` [ + "fauto-sccs-on-all-toplevs", + "fauto-sccs-on-exported-toplevs", + "fauto-sccs-on-individual-cafs", + "fscc-profiling", + "fticky-ticky", + "fall-strict", + "fdicts-strict", + "firrefutable-tuples", + "fparallel", + "fflatten", + "fsemi-tagging", + "flet-no-escape", + "femit-extern-decls", + "fglobalise-toplev-names", + "fgransim", + "fno-hi-version-check", + "dno-black-holing", + "fno-method-sharing", + "fno-state-hack", + "fruntime-types", + "fno-pre-inlining", + "fexcess-precision", + "funfolding-update-in-place", + "static", + "funregisterised", + "fext-core", + "frule-check", + "frules-off", + "fcpr-off", + "ferror-spans", + "fPIC" + ] + || any (flip prefixMatch f) [ + "fcontext-stack", + "fliberate-case-threshold", + "fmax-worker-args", + "fhistory-size", + "funfolding-creation-threshold", + "funfolding-use-threshold", + "funfolding-fun-discount", + "funfolding-keeness-factor" + ] + + + +-- Misc functions for command-line options + +startsWith :: String -> String -> Maybe String +-- startsWith pfx (pfx++rest) = Just rest + +startsWith [] str = Just str +startsWith (c:cs) (s:ss) + = if c /= s then Nothing else startsWith cs ss +startsWith _ [] = Nothing + + +----------------------------------------------------------------------------- +-- convert sizes like "3.5M" into integers + +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwDyn (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = read m :: Double + pred c = isDigit c || c == '.' + + +----------------------------------------------------------------------------- +-- RTS Hooks + +#if __GLASGOW_HASKELL__ >= 504 +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () +#else +foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO () +foreign import "enableTimingStats" unsafe enableTimingStats :: IO () +#endif + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+ticky-ticky. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +GLOBAL_VAR(v_Build_tag, "", String) + +-- The RTS has its own build tag, because there are some ways that +-- affect the RTS only. +GLOBAL_VAR(v_RTS_Build_tag, "", String) + +data WayName + = WayThreaded + | WayDebug + | WayProf + | WayUnreg + | WayTicky + | WayPar + | WayGran + | WayNDP + | WayUser_a + | WayUser_b + | WayUser_c + | WayUser_d + | WayUser_e + | WayUser_f + | WayUser_g + | WayUser_h + | WayUser_i + | WayUser_j + | WayUser_k + | WayUser_l + | WayUser_m + | WayUser_n + | WayUser_o + | WayUser_A + | WayUser_B + deriving (Eq,Ord) + +GLOBAL_VAR(v_Ways, [] ,[WayName]) + +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + WayThreaded `allowedWith` WayProf = True + WayProf `allowedWith` WayUnreg = True + WayProf `allowedWith` WayNDP = True + _ `allowedWith` _ = False + + +findBuildTag :: IO [String] -- new options +findBuildTag = do + way_names <- readIORef v_Ways + let ws = sort way_names + if not (allowed_combination ws) + then throwDyn (CmdLineError $ + "combination not supported: " ++ + foldr1 (\a b -> a ++ '/':b) + (map (wayName . lkupWay) ws)) + else let ways = map lkupWay ws + tag = mkBuildTag (filter (not.wayRTSOnly) ways) + rts_tag = mkBuildTag ways + flags = map wayOpts ways + in do + writeIORef v_Build_tag tag + writeIORef v_RTS_Build_tag rts_tag + return (concat flags) + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +lkupWay w = + case lookup w way_details of + Nothing -> error "findBuildTag" + Just details -> details + +data Way = Way { + wayTag :: String, + wayRTSOnly :: Bool, + wayName :: String, + wayOpts :: [String] + } + +way_details :: [ (WayName, Way) ] +way_details = + [ (WayThreaded, Way "thr" True "Threaded" [ +#if defined(freebsd_TARGET_OS) + "-optc-pthread" + , "-optl-pthread" +#endif + ] ), + + (WayDebug, Way "debug" True "Debug" [] ), + + (WayProf, Way "p" False "Profiling" + [ "-fscc-profiling" + , "-DPROFILING" + , "-optc-DPROFILING" ]), + + (WayTicky, Way "t" False "Ticky-ticky Profiling" + [ "-fticky-ticky" + , "-DTICKY_TICKY" + , "-optc-DTICKY_TICKY" ]), + + (WayUnreg, Way "u" False "Unregisterised" + unregFlags ), + + -- optl's below to tell linker where to find the PVM library -- HWL + (WayPar, Way "mp" False "Parallel" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ]), + + -- at the moment we only change the RTS and could share compiler and libs! + (WayPar, Way "mt" False "Parallel ticky profiling" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-optc-DPAR" + , "-optc-DPAR_TICKY" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ]), + + (WayPar, Way "md" False "Distributed" + [ "-fparallel" + , "-D__PARALLEL_HASKELL__" + , "-D__DISTRIBUTED_HASKELL__" + , "-optc-DPAR" + , "-optc-DDIST" + , "-package concurrent" + , "-optc-w" + , "-optl-L${PVM_ROOT}/lib/${PVM_ARCH}" + , "-optl-lpvm3" + , "-optl-lgpvm3" ]), + + (WayGran, Way "mg" False "GranSim" + [ "-fgransim" + , "-D__GRANSIM__" + , "-optc-DGRAN" + , "-package concurrent" ]), + + (WayNDP, Way "ndp" False "Nested data parallelism" + [ "-fparr" + , "-fflatten"]), + + (WayUser_a, Way "a" False "User way 'a'" ["$WAY_a_REAL_OPTS"]), + (WayUser_b, Way "b" False "User way 'b'" ["$WAY_b_REAL_OPTS"]), + (WayUser_c, Way "c" False "User way 'c'" ["$WAY_c_REAL_OPTS"]), + (WayUser_d, Way "d" False "User way 'd'" ["$WAY_d_REAL_OPTS"]), + (WayUser_e, Way "e" False "User way 'e'" ["$WAY_e_REAL_OPTS"]), + (WayUser_f, Way "f" False "User way 'f'" ["$WAY_f_REAL_OPTS"]), + (WayUser_g, Way "g" False "User way 'g'" ["$WAY_g_REAL_OPTS"]), + (WayUser_h, Way "h" False "User way 'h'" ["$WAY_h_REAL_OPTS"]), + (WayUser_i, Way "i" False "User way 'i'" ["$WAY_i_REAL_OPTS"]), + (WayUser_j, Way "j" False "User way 'j'" ["$WAY_j_REAL_OPTS"]), + (WayUser_k, Way "k" False "User way 'k'" ["$WAY_k_REAL_OPTS"]), + (WayUser_l, Way "l" False "User way 'l'" ["$WAY_l_REAL_OPTS"]), + (WayUser_m, Way "m" False "User way 'm'" ["$WAY_m_REAL_OPTS"]), + (WayUser_n, Way "n" False "User way 'n'" ["$WAY_n_REAL_OPTS"]), + (WayUser_o, Way "o" False "User way 'o'" ["$WAY_o_REAL_OPTS"]), + (WayUser_A, Way "A" False "User way 'A'" ["$WAY_A_REAL_OPTS"]), + (WayUser_B, Way "B" False "User way 'B'" ["$WAY_B_REAL_OPTS"]) + ] + +unregFlags = + [ "-optc-DNO_REGS" + , "-optc-DUSE_MINIINTERPRETER" + , "-fno-asm-mangling" + , "-funregisterised" + , "-fvia-C" ] diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs new file mode 100644 index 0000000000..eee3e1a383 --- /dev/null +++ b/compiler/main/SysTools.lhs @@ -0,0 +1,817 @@ +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2003 +-- +-- Access to system tools: gcc, cp, rm etc +-- +----------------------------------------------------------------------------- + +\begin{code} +module SysTools ( + -- Initialisation + initSysTools, + + getTopDir, -- IO String -- The value of $topdir + getPackageConfigPath, -- IO String -- Where package.conf is + getUsageMsgPaths, -- IO (String,String) + + -- Interface to system tools + runUnlit, runCpp, runCc, -- [Option] -> IO () + runPp, -- [Option] -> IO () + runMangle, runSplit, -- [Option] -> IO () + runAs, runLink, -- [Option] -> IO () + runMkDLL, + + touch, -- String -> String -> IO () + copy, -- String -> String -> String -> IO () + normalisePath, -- FilePath -> FilePath + + -- Temporary-file management + setTmpDir, + newTempName, + cleanTempFiles, cleanTempFilesExcept, + addFilesToClean, + + -- System interface + system, -- String -> IO ExitCode + + -- Misc + getSysMan, -- IO String Parallel system only + + Option(..) + + ) where + +#include "HsVersions.h" + +import DriverPhases ( isHaskellUserSrcFilename ) +import Config +import Outputable +import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages ) +import Panic ( GhcException(..) ) +import Util ( Suffix, global, notNull, consIORef, joinFileName, + normalisePath, pgmPath, platformPath, joinFileExt ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, Option(..), + setTmpDir, defaultDynFlags ) + +import EXCEPTION ( throwDyn, finally ) +import DATA_IOREF ( IORef, readIORef, writeIORef ) +import DATA_INT + +import Monad ( when, unless ) +import System ( ExitCode(..), getEnv, system ) +import IO ( try, catch, hGetContents, + openFile, hPutStr, hClose, hFlush, IOMode(..), + stderr, ioError, isDoesNotExistError ) +import Directory ( doesFileExist, removeFile ) +import Maybe ( isJust ) +import List ( partition ) + +-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command +-- lines on mingw32, so we disallow it now. +#if __GLASGOW_HASKELL__ < 500 +#error GHC >= 5.00 is required for bootstrapping GHC +#endif + +#ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ > 504 +import qualified System.Posix.Internals +#else +import qualified Posix +#endif +#else /* Must be Win32 */ +import List ( isPrefixOf ) +import Util ( dropList ) +import Foreign +import CString ( CString, peekCString ) +#endif + +import Text.Regex + +#if __GLASGOW_HASKELL__ < 603 +-- rawSystem comes from libghccompat.a in stage1 +import Compat.RawSystem ( rawSystem ) +import GHC.IOBase ( IOErrorType(..) ) +import System.IO.Error ( ioeGetErrorType ) +#else +import System.Process ( runInteractiveProcess, getProcessExitCode ) +import System.IO ( hSetBuffering, hGetLine, BufferMode(..) ) +import Control.Concurrent( forkIO, newChan, readChan, writeChan ) +import Data.Char ( isSpace ) +import FastString ( mkFastString ) +import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) +#endif +\end{code} + + + The configuration story + ~~~~~~~~~~~~~~~~~~~~~~~ + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It finds these in one +of two places: + +* When running as an *installed program*, GHC finds most of this support + stuff in the installed library tree. The path to this tree is passed + to GHC via the -B flag, and given to initSysTools . + +* When running *in-place* in a build tree, GHC finds most of this support + stuff in the build tree. The path to the build tree is, again passed + to GHC via -B. + +GHC tells which of the two is the case by seeing whether package.conf +is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack). + + +SysTools.initSysProgs figures out exactly where all the auxiliary programs +are, and initialises mutable variables to make it easy to call them. +To to this, it makes use of definitions in Config.hs, which is a Haskell +file containing variables whose value is figured out by the build system. + +Config.hs contains two sorts of things + + cGCC, The *names* of the programs + cCPP e.g. cGCC = gcc + cUNLIT cCPP = gcc -E + etc They do *not* include paths + + + cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc + cSPLIT_DIR_REL *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) + + + +--------------------------------------------- +NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): + +Another hair-brained scheme for simplifying the current tool location +nightmare in GHC: Simon originally suggested using another +configuration file along the lines of GCC's specs file - which is fine +except that it means adding code to read yet another configuration +file. What I didn't notice is that the current package.conf is +general enough to do this: + +Package + {name = "tools", import_dirs = [], source_dirs = [], + library_dirs = [], hs_libraries = [], extra_libraries = [], + include_dirs = [], c_includes = [], package_deps = [], + extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.], + extra_cc_opts = [], extra_ld_opts = []} + +Which would have the advantage that we get to collect together in one +place the path-specific package stuff with the path-specific tool +stuff. + End of NOTES +--------------------------------------------- + + +%************************************************************************ +%* * +\subsection{Global variables to contain system programs} +%* * +%************************************************************************ + +All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE. +(See remarks under pathnames below) + +\begin{code} +GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch +GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp + +GLOBAL_VAR(v_Path_package_config, error "path_package_config", String) +GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String)) + +GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir> + +-- Parallel system only +GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager + +-- ways to get at some of these variables from outside this module +getPackageConfigPath = readIORef v_Path_package_config +getTopDir = readIORef v_TopDir +\end{code} + + +%************************************************************************ +%* * +\subsection{Initialisation} +%* * +%************************************************************************ + +\begin{code} +initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) + + -> DynFlags + -> IO DynFlags -- Set all the mutable variables above, holding + -- (a) the system programs + -- (b) the package-config file + -- (c) the GHC usage message + + +initSysTools mbMinusB dflags + = do { (am_installed, top_dir) <- findTopDir mbMinusB + ; writeIORef v_TopDir top_dir + -- top_dir + -- for "installed" this is the root of GHC's support files + -- for "in-place" it is the root of the build tree + -- NB: top_dir is assumed to be in standard Unix format '/' separated + + ; let installed, installed_bin :: FilePath -> FilePath + installed_bin pgm = pgmPath top_dir pgm + installed file = pgmPath top_dir file + inplace dir pgm = pgmPath (top_dir `joinFileName` + cPROJECT_DIR `joinFileName` dir) pgm + + ; let pkgconfig_path + | am_installed = installed "package.conf" + | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" + + ghc_usage_msg_path + | am_installed = installed "ghc-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" + + ghci_usage_msg_path + | am_installed = installed "ghci-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt" + + -- For all systems, unlit, split, mangle are GHC utilities + -- architecture-specific stuff is done when building Config.hs + unlit_path + | am_installed = installed_bin cGHC_UNLIT_PGM + | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM + + -- split and mangle are Perl scripts + split_script + | am_installed = installed_bin cGHC_SPLIT_PGM + | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM + + mangle_script + | am_installed = installed_bin cGHC_MANGLER_PGM + | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM + + ; let dflags0 = defaultDynFlags +#ifndef mingw32_HOST_OS + -- check whether TMPDIR is set in the environment + ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set +#else + -- On Win32, consult GetTempPath() for a temp dir. + -- => it first tries TMP, TEMP, then finally the + -- Windows directory(!). The directory is in short-path + -- form. + ; e_tmpdir <- + IO.try (do + let len = (2048::Int) + buf <- mallocArray len + ret <- getTempPath len buf + if ret == 0 then do + -- failed, consult TMPDIR. + free buf + getEnv "TMPDIR" + else do + s <- peekCString buf + free buf + return s) +#endif + ; let dflags1 = case e_tmpdir of + Left _ -> dflags0 + Right d -> setTmpDir d dflags0 + + -- Check that the package config exists + ; config_exists <- doesFileExist pkgconfig_path + ; when (not config_exists) $ + throwDyn (InstallationError + ("Can't find package.conf as " ++ pkgconfig_path)) + +#if defined(mingw32_HOST_OS) + -- WINDOWS-SPECIFIC STUFF + -- On Windows, gcc and friends are distributed with GHC, + -- so when "installed" we look in TopDir/bin + -- When "in-place" we look wherever the build-time configure + -- script found them + -- When "install" we tell gcc where its specs file + exes are (-B) + -- and also some places to pick up include files. We need + -- to be careful to put all necessary exes in the -B place + -- (as, ld, cc1, etc) since if they don't get found there, gcc + -- then tries to run unadorned "as", "ld", etc, and will + -- pick up whatever happens to be lying around in the path, + -- possibly including those from a cygwin install on the target, + -- which is exactly what we're trying to avoid. + ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/") + (gcc_prog,gcc_args) + | am_installed = (installed_bin "gcc", [gcc_b_arg]) + | otherwise = (cGCC, []) + -- The trailing "/" is absolutely essential; gcc seems + -- to construct file names simply by concatenating to + -- this -B path with no extra slash We use "/" rather + -- than "\\" because otherwise "\\\" is mangled + -- later on; although gcc_args are in NATIVE format, + -- gcc can cope + -- (see comments with declarations of global variables) + -- + -- The quotes round the -B argument are in case TopDir + -- has spaces in it + + perl_path | am_installed = installed_bin cGHC_PERL + | otherwise = cGHC_PERL + + -- 'touch' is a GHC util for Windows, and similarly unlit, mangle + ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM + | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM + + -- On Win32 we don't want to rely on #!/bin/perl, so we prepend + -- a call to Perl to get the invocation of split and mangle + ; let (split_prog, split_args) = (perl_path, [Option split_script]) + (mangle_prog, mangle_args) = (perl_path, [Option mangle_script]) + + ; let (mkdll_prog, mkdll_args) + | am_installed = + (pgmPath (installed "gcc-lib/") cMKDLL, + [ Option "--dlltool-name", + Option (pgmPath (installed "gcc-lib/") "dlltool"), + Option "--driver-name", + Option gcc_prog, gcc_b_arg ]) + | otherwise = (cMKDLL, []) +#else + -- UNIX-SPECIFIC STUFF + -- On Unix, the "standard" tools are assumed to be + -- in the same place whether we are running "in-place" or "installed" + -- That place is wherever the build-time configure script found them. + ; let gcc_prog = cGCC + gcc_args = [] + touch_path = "touch" + mkdll_prog = panic "Can't build DLLs on a non-Win32 system" + mkdll_args = [] + + -- On Unix, scripts are invoked using the '#!' method. Binary + -- installations of GHC on Unix place the correct line on the front + -- of the script at installation time, so we don't want to wire-in + -- our knowledge of $(PERL) on the host system here. + ; let (split_prog, split_args) = (split_script, []) + (mangle_prog, mangle_args) = (mangle_script, []) +#endif + + -- cpp is derived from gcc on all platforms + -- HACK, see setPgmP below. We keep 'words' here to remember to fix + -- Config.hs one day. + ; let cpp_path = (gcc_prog, gcc_args ++ + (Option "-E"):(map Option (words cRAWCPP_FLAGS))) + + -- For all systems, copy and remove are provided by the host + -- system; architecture-specific stuff is done when building Config.hs + ; let cp_path = cGHC_CP + + -- Other things being equal, as and ld are simply gcc + ; let (as_prog,as_args) = (gcc_prog,gcc_args) + (ld_prog,ld_args) = (gcc_prog,gcc_args) + + -- Initialise the global vars + ; writeIORef v_Path_package_config pkgconfig_path + ; writeIORef v_Path_usages (ghc_usage_msg_path, + ghci_usage_msg_path) + + ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan") + -- Hans: this isn't right in general, but you can + -- elaborate it in the same way as the others + + ; writeIORef v_Pgm_T touch_path + ; writeIORef v_Pgm_CP cp_path + + ; return dflags1{ + pgm_L = unlit_path, + pgm_P = cpp_path, + pgm_F = "", + pgm_c = (gcc_prog,gcc_args), + pgm_m = (mangle_prog,mangle_args), + pgm_s = (split_prog,split_args), + pgm_a = (as_prog,as_args), + pgm_l = (ld_prog,ld_args), + pgm_dll = (mkdll_prog,mkdll_args) } + } + +#if defined(mingw32_HOST_OS) +foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32 +#endif +\end{code} + +\begin{code} +-- Find TopDir +-- for "installed" this is the root of GHC's support files +-- for "in-place" it is the root of the build tree +-- +-- Plan of action: +-- 1. Set proto_top_dir +-- if there is no given TopDir path, get the directory +-- where GHC is running (only on Windows) +-- +-- 2. If package.conf exists in proto_top_dir, we are running +-- installed; and TopDir = proto_top_dir +-- +-- 3. Otherwise we are running in-place, so +-- proto_top_dir will be /...stuff.../ghc/compiler +-- Set TopDir to /...stuff..., which is the root of the build tree +-- +-- This is very gruesome indeed + +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO (Bool, -- True <=> am installed, False <=> in-place + String) -- TopDir (in Unix format '/' separated) + +findTopDir mbMinusB + = do { top_dir <- get_proto + -- Discover whether we're running in a build tree or in an installation, + -- by looking for the package configuration file. + ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf") + + ; return (am_installed, top_dir) + } + where + -- get_proto returns a Unix-format path (relying on getBaseDir to do so too) + get_proto = case mbMinusB of + Just minusb -> return (normalisePath minusb) + Nothing + -> do maybe_exec_dir <- getBaseDir -- Get directory of executable + case maybe_exec_dir of -- (only works on Windows; + -- returns Nothing on Unix) + Nothing -> throwDyn (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 p = pgm_L dflags + runSomething dflags "Literate pre-processor" p args + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = do + let (p,args0) = pgm_P dflags + runSomething dflags "C pre-processor" p (args0 ++ args) + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = do + let p = pgm_F dflags + runSomething dflags "Haskell pre-processor" p args + +runCc :: DynFlags -> [Option] -> IO () +runCc dflags args = do + let (p,args0) = pgm_c dflags + runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args) + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter str = unlines (do_filter (lines str)) + + do_filter [] = [] + do_filter ls@(l:ls') + | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls, + isJust (matchRegex r_warn w) + = do_filter rest + | otherwise + = l : do_filter ls' + + r_from = mkRegex "from.*:[0-9]+" + r_warn = mkRegex "warning: call-clobbered register used" + +runMangle :: DynFlags -> [Option] -> IO () +runMangle dflags args = do + let (p,args0) = pgm_m dflags + runSomething dflags "Mangler" p (args0++args) + +runSplit :: DynFlags -> [Option] -> IO () +runSplit dflags args = do + let (p,args0) = pgm_s dflags + runSomething dflags "Splitter" p (args0++args) + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = do + let (p,args0) = pgm_a dflags + runSomething dflags "Assembler" p (args0++args) + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = do + let (p,args0) = pgm_l dflags + runSomething dflags "Linker" p (args0++args) + +runMkDLL :: DynFlags -> [Option] -> IO () +runMkDLL dflags args = do + let (p,args0) = pgm_dll dflags + runSomething dflags "Make DLL" p (args0++args) + +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = do + p <- readIORef v_Pgm_T + runSomething dflags purpose p [FileOption "" arg] + +copy :: DynFlags -> String -> String -> String -> IO () +copy dflags purpose from to = do + showPass dflags purpose + + h <- openFile to WriteMode + ls <- readFile from -- inefficient, but it'll do for now. + -- ToDo: speed up via slurping. + hPutStr h ls + hClose h + +\end{code} + +\begin{code} +getSysMan :: IO String -- How to invoke the system manager + -- (parallel system only) +getSysMan = readIORef v_Pgm_sysman +\end{code} + +\begin{code} +getUsageMsgPaths :: IO (FilePath,FilePath) + -- the filenames of the usage messages (ghc, ghci) +getUsageMsgPaths = readIORef v_Path_usages +\end{code} + + +%************************************************************************ +%* * +\subsection{Managing temporary files +%* * +%************************************************************************ + +\begin{code} +GLOBAL_VAR(v_FilesToClean, [], [String] ) +\end{code} + +\begin{code} +cleanTempFiles :: DynFlags -> IO () +cleanTempFiles dflags + = do fs <- readIORef v_FilesToClean + removeTmpFiles dflags fs + writeIORef v_FilesToClean [] + +cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () +cleanTempFilesExcept dflags dont_delete + = do files <- readIORef v_FilesToClean + let (to_keep, to_delete) = partition (`elem` dont_delete) files + removeTmpFiles dflags to_delete + writeIORef v_FilesToClean to_keep + + +-- find a temporary name that doesn't already exist. +newTempName :: DynFlags -> Suffix -> IO FilePath +newTempName DynFlags{tmpDir=tmp_dir} extn + = do x <- getProcessID + findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0 + where + findTempName prefix x + = do let filename = (prefix ++ show x) `joinFileExt` extn + b <- doesFileExist filename + if b then findTempName prefix (x+1) + else do consIORef v_FilesToClean filename -- clean it up later + return filename + +addFilesToClean :: [FilePath] -> IO () +-- May include wildcards [used by DriverPipeline.run_phase SplitMangle] +addFilesToClean files = mapM_ (consIORef v_FilesToClean) files + +removeTmpFiles :: DynFlags -> [FilePath] -> IO () +removeTmpFiles dflags fs + = warnNon $ + traceCmd dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ rm deletees) + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + + rm f = removeFile f `IO.catch` + (\_ignored -> + debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f) + ) + + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: DynFlags + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args = do + let real_args = filter notNull (map showOpt args) + traceCmd dflags phase_name (unwords (pgm:real_args)) $ do + (exit_code, doesn'tExist) <- + IO.catch (do + rc <- builderMainLoop dflags filter_fn pgm real_args + case rc of + ExitSuccess{} -> return (rc, False) + ExitFailure n + -- rawSystem returns (ExitFailure 127) if the exec failed for any + -- reason (eg. the program doesn't exist). This is the only clue + -- we have, but we need to report something to the user because in + -- the case of a missing program there will otherwise be no output + -- at all. + | n == 127 -> return (rc, True) + | otherwise -> return (rc, False)) + -- Should 'rawSystem' generate an IO exception indicating that + -- 'pgm' couldn't be run rather than a funky return code, catch + -- this here (the win32 version does this, but it doesn't hurt + -- to test for this in general.) + (\ err -> + if IO.isDoesNotExistError err +#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604 + -- the 'compat' version of rawSystem under mingw32 always + -- maps 'errno' to EINVAL to failure. + || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False} +#endif + then return (ExitFailure 1, True) + else IO.ioError err) + case (doesn'tExist, exit_code) of + (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm)) + (_, ExitSuccess) -> return () + _ -> throwDyn (PhaseFailed phase_name exit_code) + + + +#if __GLASGOW_HASKELL__ < 603 +builderMainLoop dflags filter_fn pgm real_args = do + rawSystem pgm real_args +#else +builderMainLoop dflags filter_fn pgm real_args = do + chan <- newChan + (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing + + -- and run a loop piping the output from the compiler to the log_action in DynFlags + hSetBuffering hStdOut LineBuffering + hSetBuffering hStdErr LineBuffering + forkIO (readerProc chan hStdOut filter_fn) + forkIO (readerProc chan hStdErr filter_fn) + rc <- loop chan hProcess 2 1 ExitSuccess + hClose hStdIn + hClose hStdOut + hClose hStdErr + return rc + where + -- status starts at zero, and increments each time either + -- a reader process gets EOF, or the build proc exits. We wait + -- for all of these to happen (status==3). + -- ToDo: we should really have a contingency plan in case any of + -- the threads dies, such as a timeout. + loop chan hProcess 0 0 exitcode = return exitcode + loop chan hProcess t p exitcode = do + mb_code <- if p > 0 + then getProcessExitCode hProcess + else return Nothing + case mb_code of + Just code -> loop chan hProcess t (p-1) code + Nothing + | t > 0 -> do + msg <- readChan chan + case msg of + BuildMsg msg -> do + log_action dflags SevInfo noSrcSpan defaultUserStyle msg + loop chan hProcess t p exitcode + BuildError loc msg -> do + log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + loop chan hProcess t p exitcode + EOF -> + loop chan hProcess (t-1) p exitcode + | otherwise -> loop chan hProcess t p exitcode + +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (lines (filter_fn str)) Nothing) + `finally` + writeChan chan EOF + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. + where + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + + checkError l ls + = case matchRegex errRegex l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file':lineno':colno':msg:_) -> do + let file = mkFastString file' + lineno = read lineno'::Int + colno = case colno' of + "" -> 0 + _ -> read (init colno') :: Int + srcLoc = mkSrcLoc file lineno colno + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)" + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc + | EOF +#endif + +showOpt (FileOption pre f) = pre ++ platformPath f +showOpt (Option "") = "" +showOpt (Option s) = s + +traceCmd :: DynFlags -> String -> String -> IO () -> IO () +-- a) trace the command (at two levels of verbosity) +-- b) don't do it at all if dry-run is set +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; hFlush stderr + + -- Test for -n flag + ; unless (dopt Opt_DryRun dflags) $ do { + + -- And run it! + ; action `IO.catch` handle_exn verb + }} + where + handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn)) + ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) } +\end{code} + +%************************************************************************ +%* * +\subsection{Support code} +%* * +%************************************************************************ + +\begin{code} +----------------------------------------------------------------------------- +-- Define getBaseDir :: IO (Maybe String) + +getBaseDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +-- Assuming we are running ghc, accessed by path $()/bin/ghc.exe, +-- return the path $(stuff). Note that we drop the "bin/" directory too. +getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. + buf <- mallocArray len + ret <- getModuleFileName nullPtr buf len + if ret == 0 then free buf >> return Nothing + else do s <- peekCString buf + free buf + return (Just (rootDir s)) + where + rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s))) + +foreign import stdcall unsafe "GetModuleFileNameA" + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +#else +getBaseDir = return Nothing +#endif + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +#elif __GLASGOW_HASKELL__ > 504 +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#else +getProcessID :: IO Int +getProcessID = Posix.getProcessID +#endif + +\end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs new file mode 100644 index 0000000000..86e55f9e06 --- /dev/null +++ b/compiler/main/TidyPgm.lhs @@ -0,0 +1,816 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Tidying up Core} + +\begin{code} +module TidyPgm( mkBootModDetails, tidyProgram ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlag(..), dopt ) +import Packages ( HomeModules ) +import CoreSyn +import CoreUnfold ( noUnfolding, mkTopUnfolding ) +import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) +import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules ) +import PprCore ( pprRules ) +import CoreLint ( showPass, endPass ) +import CoreUtils ( exprArity, rhsIsStatic ) +import VarEnv +import VarSet +import Var ( Id, Var ) +import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, + isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector, + idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo + ) +import IdInfo {- loads of stuff -} +import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) +import NewDemand ( isBottomingSig, topSig ) +import BasicTypes ( Arity, isNeverActive ) +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe, + isWiredInName, getName + ) +import NameSet ( NameSet, elemNameSet ) +import IfaceEnv ( allocateGlobalBinder ) +import NameEnv ( filterNameEnv, mapNameEnv ) +import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) +import Type ( tidyTopType ) +import TcType ( isFFITy ) +import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe ) +import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, + newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon ) +import Class ( classSelIds ) +import Module ( Module ) +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), + TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, + extendTypeEnvWithIds, lookupTypeEnv, + ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) + ) +import Maybes ( orElse, mapCatMaybes ) +import ErrUtils ( showPass, dumpIfSet_core ) +import UniqSupply ( splitUniqSupply, uniqFromSupply ) +import List ( partition ) +import Maybe ( isJust ) +import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) +import FastTypes hiding ( fastOr ) +\end{code} + + +Constructing the TypeEnv, Instances, Rules from which the ModIface is +constructed, and which goes on to subsequent modules in --make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +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 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Caf and Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +\begin{code} +mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails +-- 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 +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetails hsc_env (ModGuts { mg_module = mod, + mg_exports = exports, + mg_types = type_env, + mg_insts = ispecs }) + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy [hoot] type env" + + ; let { ispecs' = tidyInstances tidyExternalId ispecs + ; type_env1 = filterNameEnv (not . isWiredInThing) type_env + ; type_env2 = mapNameEnv tidyBootThing type_env1 + ; type_env' = extendTypeEnvWithIds type_env2 + (map instanceDFunId ispecs') + } + ; return (ModDetails { md_types = type_env', + md_insts = ispecs', + md_rules = [], + md_exports = exports }) + } + where + +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) + +tidyBootThing :: TyThing -> TyThing +-- Just externalise the Ids; keep everything +tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id) +tidyBootThing thing = thing + +tidyExternalId :: Id -> Id +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId with VanillaIdInfo, and tidies its type +-- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) +tidyExternalId id + = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) + mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo +\end{code} + + +%************************************************************************ +%* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +%* * +%************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Figure out which Ids are externally visible + +* Tidy the bindings, externalising appropriate Ids + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Step 1: Figure out external Ids +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) ones mentioned in the unfoldings, workers, + or rules of externally-visible ones +This exercise takes a sweep of the bindings bottom to top. Actually, +in Step 2 we're also going to need to know which Ids should be +exported with their unfoldings, so we produce not an IdSet but an +IdEnv Bool + + +Step 2: Tidy the program +~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the NameCache kept in the HscEnv as the + source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. + This is used by the code generator to decide whether + to make the label externally visible + + 4. Give external Ids a "tidy" OccName. This means + we can print them in interface files without confusing + "x" (unique 5) with "x" (unique 10). + + 5. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS + + +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 + mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, + mg_types = type_env, mg_insts = insts_tc, + mg_binds = binds, + mg_rules = imp_rules, + mg_dir_imps = dir_imps, mg_deps = deps, + mg_home_mods = home_mods, + mg_foreign = foreign_stubs }) + + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy Core" + + ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; ext_ids = findExternalIds omit_prags binds + ; ext_rules + | omit_prags = [] + | otherwise = findExternalRules binds imp_rules ext_ids + -- findExternalRules filters imp_rules to avoid binders that + -- aren't externally visible; but the externally-visible binders + -- are computed (by findExternalIds) assuming that all orphan + -- rules are exported (they get their Exported flag set in the desugarer) + -- So in fact we may export more than we need. + -- (It's a sort of mutual recursion.) + } + + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds + + ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds + ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc + -- A DFunId will have a binding in tidy_binds, and so + -- will now be in final_env, replete with IdInfo + -- Its name will be unchanged since it was born, but + -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs + + ; tidy_rules = tidyRules tidy_env ext_rules + -- You might worry that the tidy_env contains IdInfo-rich stuff + -- and indeed it does, but if omit_prags is on, ext_rules is empty + + ; implicit_binds = getImplicitBinds type_env + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + } + + ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; dumpIfSet_core dflags Opt_D_dump_simpl + "Tidy Core Rules" + (pprRules tidy_rules) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = implicit_binds ++ tidy_binds, + cg_dir_imps = dir_imps, + cg_foreign = foreign_stubs, + cg_home_mods = home_mods, + cg_dep_pkgs = dep_pkgs deps }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_ispecs, + md_exports = exports }) + } + +lookup_dfun type_env dfun_id + = case lookupTypeEnv type_env (idName dfun_id) of + Just (AnId dfun_id') -> dfun_id' + other -> pprPanic "lookup_dfun" (ppr dfun_id) + +tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv + +-- The competed type environment is gotten from +-- Dropping any wired-in things, and then +-- a) keeping the types and classes +-- b) removing all Ids, +-- c) adding Ids with correct IdInfo, including unfoldings, +-- gotten from the bindings +-- From (c) we keep only those Ids with External names; +-- the CoreTidy pass makes sure these are all and only +-- the externally-accessible ones +-- This truncates the type environment to include only the +-- exported Ids and things needed from them, which saves space + +tidyTypeEnv omit_prags exports type_env tidy_binds + = let type_env1 = filterNameEnv keep_it type_env + type_env2 = extendTypeEnvWithIds type_env1 final_ids + type_env3 | omit_prags = mapNameEnv trim_thing type_env2 + | otherwise = type_env2 + in + type_env3 + where + final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] + + -- We keep GlobalIds, because they won't appear + -- in the bindings from which final_ids are derived! + -- (The bindings bind LocalIds.) + keep_it thing | isWiredInThing thing = False + keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) + keep_it other = True -- Keep all TyCons, DataCons, and Classes + + trim_thing thing + = case thing of + ATyCon tc | mustExposeTyCon exports tc -> thing + | otherwise -> ATyCon (makeTyConAbstract tc) + + AnId id | isImplicitId id -> thing + | otherwise -> AnId (id `setIdInfo` vanillaIdInfo) + + other -> thing + +mustExposeTyCon :: NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon exports tc + | not (isAlgTyCon tc) -- Synonyms + = True + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + -- (This includes data types with no constructors.) + | otherwise -- Newtype, datatype + = any exported_con (tyConDataCons tc) + -- Expose rep if any datacon or field is exported + + || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + where + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) + +tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] +tidyInstances tidy_dfun ispecs + = map tidy ispecs + where + tidy ispec = setInstanceDFunId ispec $ + tidy_dfun (instanceDFunId ispec) + +getImplicitBinds :: TypeEnv -> [CoreBind] +getImplicitBinds type_env + = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) + ++ concatMap other_implicit_ids (typeEnvElts type_env)) + -- Put the constructor wrappers first, because + -- other implicit bindings (notably the fromT functions arising + -- from generics) use the constructor wrappers. At least that's + -- what External Core likes + where + implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + + other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) + -- The "naughty" ones are not real functions at all + -- They are there just so we can get decent error messages + -- See Note [Naughty record selectors] in MkId.lhs + other_implicit_ids (AClass cl) = classSelIds cl + other_implicit_ids other = [] + + get_defn :: Id -> CoreBind + get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs) + where + rhs = unfoldingTemplate (idUnfolding id) + -- Don't forget to tidy the body ! Otherwise you get silly things like + -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl +\end{code} + + +%************************************************************************ +%* * +\subsection{Step 1: finding externals} +%* * +%************************************************************************ + +\begin{code} +findExternalIds :: Bool + -> [CoreBind] + -> IdEnv Bool -- In domain => external + -- Range = True <=> show unfolding + -- Step 1 from the notes above +findExternalIds omit_prags binds + | omit_prags + = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ] + + | otherwise + = foldr find emptyVarEnv binds + where + find (NonRec id rhs) needed + | need_id needed id = addExternal (id,rhs) needed + | otherwise = needed + find (Rec prs) needed = find_prs prs needed + + -- For a recursive group we have to look for a fixed point + find_prs prs needed + | null needed_prs = needed + | otherwise = find_prs other_prs new_needed + where + (needed_prs, other_prs) = partition (need_pr needed) prs + new_needed = foldr addExternal needed needed_prs + + -- The 'needed' set contains the Ids that are needed by earlier + -- interface file emissions. If the Id isn't in this set, and isn't + -- exported, there's no need to emit anything + need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id + need_pr needed_set (id,rhs) = need_id needed_set id + +addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool +-- The Id is needed; extend the needed set +-- with it and its dependents (free vars etc) +addExternal (id,rhs) needed + = extendVarEnv (foldVarSet add_occ needed new_needed_ids) + id show_unfold + where + add_occ id needed = extendVarEnv needed id False + -- "False" because we don't know we need the Id's unfolding + -- We'll override it later when we find the binding site + + new_needed_ids = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids + + idinfo = idInfo id + dont_inline = isNeverActive (inlinePragInfo idinfo) + loop_breaker = isLoopBreaker (occInfo idinfo) + bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) + spec_ids = specInfoFreeVars (specInfo idinfo) + worker_info = workerInfo idinfo + + -- Stuff to do with the Id's unfolding + -- The simplifier has put an up-to-date unfolding + -- in the IdInfo, but the RHS will do just as well + unfolding = unfoldingInfo idinfo + rhs_is_small = not (neverUnfold unfolding) + + -- We leave the unfolding there even if there is a worker + -- In GHCI the unfolding is used by importers + -- When writing an interface file, we omit the unfolding + -- if there is a worker + show_unfold = not bottoming_fn && -- Not necessary + not dont_inline && + not loop_breaker && + rhs_is_small -- Small enough + + unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs + | otherwise = emptyVarSet + + worker_ids = case worker_info of + HasWorker work_id _ -> unitVarSet work_id + otherwise -> emptyVarSet +\end{code} + + +\begin{code} +findExternalRules :: [CoreBind] + -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) + -> IdEnv a -- Ids that are exported, so we need their rules + -> [CoreRule] + -- The complete rules are gotten by combining + -- a) the non-local rules + -- b) rules embedded in the top-level Ids +findExternalRules binds non_local_rules ext_ids + = filter (not . internal_rule) (non_local_rules ++ local_rules) + where + local_rules = [ rule + | id <- bindersOfBinds binds, + id `elemVarEnv` ext_ids, + rule <- idCoreRules id + ] + + internal_rule rule + = any internal_id (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) + + internal_id id = not (id `elemVarEnv` ext_ids) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Step 2: top-level tidying} +%* * +%************************************************************************ + + +\begin{code} +-- TopTidyEnv: when tidying we need to know +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: HscEnv + -> HomeModules + -> Module + -> TypeEnv + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) + +tidyTopBinds hsc_env hmods mod type_env ext_ids binds + = tidy init_env binds + where + nc_var = hsc_NC hsc_env + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds type_env, + let name = idName bndr, + isExternalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + + tidy env [] = return (env, []) + tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b + ; (env2, bs') <- tidy env1 bs + ; return (env2, b':bs') } + +------------------------ +tidyTopBind :: HomeModules + -> Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) + = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr + ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) + ; subst2 = extendVarEnv subst1 bndr bndr' + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, NonRec bndr' rhs') } + where + caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs + +tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) + = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs + ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) + names' prs + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } + where + bndrs = map fst prs + + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- 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. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- 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. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + | isGlobalId bndr -- Injected binding for record selector, etc + = (bndr, tidyExpr rhs_tidy_env rhs) + | otherwise + = (bndr', rhs') + where + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info + + -- Expose an unfolding if ext_ids tells us to + -- Remember that ext_ids maps an Id to a Bool: + -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr + show_unfold = maybe_external `orElse` False + unfold_info | show_unfold = mkTopUnfolding rhs' + | otherwise = noUnfolding + + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity rhs + + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info. This must also remain valid through to code generation. +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. + +tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setCafInfo` caf_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo + `setInlinePragInfo` inlinePragInfo idinfo + `setUnfoldingInfo` unfold_info + `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + + + +------------ Worker -------------- +tidyWorker tidy_env (HasWorker work_id wrap_arity) + = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity +tidyWorker tidy_env other + = NoWorker +\end{code} + +%************************************************************************ +%* * +\subsection{Figuring out CafInfo for an expression} +%* * +%************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +\begin{code} +hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs hmods p arity expr + | is_caf || mentions_cafs = MayHaveCafRefs + | otherwise = NoCafRefs + where + mentions_cafs = isFastTrue (cafRefs p expr) + is_caf = not (arity > 0 || rhsIsStatic hmods expr) + -- NB. we pass in the arity of the expression, which is expected + -- to be calculated by exprArity. This is because exprArity + -- knows how much eta expansion is going to be done by + -- CorePrep later on, and we don't want to duplicate that + -- knowledge in rhsIsStatic below. + +cafRefs p (Var id) + -- imported Ids first: + | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) + -- now Ids local to this module: + | otherwise = + case lookupVarEnv p id of + Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) + Nothing -> fastBool False + +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a +cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e +cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) +cafRefs p (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es + +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) +\end{code} |