diff options
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} |