From: Simon Marlow Date: Wed, 6 Apr 2011 13:30:59 +0000 (+0100) Subject: Merge branch 'trac_5025' of https://github.com/thoughtpolice/ghc X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6caa417ded740fb8eaa50669269e38c8129092f0;hp=9e27ad106ef7036f356475daa0412ad72b56067b Merge branch 'trac_5025' of https://github.com/thoughtpolice/ghc * 'trac_5025' of https://github.com/thoughtpolice/ghc: Teach GHC to compile objective-c files; trac #5025 Conflicts: compiler/main/DriverPipeline.hs --- diff --git a/.gitignore b/.gitignore index 79629da..bbcff22 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,7 @@ *.o.cmd *.depend* log +tags autom4te.cache config.log diff --git a/aclocal.m4 b/aclocal.m4 index 691fd45..23e6bc0 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -1069,18 +1069,9 @@ AC_SUBST([GhcPkgCmd]) # Determine which extra flags we need to pass gcc when we invoke it # to compile .hc code. # -# Some OSs (Mandrake Linux, in particular) configure GCC with -# -momit-leaf-frame-pointer on by default. If this is the case, we -# need to turn it off for mangling to work. The test is currently a -# bit crude, using only the version number of gcc. -# # -fwrapv is needed for gcc to emit well-behaved code in the presence of # integer wrap around. (Trac #952) # -# -fno-unit-at-a-time or -fno-toplevel-reoder is necessary to avoid gcc -# reordering things in the module and confusing the manger and/or splitter. -# (eg. Trac #1427) -# AC_DEFUN([FP_GCC_EXTRA_FLAGS], [AC_REQUIRE([FP_HAVE_GCC]) AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts], @@ -1088,24 +1079,6 @@ AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_ FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"], []) - case $TargetPlatform in - i386-*|x86_64-*) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer"], - []) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], - [FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time"] - )], - []) - ;; - sparc-*-solaris2) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - []) - ;; - esac ]) AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts) ]) diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 372562c..b9f6db3 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -71,10 +71,10 @@ cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)]) cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = do -- Why bother doing it this early? - -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" + -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads" -- (dualLivenessWithInsertion callPPs) g -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses - -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" -- (removeDeadAssignmentsAndReloads callPPs) g dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g @@ -91,16 +91,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Spills and reloads ------------------- g <- -- pprTrace "pre Spills" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "spills and reloads" + dual_rewrite run Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion procPoints) g -- Insert spills at defns; reloads at return points g <- -- pprTrace "pre insertLateReloads" (ppr g) $ - run $ insertLateReloads g -- Duplicate reloads just before uses + runOptimization $ insertLateReloads g -- Duplicate reloads just before uses dump Opt_D_dump_cmmz "Post late reloads" g g <- -- pprTrace "post insertLateReloads" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" + dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) @@ -146,12 +146,16 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) - - run = runFuelIO (hsc_OptFuel hsc_env) - - dual_rewrite flag txt pass g = + -- Runs a required transformation/analysis + run = runInfiniteFuelIO (hsc_OptFuel hsc_env) + -- Runs an optional transformation/analysis (and should + -- thus be subject to optimization fuel) + runOptimization = runFuelIO (hsc_OptFuel hsc_env) + + -- pass 'run' or 'runOptimization' for 'r' + dual_rewrite r flag txt pass g = do dump flag ("Pre " ++ txt) g - g <- run $ pass g + g <- r $ pass g dump flag ("Post " ++ txt) $ g return g diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0dec26d..c71f188 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -115,12 +115,15 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts cmmMiniInlineStmts uses (stmt:stmts) = stmt : cmmMiniInlineStmts uses stmts -lookForInline u expr (stmt : rest) +lookForInline u expr stmts = lookForInline' u expr regset stmts + where regset = foldRegsUsed extendRegSet emptyRegSet expr + +lookForInline' u expr regset (stmt : rest) | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline = Just (inlineStmt u expr stmt : rest) | ok_to_skip - = case lookForInline u expr rest of + = case lookForInline' u expr regset rest of Nothing -> Nothing Just stmts -> Just (stmt:stmts) @@ -137,13 +140,18 @@ lookForInline u expr (stmt : rest) CmmCall{} -> hasNoGlobalRegs expr _ -> True - -- We can skip over assignments to other tempoararies, because we - -- know that expressions aren't side-effecting and temporaries are - -- single-assignment. + -- Expressions aren't side-effecting. Temporaries may or may not + -- be single-assignment depending on the source (the old code + -- generator creates single-assignment code, but hand-written Cmm + -- and Cmm from the new code generator is not single-assignment.) + -- So we do an extra check to make sure that the register being + -- changed is not one we were relying on. I don't know how much of a + -- performance hit this is (we have to create a regset for every + -- instruction.) -- EZY ok_to_skip = case stmt of CmmNop -> True CmmComment{} -> True - CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True + CmmAssign (CmmLocal r@(LocalReg u' _)) rhs | u' /= u && not (r `elemRegSet` regset) -> True CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr) _other -> False diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 057a965..8d3a06b 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -6,12 +6,12 @@ -- the optimiser with varying amount of fuel to find out the exact number of -- steps where a bug is introduced in the output. module OptimizationFuel - ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel + ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel , OptFuelState, initOptFuelState , FuelConsumer, FuelUsingMonad, FuelState , fuelGet, fuelSet, lastFuelPass, setFuelPass , fuelExhausted, fuelDec1, tryWithFuel - , runFuelIO, fuelConsumingPass + , runFuelIO, runInfiniteFuelIO, fuelConsumingPass , FuelUniqSM , liftUniq ) @@ -51,6 +51,7 @@ amountOfFuel :: OptimizationFuel -> Int anyFuelLeft :: OptimizationFuel -> Bool oneLessFuel :: OptimizationFuel -> OptimizationFuel +unlimitedFuel :: OptimizationFuel #ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int @@ -61,6 +62,7 @@ amountOfFuel (OptimizationFuel f) = f anyFuelLeft (OptimizationFuel f) = f > 0 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) +unlimitedFuel = OptimizationFuel infiniteFuel #else -- type OptimizationFuel = State# () -- would like this, but it won't work data OptimizationFuel = OptimizationFuel @@ -70,6 +72,7 @@ amountOfFuel _ = maxBound anyFuelLeft _ = True oneLessFuel _ = OptimizationFuel +unlimitedFuel = OptimizationFuel #endif data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } @@ -92,6 +95,16 @@ runFuelIO fs (FUSM f) = writeIORef (fuel_ref fs) fuel' return a +-- ToDo: Do we need the pass_ref when we are doing infinite fueld +-- transformations? +runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runInfiniteFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass) + writeIORef (pass_ref fs) pass' + return a + instance Monad FuelUniqSM where FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s') return a = FUSM (\s -> return (a, s)) diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index fe09f68..d617743 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -304,13 +304,15 @@ type DynTag = Int -- The tag on a *pointer* {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors) -can be either: +The family size of a data type (the number of constructors +or the arity of a function) can be either: * small, if the family size < 2**tag_bits * big, otherwise. Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -} +Big families only use the tag value 1 to represent evaluatedness. +We don't have very many tag bits: for example, we have 2 bits on +x86-32 and 3 bits on x86-64. -} isSmallFamily :: Int -> Bool isSmallFamily fam_size = fam_size <= mAX_PTR_TAG diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 0def1c1..357b51c 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -152,10 +152,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@ @echo 'cGHC_UNLIT_DIR :: String' >> $@ @echo 'cGHC_UNLIT_DIR = "$(GHC_UNLIT_DIR)"' >> $@ - @echo 'cGHC_MANGLER_PGM :: String' >> $@ - @echo 'cGHC_MANGLER_PGM = "$(GHC_MANGLER_PGM)"' >> $@ - @echo 'cGHC_MANGLER_DIR :: String' >> $@ - @echo 'cGHC_MANGLER_DIR = "$(GHC_MANGLER_DIR)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @echo 'cGHC_SPLIT_PGM = "$(GHC_SPLIT_PGM)"' >> $@ @echo 'cGHC_SPLIT_DIR :: String' >> $@ diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 85f3402..e9906a6 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -30,6 +30,7 @@ import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config +import SysTools import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable @@ -56,7 +57,7 @@ codeOutput :: DynFlags -> ForeignStubs -> [PackageId] -> [RawCmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -212,18 +213,21 @@ outputJava dflags filenm mod tycons core_binds \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - = case stubs of - NoStubs -> do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> 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) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - ForeignStubs h_code c_code -> do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -266,10 +270,10 @@ outputForeignStubs dflags mod location stubs -- 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 (moduleName mod) location - + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index ee4a756..f6a9738 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -77,7 +77,6 @@ data Phase | Cc | Cobjc | 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 @@ -86,6 +85,7 @@ data Phase | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. @@ -113,7 +113,6 @@ eqPhase Ccpp Ccpp = True eqPhase Cc Cc = True eqPhase Cobjc Cobjc = True eqPhase HCc HCc = True -eqPhase Mangle Mangle = True eqPhase SplitMangle SplitMangle = True eqPhase SplitAs SplitAs = True eqPhase As As = True @@ -122,6 +121,7 @@ eqPhase LlvmLlc LlvmLlc = True eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True eqPhase StopLn StopLn = True eqPhase _ _ = False @@ -135,13 +135,11 @@ x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y after_x = nextPhase x nextPhase :: Phase -> Phase --- A conservative approximation the next phase, used in happensBefore +-- A conservative approximation to the next phase, used in happensBefore nextPhase (Unlit sf) = Cpp sf nextPhase (Cpp sf) = HsPp sf nextPhase (HsPp sf) = Hsc sf nextPhase (Hsc _) = HCc -nextPhase HCc = Mangle -nextPhase Mangle = SplitMangle nextPhase SplitMangle = As nextPhase As = SplitAs nextPhase LlvmOpt = LlvmLlc @@ -151,12 +149,14 @@ nextPhase LlvmLlc = LlvmMangle nextPhase LlvmLlc = As #endif nextPhase LlvmMangle = As -nextPhase SplitAs = StopLn +nextPhase SplitAs = MergeStub nextPhase Ccpp = As nextPhase Cc = As nextPhase Cobjc = As nextPhase CmmCpp = Cmm nextPhase Cmm = HCc +nextPhase HCc = As +nextPhase MergeStub = StopLn nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined @@ -176,7 +176,6 @@ startPhase "C" = Cc startPhase "m" = Cobjc startPhase "cc" = Ccpp startPhase "cxx" = Ccpp -startPhase "raw_s" = Mangle startPhase "split_s" = SplitMangle startPhase "s" = As startPhase "S" = As @@ -205,7 +204,6 @@ phaseInputExt HCc = "hc" phaseInputExt Ccpp = "cpp" phaseInputExt Cobjc = "m" phaseInputExt Cc = "c" -phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" phaseInputExt LlvmOpt = "ll" @@ -214,6 +212,7 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index fb262ba..8d31fd9 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-cse #-} +{-# LANGUAGE NamedFieldPuns #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -78,7 +79,7 @@ preprocess :: HscEnv preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -141,7 +142,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env = hsc_env0 {hsc_dflags = dflags} -- Figure out what lang we're generating - let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + let hsc_lang = 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 @@ -158,12 +159,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) source_unchanged = isJust maybe_old_linkable && not force_recomp object_filename = ml_obj_file location - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HscNoRecomp + let handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable @@ -175,22 +171,27 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) return maybe_old_linkable | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- + = do (hs_unlinked, unlinked_time) <- case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) + HscNothing -> + return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. - _other - -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + _other -> do + maybe_stub_o <- case hasStub of + Nothing -> return Nothing + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return (Just stub_o) + _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) + maybe_stub_o -- 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) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + + let linkable = LM unlinked_time this_mod hs_unlinked return (Just linkable) handleInterpreted HscNoRecomp @@ -200,7 +201,12 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) = ASSERT (isHsBoot src_flavour) return maybe_old_linkable handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) - = do stub_unlinked <- getStubLinkable hasStub + = do stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, @@ -210,7 +216,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- if the source is modified, then the linkable will -- be out of date. let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + (hs_unlinked ++ stub_o) return (Just linkable) let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) @@ -235,31 +241,17 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- 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 :: HscEnv -> Module -> ModLocation -> IO FilePath -compileStub hsc_env mod location = do - -- compile the _stub.c file w/ gcc - let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) - (moduleName mod) location +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). - _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing return stub_o - -- --------------------------------------------------------------------------- -- Link @@ -436,7 +428,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do ( _, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output - Nothing{-no ModLocation-} + Nothing{-no ModLocation-} Nothing return out_file @@ -482,9 +474,11 @@ runPipeline -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> Maybe FilePath -- ^ stub object, if we have one -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o = do let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn @@ -516,9 +510,17 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo let get_output_fn = getOutputFilename stop_phase output basename -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc + let env = PipeEnv{ stop_phase, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state + + let PipeState{ hsc_env=hsc_env', maybe_loc } = state' + dflags' = hsc_dflags hsc_env' -- 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 @@ -536,38 +538,102 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_lo copyWithHeader dflags msg line_prag output_fn final_fn return (dflags', final_fn) +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +getDynFlags :: CompPipeline DynFlags +getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +io :: IO a -> CompPipeline a +io m = P $ \_env state -> do a <- m; return (state, a) + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + io $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc - -pipeLoop :: HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> IO (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc - - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) - - | not (phase `happensBefore` stop_phase) +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: Phase -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + PipeEnv{stop_phase} <- getPipeEnv + PipeState{hsc_env} <- getPipeState + case () of + _ | phase `eqPhase` stop_phase -- All done + -> return input_fn + + | 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 ++ + -> panic ("pipeLoop: at phase " ++ show phase ++ " but I wanted to stop at phase " ++ show stop_phase) - | otherwise - = do debugTraceMsg (hsc_dflags hsc_env) 4 + | otherwise + -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4 (ptext (sLit "Running phase") <+> ppr phase) - (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc + dflags <- getDynFlags + (next_phase, output_fn) <- runPhase phase input_fn dflags + pipeLoop next_phase output_fn + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. getOutputFilename :: Phase -> PipelineOutput -> String @@ -585,21 +651,19 @@ getOutputFilename stop_phase output basename 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 keep_bc = dopt Opt_KeepLlvmFiles dflags - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other 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 LlvmOpt | keep_bc -> True HCc | keep_hc -> True @@ -630,31 +694,23 @@ getOutputFilename stop_phase output basename -- 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 - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> 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 +runPhase :: Phase -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (Phase, -- next phase to run + 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 hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- phaseOutputFilename (Cpp sf) let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -668,56 +724,60 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l , SysTools.FileOption "" output_fn ] - SysTools.runUnlit dflags flags + io $ SysTools.runUnlit dflags flags - return (Cpp sf, dflags, maybe_loc, output_fn) + return (Cpp sf, output_fn) ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- getOptionsFromFile dflags0 input_fn +runPhase (Cpp sf) input_fn dflags0 + = do + src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns + unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (HsPp sf, dflags1, maybe_loc, input_fn) + return (HsPp sf, input_fn) else do - output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc - doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- phaseOutputFilename (HsPp sf) + io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- getOptionsFromFile dflags0 output_fn + src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags0 src_opts - unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + <- io $ parseDynamicNoPackageFlags dflags0 src_opts + unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult unhandled_flags + + setDynFlags dflags2 - return (HsPp sf, dflags2, maybe_loc, output_fn) + return (HsPp sf, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase (HsPp sf) input_fn dflags + = 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) + return (Hsc sf, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- get_output_fn dflags (Hsc sf) maybe_loc - SysTools.runPp dflags + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + io $ SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -726,22 +786,26 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- getOptionsFromFile dflags output_fn + src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- parseDynamicNoPackageFlags dflags src_opts - handleFlagWarnings dflags1 warns - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicNoPackageFlags dflags src_opts + setDynFlags dflags1 + io $ handleFlagWarnings dflags1 warns + io $ checkProcessArgsResult unhandled_flags - return (Hsc sf, dflags1, maybe_loc, output_fn) + return (Hsc sf, 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 hsc_env basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) input_fn dflags0 = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -753,8 +817,10 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } + setDynFlags dflags + -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- + (hspp_buf,mod_name,imps,src_imps) <- io $ case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn @@ -771,7 +837,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- 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 + location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -798,6 +864,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma o_file = ml_obj_file location4 -- The real object file + setModLocation location4 -- Figure out if the source has changed, for recompilation avoidance. -- @@ -806,11 +873,11 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- 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. - src_timestamp <- getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationTime (basename <.> suff) let force_recomp = dopt Opt_ForceRecomp dflags - hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) - source_unchanged <- + hsc_lang = hscTarget dflags + source_unchanged <- io $ if force_recomp || not (isStopLn stop) -- Set source_unchanged to False unconditionally if -- (a) recompilation checker is off, or @@ -827,16 +894,17 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- get_output_fn dflags next_phase (Just location4) + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + setDynFlags dflags' + PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module - mod <- addHomeModuleToFinder hsc_env' mod_name location4 + mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -852,58 +920,64 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma ms_srcimps = src_imps } -- run the compiler! - result <- hscCompileOneShot hsc_env' + result <- io $ hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info case result of HscNoRecomp - -> do SysTools.touch dflags' "Touching object file" o_file + -> do io $ 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) + return (StopLn, o_file) (HscRecomp hasStub _) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o + -> do case hasStub of + Nothing -> return () + Just stub_c -> + do stub_o <- io $ compileStub hsc_env' stub_c + setStubO 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) + io $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags Cmm maybe_loc - doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename Cmm + io $ doCpp dflags False{-not raw-} True{-include CC opts-} + input_fn output_fn + return (Cmm, output_fn) -runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc +runPhase Cmm input_fn dflags = do - let dflags = hsc_dflags hsc_env - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + PipeEnv{src_basename} <- getPipeEnv + let hsc_lang = hscTarget dflags + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- get_output_fn dflags next_phase maybe_loc + + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + extCoreName = src_basename ++ ".hcr" } + + setDynFlags dflags' + PipeState{hsc_env} <- getPipeState - hscCompileCmmFile hsc_env' input_fn + io $ hscCompileCmmFile hsc_env input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: -- --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -911,26 +985,26 @@ runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc -- 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 hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase cc_phase input_fn dflags | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc - = do let dflags = hsc_dflags hsc_env + = 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 [] + pkgs <- if hcc then io $ 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 + pkg_include_dirs <- io $ 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 - gcc_extra_viac_flags <- getExtraViaCOpts dflags + let md_c_flags = machdepCCOpts dflags + gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags let pic_c_flags = picCCOpts dflags let verb = getVerbFlag dflags @@ -938,13 +1012,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- + pkg_extra_cc_opts <- io $ if cc_phase `eqPhase` HCc then return [] else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -959,11 +1033,8 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- Decide next phase - let mangle = dopt Opt_DoAsmMangling dflags - next_phase - | hcc && mangle = Mangle - | otherwise = As - output_fn <- get_output_fn dflags next_phase maybe_loc + let next_phase = As + output_fn <- phaseOutputFilename next_phase let more_hcc_opts = @@ -986,7 +1057,7 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" | cc_phase `eqPhase` Cobjc = "objective-c" | otherwise = "c" - SysTools.runCc dflags ( + io $ 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 @@ -1020,18 +1091,8 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc -- This is a temporary hack. ++ ["-mcpu=v9"] #endif - ++ (if hcc && mangle - then md_regd_c_flags - else []) - ++ (if hcc - then if mangle - then gcc_extra_viac_flags - else filter (=="-fwrapv") - gcc_extra_viac_flags - -- still want -fwrapv even for unreg'd - else []) ++ (if hcc - then more_hcc_opts + then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ [ verb, "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] @@ -1044,81 +1105,56 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- --- Mangle phase - -runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - 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 dflags 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 hsc_env _basename _suff input_fn _get_output_fn maybe_loc +runPhase SplitMangle input_fn dflags = 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) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" + + split_s_prefix <- io $ SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix - SysTools.runSplit dflags + io $ 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 + s <- io $ readFile n_files_fn let n_files = read s :: Int dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + setDynFlags dflags' + -- Remember to delete all these files - addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags', maybe_loc, "**splitmangle**") + return (SplitAs, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase As input_fn dflags + = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase -- we create directories for the object file, because it -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryHierarchy (takeDirectory output_fn) - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runAs dflags + let md_c_flags = machdepCCOpts dflags + io $ SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] #ifdef sparc_TARGET_ARCH @@ -1138,24 +1174,27 @@ runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc + -- we'll handle the stub_o file in this phase, so don't MergeStub, + -- just jump straight to StopLn afterwards. + let next_phase = StopLn + output_fn <- phaseOutputFilename next_phase let base_o = dropExtension output_fn osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - createDirectoryHierarchy split_odir + io $ 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 ) $ filter (osuf `isSuffixOf`) fs + fs <- io $ getDirectoryContents split_odir + io $ mapM_ removeFile $ + map (split_odir ) $ filter (osuf `isSuffixOf`) fs let as_opts = getOpts dflags opt_a @@ -1167,7 +1206,7 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc split_obj n = split_odir takeFileName base_o ++ "__" ++ show n <.> osuf - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags let assemble_file n = SysTools.runAs dflags (map SysTools.Option as_opts ++ @@ -1188,19 +1227,25 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc ] ++ map SysTools.Option md_c_flags) - mapM_ assemble_file [1..n] + io $ mapM_ assemble_file [1..n] + + -- If there's a stub_o file, then we make it the n+1th split object. + PipeState{maybe_stub_o} <- getPipeState + n' <- case maybe_stub_o of + Nothing -> return n + Just stub_o -> do io $ copyFile stub_o (split_obj (n+1)) + return (n+1) -- join them into a single .o file - joinObjectFiles dflags (map split_obj [1..n]) output_fn + io $ joinObjectFiles dflags (map split_obj [1..n']) output_fn - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmOpt input_fn dflags = do - let dflags = hsc_dflags hsc_env let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this for @@ -1211,16 +1256,16 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc then [SysTools.Option (llvmOpts !! opt_lvl)] else [] - output_fn <- get_output_fn dflags LlvmLlc maybe_loc + output_fn <- phaseOutputFilename LlvmLlc - SysTools.runLlvmOpt dflags + io $ SysTools.runLlvmOpt dflags ([ SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag ++ map SysTools.Option lo_opts) - return (LlvmLlc, dflags, maybe_loc, output_fn) + return (LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate @@ -1230,9 +1275,8 @@ runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmLlc phase -runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmLlc input_fn dflags = do - let dflags = hsc_dflags hsc_env let lc_opts = getOpts dflags opt_lc let opt_lvl = max 0 (min 2 $ optLevel dflags) #if darwin_TARGET_OS @@ -1244,16 +1288,16 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- get_output_fn dflags nphase maybe_loc + output_fn <- phaseOutputFilename nphase - SysTools.runLlvmLlc dflags + io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, dflags, maybe_loc, output_fn) + return (nphase, output_fn) where #if darwin_TARGET_OS llvmOpts = ["-O1", "-O2", "-O2"] @@ -1265,17 +1309,36 @@ runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase LlvmMangle input_fn _dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags As maybe_loc - llvmFixupAsm input_fn output_fn - return (As, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename As + io $ llvmFixupAsm input_fn output_fn + return (As, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects +runPhase MergeStub input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + io $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (StopLn, output_fn) -- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = +runPhase other _input_fn _dflags = panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1313,7 +1376,7 @@ mkExtraCObj dflags xs oFile <- newTempName dflags "o" writeFile cFile $ unlines xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId - (md_c_flags, _) = machdepCCOpts dflags + md_c_flags = machdepCCOpts dflags SysTools.runCc dflags ([Option "-c", FileOption "" cFile, @@ -1505,7 +1568,7 @@ linkBinary dflags o_files dep_packages = do rc_objs <- maybeCreateManifest dflags output_fn - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags SysTools.runLink dflags ( [ SysTools.Option verb , SysTools.Option "-o" @@ -1658,7 +1721,7 @@ linkDynLib dflags o_files dep_packages = do -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - let (md_c_flags, _) = machdepCCOpts dflags + let md_c_flags = machdepCCOpts dflags let extra_ld_opts = getOpts dflags opt_l rtsEnabledObj <- mkRtsOptionsLevelObj dflags @@ -1805,7 +1868,7 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do | otherwise = (optc ++ md_c_flags) where optc = getOpts dflags opt_c - (md_c_flags, _) = machdepCCOpts dflags + md_c_flags = machdepCCOpts dflags let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -1861,7 +1924,7 @@ joinObjectFiles dflags o_files output_fn = do ld_x_flag | null cLD_X = "" | otherwise = "-Wl,-x" - (md_c_flags, _) = machdepCCOpts dflags + md_c_flags = machdepCCOpts dflags if cLdIsGNULd == "YES" then do @@ -1886,19 +1949,3 @@ hscNextPhase dflags _ hsc_lang = HscInterpreted -> StopLn _other -> StopLn - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop _ 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 - diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 706ded8..7c0fd46 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -252,7 +252,6 @@ data DynFlag | Opt_Pp | Opt_ForceRecomp | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@ -289,7 +288,6 @@ data DynFlag | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles @@ -398,7 +396,6 @@ data DynFlags = DynFlags { #ifndef OMIT_NATIVE_CODEGEN targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. #endif - stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@ -469,7 +466,6 @@ data DynFlags = DynFlags { 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]), @@ -668,7 +664,6 @@ defaultDynFlags = #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, #endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@ -733,7 +728,6 @@ defaultDynFlags = pgm_P = panic "defaultDynFlags: No pgm_P", pgm_F = panic "defaultDynFlags: No pgm_F", pgm_c = panic "defaultDynFlags: No pgm_c", - pgm_m = panic "defaultDynFlags: No pgm_m", pgm_s = panic "defaultDynFlags: No pgm_s", pgm_a = panic "defaultDynFlags: No pgm_a", pgm_l = panic "defaultDynFlags: No pgm_l", @@ -1106,7 +1100,7 @@ dynamic_flags = [ , Flag "pgmP" (hasArg setPgmP) , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) + , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])})) , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])})) , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])})) @@ -1177,8 +1171,8 @@ dynamic_flags = [ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) + , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural @@ -1289,9 +1283,9 @@ dynamic_flags = [ ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) + , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- @@ -1478,7 +1472,6 @@ fFlags = [ ( "dicts-cheap", Opt_DictsCheap, nop ), ( "excess-precision", Opt_ExcessPrecision, nop ), ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), ( "print-bind-result", Opt_PrintBindResult, nop ), ( "force-recomp", Opt_ForceRecomp, nop ), ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), @@ -1650,8 +1643,6 @@ defaultFlags = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_DoAsmMangling, - Opt_SharedImplib, Opt_GenManifest, @@ -2153,20 +2144,17 @@ setOptHpcDir arg = upd $ \ d -> d{hpcDir = arg} -- The options below are not dependent on the version of gcc, only the -- platform. -machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) +machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations +machdepCCOpts dflags = cCcOpts ++ machdepCCOpts' -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags +machdepCCOpts' :: [String] -- flags for all C compilations +machdepCCOpts' #if alpha_TARGET_ARCH - = ( ["-w", "-mieee" + = ["-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. @@ -2174,71 +2162,17 @@ machdepCCOpts' _dflags #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"] ) + = ["-D_HPUX_SOURCE"] #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 - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-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-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#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. + = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else [] -#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] diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index d8a6271..5cbcd41 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -498,7 +498,7 @@ mkStubPaths :: DynFlags -> ModuleName -> ModLocation - -> (FilePath,FilePath,FilePath) + -> FilePath mkStubPaths dflags mod location = let @@ -513,15 +513,8 @@ mkStubPaths dflags mod location | otherwise = src_basename stub_basename = stub_basename0 ++ "_stub" - - obj = ml_obj_file location - osuf = objectSuf dflags - stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub" - -- NB. not takeFileName, see #3093 in - (stub_basename <.> "c", - stub_basename <.> "h", - stub_obj_base <.> objectSuf dflags) + stub_basename <.> "h" -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, @@ -538,12 +531,9 @@ findObjectLinkableMaybe mod locn -- 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 = (dropExtension obj_fn ++ "_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]) +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) -- ----------------------------------------------------------------------------- -- Error messages diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 5f9380a..0d41435 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,1463 +1,1478 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2005 --- --- This module deals with --make --- ----------------------------------------------------------------------------- - -module GhcMake( - depanal, - load, LoadHowMuch(..), - - topSortModuleGraph, - - noModError, cyclicModuleErr - ) where - -#include "HsVersions.h" - -#ifdef GHCI -import qualified Linker ( unload ) -#endif - -import DriverPipeline -import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils -import DynFlags -import HsSyn hiding ((<.>)) -import Finder -import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) - -import Exception ( evaluate, tryIO ) -import Panic -import SysTools -import BasicTypes -import SrcLoc -import Util -import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer -import FastString -import Outputable -import UniqFM - -import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) - -import System.Directory ( doesFileExist, getModificationTime ) -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.Time ( ClockTime ) -import System.FilePath -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.List as List - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compilating --- and loading may result in files being created on disk. --- --- Calls the 'reportModuleCompilationResult' callback after each compiling --- each module, whether successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the callback. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- 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_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- 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 - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = 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 - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ 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 <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ 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_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep 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 liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - liftIO $ 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 || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - hsc_env1 <- getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult - - 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 liftIO $ 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 - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - --- Finish up after a load. - --- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag - -> m SuccessFlag -loadFinish _all_ok Failed - = do hsc_env <- getSession - liftIO $ unload hsc_env [] - modifySession discardProg - 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 - = do modifySession $ \hsc_env -> 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 :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - -#if defined(mingw32_HOST_OS) - -- we must add the .exe extention unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name_exe = fmap (<.> "exe") name -#else - name_exe = name -#endif - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } - --- ----------------------------------------------------------------------------- - --- | 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] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapUFM prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (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" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name 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 _):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 - - --- --------------------------------------------------------------------------- --- Unloading - -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of -#ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables -#else - LinkInMemory -> panic "unload: no interpreter" - -- urgh. avoid warnings: - hsc_env stable_linkables -#endif - _other -> return () - --- ----------------------------------------------------------------------------- - -{- | - - 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. - - 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, then: - - - 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) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- 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_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_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 lookupUFM hpt (ms_mod_name 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 lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - --- ----------------------------------------------------------------------------- - --- | 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 - :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) - -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' in the monad has an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep old_hpt stable_mods cleanup sccs = do - (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) - return (res, reverse done) - where - - upsweep' _old_hpt done - [] _ _ - = return (Succeeded, done) - - upsweep' _old_hpt done - (CyclicSCC ms:_) _ _ - = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) - return (Failed, done) - - upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger - - hsc_env <- getSession - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - liftIO cleanup -- Remove unwanted tmp files between compilations - - case mb_mod_info of - Nothing -> return (Failed, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (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 the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod - - done' = mod:done - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. See reTypecheckLoop, below. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' - setSession hsc_env2 - - upsweep' old_hpt1 done' mods (mod_index+1) nmods - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> IO HomeModInfo - -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = let - this_mod_name = ms_mod_name summary - 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 - - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - - old_hmi = lookupUFM old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fvia-C to -fasm and vice-versa, otherwise we could - -- end up trying to link object code to byte code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- 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 old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: Maybe Linkable -> IO HomeModInfo - compile_it mb_linkable = - compile hsc_env summary' mod_index nmods - mb_old_iface mb_linkable - - compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo - compile_it_discard_iface mb_linkable = - compile hsc_env summary' mod_index nmods - Nothing mb_linkable - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - 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. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing - - - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops - -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | not (isBootSummary ms) && - any (\m -> ms_mod m == this_mod && isBootSummary m) graph - = do - let mss = reachableBackwards (ms_mod_name ms) graph - non_boot = filter (not.isBootSummary) mss - debugTraceMsg (hsc_dflags hsc_env) 2 $ - text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) - typecheckLoop hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - where - this_mod = ms_mod ms - -typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop hsc_env mods = do - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToUFM old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [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 be cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- 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. - let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = ghcError (ProgramError "module does not exist") - in graphFromEdgedVertices (seq root (reachableG graph root)) - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey (_, k, _) = k - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary (s, _, _) = s - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ (s, key, out_keys) - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [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 = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) - ------------------------------------------------------------------------------ --- 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 - -> [ModuleName] -- 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 [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 - = do - rootSummaries <- mapM getRootSummary roots - let root_map = mkRootMap rootSummaries - checkDuplicates root_map - summs <- loop (concatMap msDeps rootSummaries) root_map - return 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) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- 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 = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: [(Located ModuleName,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 <- Map.lookup key done - = 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 True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) - --- XXX Does the (++) here need to be flipped? -mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [s]) | s <- summaries ] - Map.empty - -msDeps :: ModSummary -> [(Located ModuleName, 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_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] - -home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - ------------------------------------------------------------------------------ --- 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 - -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) - -> IO ModSummary - -summariseFile hsc_env old_summaries file mb_phase obj_allowed 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 -> liftIO $ 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 <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False - else return Nothing - 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 hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name 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 - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- getMofificationTime may fail - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - 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:_) -> 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 ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = 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 <- tryIO (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 <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) 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 <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> noModError dflags loc wanted_mod err - -- Not found - - just_found location mod = 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' mod src_fn t - - - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - return (Just (ModSummary { ms_mod = 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 :: ModLocation -> Bool -> IO (Maybe ClockTime) -getObjTimestamp location is_boot - = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - -- case we bypass the preprocessing stage? - let - local_opts = getOptions dflags buf src_fn - -- - (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts - checkProcessArgsResult leftovers - handleFlagWarnings dflags' warns - - 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 - | xopt 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 -> ModuleName -> FindResult -> IO ab --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: SrcSpan -> String -> IO a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path - -packageModErr :: ModuleName -> IO a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ 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 - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- + +module GhcMake( + depanal, + load, LoadHowMuch(..), + + topSortModuleGraph, + + noModError, cyclicModuleErr + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker ( unload ) +#endif + +import DriverPipeline +import DriverPhases +import GhcMonad +import Module +import HscTypes +import ErrUtils +import DynFlags +import HsSyn hiding ((<.>)) +import Finder +import HeaderInfo +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import RdrName ( RdrName ) + +import Exception ( evaluate, tryIO ) +import Panic +import SysTools +import BasicTypes +import SrcLoc +import Util +import Digraph +import Bag ( listToBag ) +import Maybes ( expectJust, mapCatMaybes ) +import StringBuffer +import FastString +import Outputable +import UniqFM + +import qualified Data.Map as Map +import qualified FiniteMap as Map( insertListWith) + +import System.Directory ( doesFileExist, getModificationTime ) +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) +import System.Time ( ClockTime ) +import System.FilePath +import Control.Monad +import Data.Maybe +import Data.List +import qualified Data.List as List + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] + -> m SuccessFlag +load2 how_much mod_graph = do + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- 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_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- 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 + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = 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 + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + + liftIO $ 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 <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ 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_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep 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 liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- 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 || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + 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 liftIO $ 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 + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag + -> m SuccessFlag +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + 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 + = do modifySession $ \hsc_env -> 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 } + +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- + +-- | 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] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapUFM prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (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" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name 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 _):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 + + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- + +{- | + + 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. + + 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, then: + + - 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) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- 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_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_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 lookupUFM hpt (ms_mod_name 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 lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +-- ----------------------------------------------------------------------------- + +-- | 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 + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) + -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) + where + + upsweep' _old_hpt done + [] _ _ + = return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:_) _ _ + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (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 the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 + + upsweep' old_hpt1 done' mods (mod_index+1) nmods + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo + +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + 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 + + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- 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 old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> IO HomeModInfo + compile_it mb_linkable = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable + + compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo + compile_it_discard_iface mb_linkable = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + 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. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing + + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- Topological sort of the module graph + +type SummaryNode = (ModSummary, Int, [Int]) + +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [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 be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- 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. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [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 = (ModuleName, HscSource) -- The nodes of the graph are +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + +----------------------------------------------------------------------------- +-- 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 + -> [ModuleName] -- 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 [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 + = do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return 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) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- 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 = liftIO $ multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,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 <- Map.lookup key done + = 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 True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + +-- XXX Does the (++) here need to be flipped? +mkRootMap :: [ModSummary] -> NodeMap [ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty + +msDeps :: ModSummary -> [(Located ModuleName, 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_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +----------------------------------------------------------------------------- +-- 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 + -> Bool -- object code allowed? + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase obj_allowed 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 -> liftIO $ 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 <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing + 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 hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name 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 + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- getMofificationTime may fail + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + 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:_) -> 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 ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, ClockTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map + = 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 <- tryIO (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 <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) 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 <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found + + just_found location mod = 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' mod src_fn t + + + new_summary location mod src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + -- Find the object timestamp, and return the summary + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + return (Just (ModSummary { ms_mod = 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 :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) + = do + let dflags = hsc_dflags hsc_env + -- case we bypass the preprocessing stage? + let + local_opts = getOptions dflags buf src_fn + -- + (dflags', leftovers, warns) + <- parseDynamicNoPackageFlags dflags local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns + + 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 + | xopt 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 -> ModuleName -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: SrcSpan -> String -> IO a +noHsFileErr loc path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr :: ModuleName -> IO a +packageModErr mod + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ 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 + mods_in_cycle = map ms_mod_name ms + imp_modname = unLoc . ideclName . unLoc + just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) + + show_one ms = + vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> + maybe empty (parens . text) (ml_hs_file (ms_location ms)), + nest 2 $ ptext (sLit "imports:") <+> vcat [ + pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), + pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] + ] + show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) + pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 37c65bb..841125a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -460,7 +460,8 @@ error. This is the only thing that isn't caught by the type-system. data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- 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 them for us. a @@ -596,14 +597,14 @@ hscOneShotCompiler = , hscBackend = \ tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp False ()) + HscNothing -> return (HscRecomp Nothing ()) _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -649,7 +650,7 @@ hscBatchCompiler = , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -681,7 +682,7 @@ hscInteractiveCompiler = , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -710,7 +711,7 @@ hscNothingCompiler = , hscBackend = \tc_result _mod_summary mb_old_iface -> do handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -852,7 +853,7 @@ hscWriteIface iface no_change mod_summary -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc Bool -- ^ @True@ <=> stub.c exists + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3673b3e..3d441cc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -25,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -76,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -494,6 +495,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -1790,6 +1794,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index d33fd6c..3eb5744 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -14,7 +14,7 @@ module SysTools ( -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () + runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, @@ -171,9 +171,8 @@ initSysTools mbMinusB dflags0 -- architecture-specific stuff is done when building Config.hs unlit_path = installed cGHC_UNLIT_PGM - -- split and mangle are Perl scripts + -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - mangle_script = installed cGHC_MANGLER_PGM windres_path = installed_mingw_bin "windres" @@ -194,7 +193,7 @@ initSysTools mbMinusB dflags0 | isWindowsHost = installed cGHC_TOUCHY_PGM | otherwise = "touch" -- 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. + -- a call to Perl to get the invocation of split. -- 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 @@ -202,9 +201,6 @@ initSysTools mbMinusB dflags0 (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mangle_prog, mangle_args) - | isWindowsHost = (perl_path, [Option mangle_script]) - | otherwise = (mangle_script, []) (mkdll_prog, mkdll_args) | not isWindowsHost = panic "Can't build DLLs on a non-Win32 system" @@ -234,7 +230,6 @@ initSysTools mbMinusB dflags0 pgm_P = cpp_path, pgm_F = "", pgm_c = (gcc_prog,[]), - pgm_m = (mangle_prog,mangle_args), pgm_s = (split_prog,split_args), pgm_a = (as_prog,[]), pgm_l = (ld_prog,[]), @@ -372,11 +367,6 @@ getGccEnv opts = = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -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 diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 5fab944..473b549 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -48,7 +48,7 @@ The algorithm is roughly: (c) Update the current assignment - (d) If the intstruction is a branch: + (d) If the instruction is a branch: if the destination block already has a register assignment, Generate a new block with fixup code and redirect the jump to the new block. @@ -331,7 +331,7 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr instr of Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), @@ -497,7 +497,7 @@ releaseRegs regs = do saveClobberedTemps - :: Instruction instr + :: (Outputable instr, Instruction instr) => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM [instr] -- return: instructions to spill any temps that will @@ -536,7 +536,7 @@ saveClobberedTemps clobbered dying --- | Mark all these regal regs as allocated, +-- | Mark all these real regs as allocated, -- and kick out their vreg assignments. -- clobberRegs :: [RealReg] -> RegM () @@ -571,6 +571,16 @@ clobberRegs clobbered -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). @@ -579,7 +589,7 @@ clobberRegs clobbered -- the list of free registers and free stack slots. allocateRegsAndSpill - :: Instruction instr + :: (Outputable instr, Instruction instr) => Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns @@ -593,13 +603,14 @@ allocateRegsAndSpill _ _ spills alloc [] allocateRegsAndSpill reading keep spills alloc (r:rs) = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be + -- NB1. if we're writing this register, update its assignment to be -- InReg, because the memory value is no longer valid. -- NB2. This is why we must process written registers here, even if they -- are also read by the same instruction. @@ -608,10 +619,22 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) allocateRegsAndSpill reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... - loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew -allocRegsAndSpill_spill reading keep spills alloc r rs loc assig +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs @@ -620,19 +643,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp reading r loc my_reg spills - - let new_loc - -- if the tmp was in a slot, then now its in a reg as well - | Just (InMem slot) <- loc - , reading - = InBoth my_reg slot + do spills' <- loadTemp r spill_loc my_reg spills - -- tmp has been loaded into a reg - | otherwise - = InReg my_reg - - setAssigR (addToUFM assig r $! new_loc) + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ allocateReg my_reg freeRegs allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs @@ -662,9 +675,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp reading r loc my_reg spills + = do spills' <- loadTemp r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs @@ -684,11 +697,11 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig -- update the register assignment let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills + spills' <- loadTemp r spill_loc my_reg spills allocateRegsAndSpill reading keep (spill_store ++ spills') @@ -707,22 +720,28 @@ allocRegsAndSpill_spill reading keep spills alloc r rs loc assig result --- | Load up a spilled temporary if we need to. +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg + +-- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: Instruction instr - => Bool - -> VirtualReg -- the temp being loaded - -> Maybe Loc -- the current location of this temp + :: (Outputable instr, Instruction instr) + => VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] -loadTemp True vreg (Just (InMem slot)) hreg spills +loadTemp vreg (ReadMem slot) hreg spills = do insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ _ spills = +loadTemp _ _ _ spills = return spills diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ad2405b..16ac13c 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -429,7 +429,7 @@ traceOptTcRn flag doc = ifDOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; dflags <- getDOpts - ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } + ; when (not opt_NoDebugOutput) $ liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () debugDumpTcRn doc | opt_NoDebugOutput = return () diff --git a/darcs-all b/darcs-all deleted file mode 100755 index 106eb8f..0000000 --- a/darcs-all +++ /dev/null @@ -1,437 +0,0 @@ -#!/usr/bin/perl -w - -use strict; - -# Usage: -# -# ./darcs-all [-q] [-s] [-i] [-r repo] -# [--nofib] [--testsuite] [--checked-out] cmd [darcs flags] -# -# Applies the darcs command "cmd" to each repository in the tree. -# -# e.g. -# ./darcs-all -r http://darcs.haskell.org/ghc get -# To get any repos which do not exist in the local tree -# -# ./darcs-all -r ~/ghc-validate push -# To push all your repos to the ~/ghc-validate tree -# -# ./darcs-all pull -a -# To pull everything from the default repos -# -# ./darc-all push --dry-run -# To see what local patches you have relative to the main repos -# -# -------------- Flags ------------------- -# -q says to be quite, and -s to be silent. -# -# -i says to ignore darcs errors and move on to the next repository -# -# -r repo says to use repo as the location of package repositories -# -# --checked-out says that the remote repo is in checked-out layout, as -# opposed to the layout used for the main repo. By default a repo on -# the local filesystem is assumed to be checked-out, and repos accessed -# via HTTP or SSH are assumed to be in the main repo layout; use -# --checked-out to override the latter. -# -# --nofib, --testsuite also get the nofib and testsuite repos respectively -# -# The darcs get flag you are most likely to want is --complete. By -# default we pass darcs the --partial flag. -# -# ------------ Which repos to use ------------- -# darcs-all uses the following algorithm to decide which remote repos to use -# -# It always computes the remote repos from a single base, $repo_base -# How is $repo_base set? -# If you say "-r repo", then that's $repo_base -# othewise $repo_base is set thus: -# look in _darcs/prefs/defaultrepo, -# and remove the trailing 'ghc' -# -# Then darcs-all iterates over the package found in the file -# ./packages, which has entries like: -# libraries/array packages/array darcs -# or, in general -# -# -# If $repo_base looks like a local filesystem path, or if you give -# the --checked-out flag, darcs-all works on repos of form -# $repo_base/ -# otherwise darcs-all works on repos of form -# $repo_base/ -# This logic lets you say -# both darcs-all -r http://darcs.haskell.org/ghc-6.12 pull -# and darcs-all -r ../HEAD pull -# The latter is called a "checked-out tree". - -# NB: darcs-all *ignores* the defaultrepo of all repos other than the -# root one. So the remote repos must be laid out in one of the two -# formats given by and in the file 'packages'. - - -$| = 1; # autoflush stdout after each print, to avoid output after die - -my $defaultrepo; - -my $verbose = 2; -my $ignore_failure = 0; -my $want_remote_repo = 0; -my $checked_out_flag = 0; - -my %tags; - -my @packages; - -# Figure out where to get the other repositories from. -sub getrepo { - my $basedir = "."; - my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`; - chomp $repo; - - my $repo_base; - my $checked_out_tree; - - if ($repo =~ /^...*:/) { - # HTTP or SSH - # Above regex says "at least two chars before the :", to avoid - # catching Win32 drives ("C:\"). - $repo_base = $repo; - - # --checked-out is needed if you want to use a checked-out repo - # over SSH or HTTP - if ($checked_out_flag) { - $checked_out_tree = 1; - } else { - $checked_out_tree = 0; - } - - # Don't drop the last part of the path if specified with -r, as - # it expects repos of the form: - # - # http://darcs.haskell.org - # - # rather than - # - # http://darcs.haskell.org/ghc - # - if (!$defaultrepo) { - $repo_base =~ s#/[^/]+/?$##; - } - } - elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute or relative path - # (assumes a checked-out tree): - $repo_base = $repo; - $checked_out_tree = 1; - } - else { - die "Couldn't work out repo"; - } - - return $repo_base, $checked_out_tree; -} - -sub message { - if ($verbose >= 2) { - print "@_\n"; - } -} - -sub warning { - if ($verbose >= 1) { - print "warning: @_\n"; - } -} - -sub darcs { - message "== running darcs @_"; - system ("darcs", @_) == 0 - or $ignore_failure - or die "darcs failed: $?"; -} - -sub parsePackages { - my @repos; - my $lineNum; - - my ($repo_base, $checked_out_tree) = getrepo(); - - open IN, "< packages" or die "Can't open packages file"; - @repos = ; - close IN; - - @packages = (); - $lineNum = 0; - foreach (@repos) { - chomp; - $lineNum++; - if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) { - my %line; - $line{"localpath"} = $1; - $line{"tag"} = $2; - $line{"remotepath"} = $3; - $line{"vcs"} = $4; - $line{"upstream"} = $5; - push @packages, \%line; - } - elsif (! /^(#.*)?$/) { - die "Bad content on line $lineNum of packages file: $_"; - } - } -} - -sub darcsall { - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $command = $_[0]; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if (-d "$localpath/_darcs") { - if ($want_remote_repo) { - if ($command =~ /^opt/) { - # Allows ./darcs-all optimize --relink - darcs (@_, "--repodir", $localpath, "--sibling=$path"); - } else { - darcs (@_, "--repodir", $localpath, $path); - } - } else { - darcs (@_, "--repodir", $localpath); - } - } - elsif ($tag eq "-") { - message "== Required repo $localpath is missing! Skipping"; - } - else { - message "== $localpath repo not present; skipping"; - } - } -} - -sub darcsget { - my $r_flags; - my $localpath; - my $remotepath; - my $path; - my $tag; - my @repos; - my $line; - - my ($repo_base, $checked_out_tree) = getrepo(); - - if (! grep /(?:--complete|--partial|--lazy)/, @_) { - warning("adding --partial, to override use --complete"); - $r_flags = [@_, "--partial"]; - } - else { - $r_flags = \@_; - } - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; - - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } - - if ($tags{$tag} eq 1) { - if (-d $localpath) { - warning("$localpath already present; omitting"); - } - else { - darcs (@$r_flags, $path, $localpath); - } - } - } -} - -sub darcsupstreampull { - my $localpath; - my $upstream; - my $line; - - for $line (@packages) { - $localpath = $$line{"localpath"}; - $upstream = $$line{"upstream"}; - - if ($upstream ne "-") { - if (-d $localpath) { - darcs ("pull", @_, "--repodir", $localpath, $upstream); - } - } - } -} - -sub main { - if (! -d "compiler") { - die "error: darcs-all must be run from the top level of the ghc tree." - } - - $tags{"-"} = 1; - $tags{"dph"} = 1; - $tags{"nofib"} = 0; - $tags{"testsuite"} = 0; - $tags{"extra"} = 0; - - while ($#_ ne -1) { - my $arg = shift; - # We handle -q here as well as lower down as we need to skip over it - # if it comes before the darcs command - if ($arg eq "-q") { - $verbose = 1; - } - elsif ($arg eq "-s") { - $verbose = 0; - } - elsif ($arg eq "-r") { - $defaultrepo = shift; - } - elsif ($arg eq "-i") { - $ignore_failure = 1; - } - # --nofib tells get to also grab the nofib repo. - # It has no effect on the other commands. - elsif ($arg eq "--nofib") { - $tags{"nofib"} = 1; - } - elsif ($arg eq "--no-nofib") { - $tags{"nofib"} = 0; - } - # --testsuite tells get to also grab the testsuite repo. - # It has no effect on the other commands. - elsif ($arg eq "--testsuite") { - $tags{"testsuite"} = 1; - } - elsif ($arg eq "--no-testsuite") { - $tags{"testsuite"} = 0; - } - # --dph tells get to also grab the dph repo. - # It has no effect on the other commands. - elsif ($arg eq "--dph") { - $tags{"dph"} = 1; - } - elsif ($arg eq "--no-dph") { - $tags{"dph"} = 0; - } - # --extralibs tells get to also grab the extra repos. - # It has no effect on the other commands. - elsif ($arg eq "--extra") { - $tags{"extra"} = 1; - } - elsif ($arg eq "--no-extra") { - $tags{"extra"} = 0; - } - # Use --checked-out if the remote repos are a checked-out tree, - # rather than the master trees. - elsif ($arg eq "--checked-out") { - $checked_out_flag = 1; - } - else { - unshift @_, $arg; - if (grep /^-q$/, @_) { - $verbose = 1; - } - last; - } - } - - if ($#_ eq -1) { - die "What do you want to do?"; - } - my $command = $_[0]; - parsePackages; - if ($command eq "get") { - darcsget @_; - } - elsif ($command eq "upstreampull") { - shift; - darcsupstreampull @_; - } - else { - if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) { - # Hack around whatsnew failing if there are no changes - $ignore_failure = 1; - } - if ($command =~ /^(pul|pus|sen|put|opt)/) { - $want_remote_repo = 1; - } - darcsall @_; - } -} - -END { - my $ec = $?; - - message "== Checking for old bytestring repo"; - if (-d "libraries/bytestring/_darcs") { - if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) { - print < /dev/null 2> /dev/null") == 0) { - print <- - or - - retain intermediate .raw_s files - dynamic - - - - retain all intermediate temporary files dynamic @@ -567,7 +560,7 @@ P Compile to be part of package P - dynamic + static - @@ -1999,12 +1992,6 @@ phase n - cmd - Use cmd as the mangler - dynamic - - - - cmd Use cmd as the splitter dynamic @@ -2595,12 +2582,6 @@ phase n - - - Turn off assembly mangling (use instead) - dynamic - - - - Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread. dynamic diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index 6ed8de1..dfa10a5 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -71,17 +71,6 @@ - cmd - - - - Use cmd as the - mangler. - - - - - cmd diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index ae0e80c..099a91f 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -496,22 +496,6 @@ $ ghc -c parse/Foo.hs parse/Bar.hs gurgle/Bumble.hs -odir `uname -m` - , - - - - - - Keep intermediate .raw-s files. - These are the direct output from the C compiler, before - GHC does “assembly mangling” to produce the - .s file. Again, these are not produced - when using the native code generator. - - - - - temporary fileskeeping diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index 05f1de4..8b08d9d 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -2203,27 +2203,6 @@ f "2" = 2 - - : - - (x86 only)-monly-N-regs - option (iX86 only) GHC tries to - “steal” four registers from GCC, for performance - reasons; it almost always works. However, when GCC is - compiling some modules with four stolen registers, it will - crash, probably saying: - - -Foo.hc:533: fixed or forbidden register was spilled. -This may be due to a compiler bug or to impossible asm -statements or clauses. - - - Just give some registers back with - . Try `3' first, then `2'. - If `2' doesn't work, please report the bug to us. - - diff --git a/driver/mangler/Makefile b/driver/mangler/Makefile deleted file mode 100644 index 58a1761..0000000 --- a/driver/mangler/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture -# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -dir = driver/mangler -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk diff --git a/driver/mangler/ghc-asm.lprl b/driver/mangler/ghc-asm.lprl deleted file mode 100644 index 4bac756..0000000 --- a/driver/mangler/ghc-asm.lprl +++ /dev/null @@ -1,2061 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-asm-fiddling]{Fiddling with assembler files} -%* * -%************************************************************************ - -Tasks: -\begin{itemize} -\item -Utterly stomp out C functions' prologues and epilogues; i.e., the -stuff to do with the C stack. -\item -Any other required tidying up. -\end{itemize} - -General note [chak]: Many regexps are very fragile because they rely on white -space being in the right place. This caused trouble with gcc 2.95 (at least -on Linux), where the use of white space in .s files generated by gcc suddenly -changed. To guarantee compatibility across different versions of gcc, make -sure (at least on i386-.*-linux) that regexps tolerate varying amounts of white -space between an assembler statement and its arguments as well as after a the -comma separating multiple arguments. - -\emph{For the time being, I have corrected the regexps for i386-.*-linux. I -didn't touch all the regexps for other i386 platforms, as I don't have -a box to test these changes.} - -HPPA specific notes: -\begin{itemize} -\item -The HP linker is very picky about symbols being in the appropriate -space (code vs. data). When we mangle the threaded code to put the -info tables just prior to the code, they wind up in code space -rather than data space. This means that references to *_info from -un-mangled parts of the RTS (e.g. unthreaded GC code) get -unresolved symbols. Solution: mini-mangler for .c files on HP. I -think this should really be triggered in the driver by a new -rts -option, so that user code doesn't get mangled inappropriately. -\item -With reversed tables, jumps are to the _info label rather than to -the _entry label. The _info label is just an address in code -space, rather than an entry point with the descriptive blob we -talked about yesterday. As a result, you can't use the call-style -JMP_ macro. However, some JMP_ macros take _info labels as targets -and some take code entry points within the RTS. The latter won't -work with the goto-style JMP_ macro. Sigh. Solution: Use the goto -style JMP_ macro, and mangle some more assembly, changing all -"RP'literal" and "LP'literal" references to "R'literal" and -"L'literal," so that you get the real address of the code, rather -than the descriptive blob. Also change all ".word P%literal" -entries in info tables and vector tables to just ".word literal," -for the same reason. Advantage: No more ridiculous call sequences. -\end{itemize} - -%************************************************************************ -%* * -\subsection{Top-level code} -%* * -%************************************************************************ - -\begin{code} -$TargetPlatform = $TARGETPLATFORM; - -($Pgm = $0) =~ s|.*/||m; -$ifile = $ARGV[0]; -$ofile = $ARGV[1]; - -if ( $TargetPlatform =~ /^i386-/m ) { - if ($ARGV[2] eq '') { - $StolenX86Regs = 4; - } else { - $StolenX86Regs = $ARGV[2]; - } -} - -&mangle_asm($ifile,$ofile); - -exit(0); -\end{code} - -%************************************************************************ -%* * -\subsection{Constants for various architectures} -%* * -%************************************************************************ - -\begin{code} -sub init_TARGET_STUFF { - - #--------------------------------------------------------# - if ( $TargetPlatform =~ /^alpha-.*-.*/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\$L?C(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\$.*\.\.ng:|\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)'; - $T_COPY_DIRVS = '^\s*(\$.*\.\.ng:|\#|\.(file|globl|ent|loc))'; - - $T_DOT_WORD = '\.(long|quad|byte|word)'; - $T_DOT_GLOBAL = '^\t\.globl'; - $T_HDR_literal = "\.rdata\n\t\.align 3\n"; - $T_HDR_misc = "\.text\n\t\.align 3\n"; - $T_HDR_data = "\.data\n\t\.align 3\n"; - $T_HDR_rodata = "\.rdata\n\t\.align 3\n"; - $T_HDR_closure = "\.data\n\t\.align 3\n"; - $T_HDR_info = "\.text\n\t\.align 3\n"; - $T_HDR_entry = "\.text\n\t\.align 3\n"; - $T_HDR_vector = "\.text\n\t\.align 3\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^hppa/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^L\$C(\d+)$'; # regexp for what such a lbl looks like - $T_POST_LBL = ''; - - $T_MOVE_DIRVS = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)'; - $T_COPY_DIRVS = '^\s+\.(IMPORT|EXPORT)'; - - $T_DOT_WORD = '\.(blockz|word|half|byte)'; - $T_DOT_GLOBAL = '^\s+\.EXPORT'; - $T_HDR_literal = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n"; - $T_HDR_misc = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_data = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_rodata = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_closure = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n"; - $T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - $T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|nextstep3|cygwin32|mingw32)$/m ) { - # NeXT added but not tested. CaS - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = 'L'; - $T_X86_PRE_LLBL = 'L'; - $T_X86_BADJMP = '^\tjmp [^L\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|stab|lcomm)'; - $T_DOT_WORD = '\.(long|word|value|byte|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.text\n\t\.align 4\n"; - $T_HDR_misc = "\.text\n\t\.align 4,0x90\n"; - $T_HDR_data = "\.data\n\t\.align 4\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding - $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?) - $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|gnu|freebsd|dragonfly|netbsd|openbsd|kfreebsdgnu)$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = # regexp that says what comes before APP/NO_APP - ($TargetPlatform =~ /-(linux|gnu|freebsd|dragonfly|netbsd|openbsd)$/m) ? '#' : '/' ; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = '\.L'; - $T_X86_PRE_LLBL = '.L'; - $T_X86_BADJMP = '^\tjmp\s+[^\.\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - if ( $TargetPlatform =~ /solaris2/m ) { - # newer Solaris linkers are picky about .size information, so - # omit it (see #1421) - $T_COPY_DIRVS = '^\s*\.(globl|local)'; - } else { - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - } - - $T_DOT_WORD = '\.(long|value|word|byte|zero)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11) - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 4\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?) - $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^ia64-.*-linux$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*\.(global|proc|pred\.safe_across_calls|text|data|section|subsection|align|size|type|ident)\s+.*\n)'; - $T_COPY_DIRVS = '\.(global|proc)'; - - $T_DOT_WORD = '\.(long|value|byte|zero)'; - $T_DOT_GLOBAL = '\.global'; - $T_HDR_literal = "\.section\t\.rodata\n"; - $T_HDR_misc = "\.text\n\t\.align 16\n"; # May contain code; align like 'entry' - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n"; - $T_HDR_closure = "\.data\n\t\.align 8\n"; - $T_HDR_info = "\.text\n\t\.align 8\n"; - $T_HDR_entry = "\.text\n\t\.align 16\n"; - $T_HDR_vector = "\.text\n\t\.align 8\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd|freebsd|dragonfly|netbsd|kfreebsdgnu)$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; - $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*\.(globl|text|data|section|align|size|type|ident|local)([ \t].*)?\n)'; - $T_COPY_DIRVS = '\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(quad|long|value|byte|zero)'; - $T_DOT_GLOBAL = '\.global'; - - $T_HDR_literal16 = "\.section\t\.rodata.cst16\n\t.align 16\n"; - $T_HDR_literal = "\.section\t\.rodata\n"; - - $T_HDR_misc = "\.text\n\t\.align 8\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n"; - - # the assembler on x86_64/Linux refuses to generate code for - # .quad x - y - # where x is in the text section and y in the rodata section. - # It works if y is in the text section, though. This is probably - # going to cause difficulties for PIC, I imagine. - # - # See Note [x86-64-relative] in includes/InfoTables.h - $T_HDR_relrodata= "\.text\n\t\.align 8\n"; - - $T_HDR_closure = "\.data\n\t\.align 8\n"; - $T_HDR_info = "\.text\n\t\.align 8\n"; - $T_HDR_entry = "\.text\n\t\.align 8\n"; - $T_HDR_vector = "\.text\n\t\.align 8\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/m ) { - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^# MAY NOT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)'; - $T_COPY_DIRVS = '\.(globl|proc|stab)'; - - $T_DOT_WORD = '\.long'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_literal = "\.text\n\t\.even\n"; - $T_HDR_misc = "\.text\n\t\.even\n"; - $T_HDR_data = "\.data\n\t\.even\n"; - $T_HDR_rodata = "\.text\n\t\.even\n"; - $T_HDR_closure = "\.data\n\t\.even\n"; - $T_HDR_info = "\.text\n\t\.even\n"; - $T_HDR_entry = "\.text\n\t\.even\n"; - $T_HDR_vector = "\.text\n\t\.even\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^mips-.*/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '^\s*#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\$LC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)'; - $T_COPY_DIRVS = '\.(globl|ent)'; - - $T_DOT_WORD = '\.word'; - $T_DOT_GLOBAL = '^\t\.globl'; - $T_HDR_literal = "\t\.rdata\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.rdata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc-apple-darwin.*/m ) { - # Apple PowerPC Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.const\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m ) { - # Apple i386 Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - $T_X86_PRE_LLBL_PAT = 'L'; - $T_X86_PRE_LLBL = 'L'; - $T_X86_BADJMP = '^\tjmp [^L\*]'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n"; - $T_HDR_literal = "\t\.const\n\t\.align 4\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^x86_64-apple-darwin.*/m ) { - # Apple amd64 Darwin/MacOS X. - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.align \d+|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)'; - $T_COPY_DIRVS = '\.(globl|lcomm)'; - - $T_DOT_WORD = '\.(quad|long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n"; - $T_HDR_literal = "\t\.const\n\t\.align 4\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.const\n\t\.align 2\n"; - $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m ) { - # PowerPC Linux - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^powerpc64-.*-linux/m ) { - # PowerPC 64 Linux - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = '\.'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)'; - $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)'; - - $T_DOT_WORD = '\.(long|short|byte|fill|space)'; - $T_DOT_GLOBAL = '\.globl'; - $T_HDR_toc = "\.toc\n"; - $T_HDR_literal = "\t\.section\t\".toc\",\"aw\"\n"; - $T_HDR_misc = "\t\.text\n\t\.align 2\n"; - $T_HDR_data = "\t\.data\n\t\.align 2\n"; - $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n"; - $T_HDR_closure = "\t\.data\n\t\.align 2\n"; - $T_HDR_info = "\t\.text\n\t\.align 2\n"; - $T_HDR_entry = "\t\.text\n\t\.align 2\n"; - $T_HDR_vector = "\t\.text\n\t\.align 2\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-(solaris2|openbsd)/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = 'DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.stab.*|\s*\.section.*|\s+\.type.*|\s+\.size.*)\n)'; - $T_COPY_DIRVS = '\.(global|local|proc|stab)'; - - $T_DOT_WORD = '\.(long|word|byte|half|skip|uahalf|uaword)'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/m ) { - - $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) - $T_US = '_'; # _ if symbols have an underscore on the front - $T_PRE_APP = '^# DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^LC(\d+):$'; - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)'; - $T_COPY_DIRVS = '\.(global|proc|stab)'; - - $T_DOT_WORD = '\.word'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^sparc-.*-linux/m ) { - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front - $T_PRE_APP = '#'; # regexp that says what comes before APP/NO_APP - # Probably doesn't apply anyway - $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like - $T_POST_LBL = ':'; - - $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.seg|\.stab.*|\s+?\.section.*|\s+\.type.*|\s+\.size.*)\n)'; - $T_COPY_DIRVS = '\.(global|local|globl|proc|stab)'; - - $T_DOT_WORD = '\.(long|word|nword|xword|byte|half|short|skip|uahalf|uaword)'; - $T_DOT_GLOBAL = '^\t\.global'; - $T_HDR_literal = "\.text\n\t\.align 8\n"; - $T_HDR_misc = "\.text\n\t\.align 4\n"; - $T_HDR_data = "\.data\n\t\.align 8\n"; - $T_HDR_rodata = "\.text\n\t\.align 4\n"; - $T_HDR_closure = "\.data\n\t\.align 4\n"; - $T_HDR_info = "\.text\n\t\.align 4\n"; - $T_HDR_entry = "\.text\n\t\.align 4\n"; - $T_HDR_vector = "\.text\n\t\.align 4\n"; - - #--------------------------------------------------------# - } else { - print STDERR "$Pgm: don't know how to mangle assembly language for: $TargetPlatform\n"; - exit 1; - } - - if($T_HDR_relrodata eq "") { - # default values: - # relrodata defaults to rodata. - $T_HDR_relrodata = $T_HDR_rodata; - } - -if ( 0 ) { -print STDERR "T_STABBY: $T_STABBY\n"; -print STDERR "T_US: $T_US\n"; -print STDERR "T_PRE_APP: $T_PRE_APP\n"; -print STDERR "T_CONST_LBL: $T_CONST_LBL\n"; -print STDERR "T_POST_LBL: $T_POST_LBL\n"; -if ( $TargetPlatform =~ /^i386-/m ) { - print STDERR "T_X86_PRE_LLBL_PAT: $T_X86_PRE_LLBL_PAT\n"; - print STDERR "T_X86_PRE_LLBL: $T_X86_PRE_LLBL\n"; - print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n"; -} -print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n"; -print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n"; -print STDERR "T_DOT_WORD: $T_DOT_WORD\n"; -print STDERR "T_HDR_literal: $T_HDR_literal\n"; -print STDERR "T_HDR_misc: $T_HDR_misc\n"; -print STDERR "T_HDR_data: $T_HDR_data\n"; -print STDERR "T_HDR_rodata: $T_HDR_rodata\n"; -print STDERR "T_HDR_closure: $T_HDR_closure\n"; -print STDERR "T_HDR_info: $T_HDR_info\n"; -print STDERR "T_HDR_entry: $T_HDR_entry\n"; -print STDERR "T_HDR_vector: $T_HDR_vector\n"; -} - -} -\end{code} - -%************************************************************************ -%* * -\subsection{Mangle away} -%* * -%************************************************************************ - -\begin{code} -sub mangle_asm { - local($in_asmf, $out_asmf) = @_; - local($i, $c); - - # ia64-specific information for code chunks - my $ia64_locnum; - my $ia64_outnum; - - &init_TARGET_STUFF(); - &init_FUNNY_THINGS(); - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - # read whole file, divide into "chunks": - # record some info about what we've found... - - @chk = (); # contents of the chunk - $numchks = 0; # number of them - @chkcat = (); # what category of thing in each chunk - @chksymb = (); # what symbol(base) is defined in this chunk - %entrychk = (); # ditto, its entry code - %closurechk = (); # ditto, the (static) closure - %srtchk = (); # ditto, its SRT (for top-level things) - %infochk = (); # given a symbol base, say what chunk its info tbl is in - %vectorchk = (); # ditto, return vector table - $EXTERN_DECLS = ''; # .globl .text (MIPS only) - - $i = 0; $chkcat[0] = 'misc'; $chk[0] = ''; - - while () { - tr/\r//d if $TargetPlatform =~ /-mingw32$/m; # In case Perl doesn't convert line endings - next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/om; - next if $T_STABBY && /^\.stab.*ghc.*c_ID/m; - next if /^\t\.def.*endef$/m; - next if /${T_PRE_APP}(NO_)?APP/om; - next if /^;/m && $TargetPlatform =~ /^hppa/m; - - next if /(^$|^\t\.file\t|^ # )/m && $TargetPlatform =~ /(^mips-|^ia64-|-mingw32$)/m; - - if ( $TargetPlatform =~ /^mips-/m - && /^\t\.(globl\S+\.text|comm\t)/m ) { - $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/m; - # Treat .comm variables as data. These show up in two (known) places: - # - # - the module_registered variable used in the __stginit fragment. - # even though these are declared static and initialised, gcc 3.3 - # likes to make them .comm, presumably to save space in the - # object file. - # - # - global variables used to pass arguments from C to STG in - # a foreign export. (is this still true? --SDM) - # - } elsif ( /^\t\.comm.*$/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - # Labels ending "_str": these are literal strings. - } elsif ( /^${T_US}([A-Za-z0-9_]+)_str${T_POST_LBL}$/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'relrodata'; - $chksymb[$i] = ''; - } elsif ( $TargetPlatform =~ /-darwin/m - && (/^\s*\.subsections_via_symbols/m - ||/^\s*\.no_dead_strip.*/m)) { - # Don't allow Apple's linker to do any dead-stripping of symbols - # in this file, because it will mess up info-tables in mangled - # code. - # The .no_dead_strip directives are actually put there by - # the gcc3 "used" attribute on entry points. - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && ( - /^\s*\.picsymbol_stub/m - || /^\s*\.section __TEXT,__picsymbol_stub\d,.*/m - || /^\s*\.section __TEXT,__picsymbolstub\d,.*/m - || /^\s*\.symbol_stub/m - || /^\s*\.section __TEXT,__symbol_stub\d,.*/m - || /^\s*\.section __TEXT,__symbolstub\d,.*/m - || /^\s*\.lazy_symbol_pointer/m - || /^\s*\.non_lazy_symbol_pointer/m - || /^\s*\.section __IMPORT.*/m)) - { - $chk[++$i] = $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - $dyld_section = $_; - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.data/m) - { # non_lazy_symbol_ptrs that point to local symbols - $chk[++$i] = $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - $dyld_section = $_; - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.align/m) - { # non_lazy_symbol_ptrs that point to local symbols - $dyld_section .= $_; - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^L_.*:$/m) - { # non_lazy_symbol_ptrs that point to local symbols - $chk[++$i] = $dyld_section . $_; - $chkcat[$i] = 'dyld'; - $chksymb[$i] = ''; - - } elsif ( /^\s+/m ) { # most common case first -- a simple line! - # duplicated from the bottom - - $chk[$i] .= $_; - - } elsif ( /\.\.ng:$/m && $TargetPlatform =~ /^alpha-/m ) { - # Alphas: Local labels not to be confused with new chunks - $chk[$i] .= $_; - # NB: all the rest start with a non-space - - } elsif ( $TargetPlatform =~ /^mips-/m - && /^\d+:/m ) { # a funny-looking very-local label - $chk[$i] .= $_; - - } elsif ( /$T_CONST_LBL/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'literal'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}__stg_split_marker(\d*)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'splitmarker'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/om ) { - $symb = $1; - $chk[++$i] = $_; - $chkcat[$i] = 'infotbl'; - $chksymb[$i] = $symb; - - die "Info table already? $symb; $i\n" if defined($infochk{$symb}); - - $infochk{$symb} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_(entry|ret)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'entry'; - $chksymb[$i] = $1; - - $entrychk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'closure'; - $chksymb[$i] = $1; - - $closurechk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_srt${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'srt'; - $chksymb[$i] = $1; - - $srtchk{$1} = $i; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_ct${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}(stg_ap_stack_entries|stg_stack_save_entries|stg_arg_bitmaps)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/om ) { - ; # toss it - - } elsif ( /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/om - || /^${T_US}.*_CAT${T_POST_LBL}$/om # PROF: _entryname_CAT - || /^${T_US}.*_done${T_POST_LBL}$/om # PROF: _module_done - || /^${T_US}_module_registered${T_POST_LBL}$/om # PROF: _module_registered - ) { - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/m && $TargetPlatform =~ /^hppa/m ) { - $chk[++$i] = $_; - $chkcat[$i] = 'bss'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_cc(s)?${T_POST_LBL}$/om ) { - # all CC_ symbols go in the data section... - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_hpc${T_POST_LBL}$/om ) { - # hpc shares tick boxes across modules - $chk[++$i] = $_; - $chkcat[$i] = 'data'; - $chksymb[$i] = ''; - - } elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = ''; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_vtbl${T_POST_LBL}$/om ) { - $chk[++$i] = $_; - $chkcat[$i] = 'vector'; - $chksymb[$i] = $1; - - $vectorchk{$1} = $i; - - } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/m - && /^[A-Za-z0-9][A-Za-z0-9_]*:/m ) { - # Some Solaris system headers contain function definitions (as - # opposed to mere prototypes), which end up in the .hc file when - # a Haskell module foreign imports the corresponding system - # functions (most notably stat()). We put them into the text - # segment. Note that this currently does not extend to function - # names starting with an underscore. - # - chak 7/2001 - $chk[++$i] = $_; - $chkcat[$i] = 'misc'; - $chksymb[$i] = $1; - - } elsif ( $TargetPlatform =~ /^i386-apple-darwin/m && /^(___i686\.get_pc_thunk\.[abcd]x):/om) { - # To handle PIC on Darwin/x86, we need to appropriately pass through - # the get_pc_thunk functions. The need to be put into a special section - # marked as coalesced (otherwise the .weak_definition doesn't work - # on Darwin). - $chk[++$i] = $_; - $chkcat[$i] = 'get_pc_thunk'; - $chksymb[$i] = $1; - - } elsif ( /^${T_US}[A-Za-z0-9_]/om - && ( $TargetPlatform !~ /^hppa/m # need to avoid local labels in this case - || ! /^L\$\d+$/m ) - && ( $TargetPlatform !~ /^powerpc64/m # we need to avoid local labels in this case - || ! /^\.L\d+:$/m ) ) { - local($thing); - chop($thing = $_); - $thing =~ s/:$//m; - $chk[++$i] = $_; - $chksymb[$i] = ''; - if ( - /^${T_US}stg_.*${T_POST_LBL}$/om # RTS internals - || /^${T_US}__stg_.*${T_POST_LBL}$/om # more RTS internals - || /^${T_US}__fexp_.*${T_POST_LBL}$/om # foreign export - || /^${T_US}.*_slow${T_POST_LBL}$/om # slow entry - || /^${T_US}__stginit.*${T_POST_LBL}$/om # __stginit - || /^${T_US}.*_btm${T_POST_LBL}$/om # large bitmaps - || /^${T_US}.*_fast${T_POST_LBL}$/om # primops - || /^_uname:/om # x86/Solaris2 - ) - { - $chkcat[$i] = 'misc'; - } elsif ( - /^${T_US}.*_srtd${T_POST_LBL}$/om # large bitmaps - || /^${T_US}.*_closure_tbl${T_POST_LBL}$/om # closure tables - ) - { - $chkcat[$i] = 'relrodata'; - } else - { - print STDERR "Warning: retaining unknown function \`$thing' in output from C compiler\n"; - $chkcat[$i] = 'unknown'; - } - - } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m && /^\.LCTOC1 = /om ) { - # PowerPC Linux's large-model PIC (-fPIC) generates a gobal offset - # table "by hand". Be sure to copy it over. - # Note that this label and all entries in the table should actually - # go into the .got2 section, but it isn't easy to distinguish them - # from other constant literals (.LC\d+), so we just put everything - # in .rodata. - $chk[++$i] = $_; - $chkcat[$i] = 'literal'; - $chksymb[$i] = 'LCTOC1'; - } else { # simple line (duplicated at the top) - - $chk[$i] .= $_; - } - } - $numchks = $#chk + 1; - $chk[$numchks] = ''; # We might push .note.GNU-stack into this - $chkcat[$numchks] = 'verbatim'; # If we do, write it straight back out - - # open CHUNKS, ">/tmp/chunks1" or die "Cannot open /tmp/chunks1: $!\n"; - # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } - # close CHUNKS; - - # the division into chunks is imperfect; - # we throw some things over the fence into the next - # chunk. - # - # also, there are things we would like to know - # about the whole module before we start spitting - # output. - - local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/m) ? 1 : 0; - local($FIRST_TOSSABLE ) = ($TargetPlatform =~ /^(hppa|mips-)/m) ? 1 : 0; - -# print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n"; - - # Alphas: NB: we start meddling at chunk 1, not chunk 0 - # The first ".rdata" is quite magical; as of GCC 2.7.x, it - # spits a ".quad 0" in after the very first ".rdata"; we - # detect this special case (tossing the ".quad 0")! - local($magic_rdata_seen) = 0; - - # HPPAs, MIPSen: also start medding at chunk 1 - - for ($i = $FIRST_TOSSABLE; $i < $numchks; $i++) { - $c = $chk[$i]; # convenience copy - -# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c; - - # toss all prologue stuff; HPPA is pretty weird - # (see elsewhere) - $c = &hppa_mash_prologue($c) if $TargetPlatform =~ /^hppa-/m; - - undef $ia64_locnum; - undef $ia64_outnum; - - # be slightly paranoid to make sure there's - # nothing surprising in there - if ( $c =~ /--- BEGIN ---/m ) { - if (($p, $r) = split(/--- BEGIN ---/m, $c)) { - - # remove junk whitespace around the split point - $p =~ s/\t+$//m; - $r =~ s/^\s*\n//m; - - if ($TargetPlatform =~ /^i386-/m) { - if ($p =~ /^\tsubl\s+\$(\d+),\s*\%esp\n/m) { - if ($1 >= 8192) { - die "Error: reserved stack space exceeded!\n Possible workarounds: compile with -fasm, or try another version of gcc.\n" - } - } - - # gcc 3.4.3 puts this kind of stuff in the prologue, eg. - # when compiling PrimOps.cmm with -optc-O2: - # xorl %ecx, %ecx - # xorl %edx, %edx - # movl %ecx, 16(%esp) - # movl %edx, 20(%esp) - # but then the code of the function doesn't assume - # anything about the contnets of these stack locations. - # I think it's to do with the use of inline functions for - # PK_Word64() and friends, where gcc is initialising the - # contents of the struct to zero, and failing to optimise - # away the initialisation. Let's live dangerously and - # discard these initalisations. - - $p =~ s/^\tpushl\s+\%e(di|si|bx)\n//gm; - $p =~ s/^\txorl\s+\%e(ax|cx|dx),\s*\%e(ax|cx|dx)\n//gm; - $p =~ s/^\tmovl\s+\%e(ax|cx|dx|si|di),\s*\d*\(\%esp\)\n//gm; - $p =~ s/^\tmovl\s+\$\d+,\s*\d*\(\%esp\)\n//gm; - $p =~ s/^\tsubl\s+\$\d+,\s*\%esp\n//m; - $p =~ s/^\tmovl\s+\$\d+,\s*\%eax\n\tcall\s+__alloca\n//m if ($TargetPlatform =~ /^.*-(cygwin32|mingw32)/m); - - if ($TargetPlatform =~ /^i386-apple-darwin/m) { - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = ""; - $pcrel_reg = $p; - $pcrel_reg =~ s/(.|\n)*.*___i686\.get_pc_thunk\.([abcd]x)\n(.|\n)*/$2/m or $pcrel_reg = ""; - $p =~ s/^\s+call\s+___i686\.get_pc_thunk\..x//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - - if ($pcrel_reg eq "bx") { - # Bad gcc. Goes and uses %ebx, our BaseReg, for PIC. Bad gcc. - die "Darwin/x86: -fPIC -via-C doesn't work yet, use -fasm. Aborting." - } - } - - } elsif ($TargetPlatform =~ /^x86_64-/m) { - $p =~ s/^\tpushq\s+\%r(bx|bp|12|13|14)\n//gm; - $p =~ s/^\tmovq\s+\%r(bx|bp|12|13|14),\s*\d*\(\%rsp\)\n//gm; - $p =~ s/^\tsubq\s+\$\d+,\s*\%rsp\n//m; - - } elsif ($TargetPlatform =~ /^ia64-/m) { - $p =~ s/^\t\.prologue .*\n//m; - - # Record the number of local and out registers for register relocation later - $p =~ s/^\t\.save ar\.pfs, r\d+\n\talloc r\d+ = ar\.pfs, 0, (\d+), (\d+), 0\n//m; - $ia64_locnum = $1; - $ia64_outnum = $2; - - $p =~ s/^\t\.fframe \d+\n\tadds r12 = -\d+, r12\n//m; - $p =~ s/^\t\.save rp, r\d+\n\tmov r\d+ = b0\n//m; - - # Ignore save/restore of these registers; they're taken - # care of in StgRun() - $p =~ s/^\t\.save ar\.lc, r\d+\n//m; - $p =~ s/^\t\.save pr, r\d+\n//m; - $p =~ s/^\tmov r\d+ = ar\.lc\n//m; - $p =~ s/^\tmov r\d+ = pr\n//m; - - # Remove .proc and .body directives - $p =~ s/^\t\.proc [a-zA-Z0-9_.]+#\n//m; - $p =~ s/^\t\.body\n//m; - - # If there's a label, move it to the body - if ($p =~ /^[a-zA-Z0-9.]+:\n/m) { - $p = $` . $'; - $r = $& . $r; - } - - # Remove floating-point spill instructions. - # Only fp registers 2-5 and 16-23 are saved by the runtime. - if ($p =~ s/^\tstf\.spill \[r1[4-9]\] = f([2-5]|1[6-9]|2[0-3])(, [0-9]+)?\n//gm) { - # Being paranoid, only try to remove these if we saw a - # spill operation. - $p =~ s/^\tmov r1[4-9] = r12\n//m; - $p =~ s/^\tadds r1[4-9] = -[0-9]+, r12\n//gm; - $p =~ s/^\t\.save\.f 0x[0-9a-fA-F]\n//gm; - $p =~ s/^\t\.save\.gf 0x0, 0x[0-9a-fA-F]+\n//gm; - } - - $p =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions - $p =~ s/^\t\.(mii|mmi|mfi)\n//gm; # bundling is no longer sensible - $p =~ s/^\t;;\n//gm; # discard stops - $p =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments - - # GCC 3.3 saves r1 in the prologue, move this to the body - # (Does this register get restored anywhere?) - if ($p =~ /^\tmov r\d+ = r1\n/m) { - $p = $` . $'; - $r = $& . $r; - } - } elsif ($TargetPlatform =~ /^m68k-/m) { - $p =~ s/^\tlink a6,#-?\d.*\n//m; - $p =~ s/^\tpea a6@\n\tmovel sp,a6\n//m; - # The above showed up in the asm code, - # so I added it here. - # I hope it's correct. - # CaS - $p =~ s/^\tmovel d2,sp\@-\n//m; - $p =~ s/^\tmovel d5,sp\@-\n//m; # SMmark.* only? - $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//m; # SMmark.* only? - } elsif ($TargetPlatform =~ /^mips-/m) { - # the .frame/.mask/.fmask that we use is the same - # as that produced by GCC for miniInterpret; this - # gives GDB some chance of figuring out what happened - $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n"; - $p =~ s/^\t\.(frame).*\n/__FRAME__/gm; - $p =~ s/^\t\.(mask|fmask).*\n//gm; - $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/m; # 16 + 100 4-byte args - $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//m; - $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//m; - $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//m; - $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//m; - $p =~ s/__FRAME__/$FRAME/m; - } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) { - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = ""; - - $p =~ s/^\tmflr r0\n//m; - $p =~ s/^\tbl saveFP # f\d+\n//m; - $p =~ s/^\tbl saveFP ; save f\d+-f\d+\n//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - $p =~ s/^\tstmw r\d+,-\d+\(r1\)\n//m; - $p =~ s/^\tstfd f\d+,-\d+\(r1\)\n//gm; - $p =~ s/^\tstw r0,\d+\(r1\)\n//gm; - $p =~ s/^\tstwu r1,-\d+\(r1\)\n//m; - $p =~ s/^\tstw r\d+,-\d+\(r1\)\n//gm; - $p =~ s/^\tbcl 20,31,\"?L\d+\$pb\"?\n//m; - $p =~ s/^\"?L\d+\$pb\"?:\n//m; - $p =~ s/^\tmflr r31\n//m; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli r\d+,0\n//gm; - $p =~ s/^\tstw r\d+,\d+\(r1\)\n//gm; - } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m) { - $p =~ s/^\tmflr 0\n//m; - $p =~ s/^\tstmw \d+,\d+\(1\)\n//m; - $p =~ s/^\tstfd \d+,\d+\(1\)\n//gm; - $p =~ s/^\tstw r0,8\(1\)\n//m; - $p =~ s/^\tstwu 1,-\d+\(1\)\n//m; - $p =~ s/^\tstw \d+,\d+\(1\)\n//gm; - - # GCC's "large-model" PIC (-fPIC) - $pcrel_label = $p; - $pcrel_label =~ s/(.|\n)*^.LCF(\d+):\n(.|\n)*/$2/m or $pcrel_label = ""; - - $p =~ s/^\tbcl 20,31,.LCF\d+\n//m; - $p =~ s/^.LCF\d+:\n//m; - $p =~ s/^\tmflr 30\n//m; - $p =~ s/^\tlwz 0,\.LCL\d+-\.LCF\d+\(30\)\n//m; - $p =~ s/^\tadd 30,0,30\n//m; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli \d+,0\n//gm; - $p =~ s/^\tstw \d+,\d+\(1\)\n//gm; - } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) { - $p =~ s/^\tmr 31,1\n//m; - $p =~ s/^\tmflr 0\n//m; - $p =~ s/^\tstmw \d+,\d+\(1\)\n//m; - $p =~ s/^\tstfd \d+,-?\d+\(1\)\n//gm; - $p =~ s/^\tstd r0,8\(1\)\n//m; - $p =~ s/^\tstdu 1,-\d+\(1\)\n//m; - $p =~ s/^\tstd \d+,-?\d+\(1\)\n//gm; - - # This is bad: GCC 3 seems to zero-fill some local variables in the prologue - # under some circumstances, only when generating position dependent code. - # I have no idea why, and I don't think it is necessary, so let's toss it. - $p =~ s/^\tli \d+,0\n//gm; - $p =~ s/^\tstd \d+,\d+\(1\)\n//gm; - } else { - print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n"; - } - - # HWL HACK: dont die, just print a warning - #print stderr "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/; - die "Prologue junk?: $p\n" if $p =~ /^\s+[^\s\.]/m; - - # For PIC, we want to keep part of the prologue - if ($TargetPlatform =~ /^powerpc-apple-darwin.*/m && $pcrel_label ne "") { - # Darwin: load the current instruction pointer into register r31 - $p .= "bcl 20,31,$pcrel_label\n"; - $p .= "$pcrel_label:\n"; - $p .= "\tmflr r31\n"; - } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m && $pcrel_label ne "") { - # Linux: load the GOT pointer into register 30 - $p .= "\tbcl 20,31,.LCF$pcrel_label\n"; - $p .= ".LCF$pcrel_label:\n"; - $p .= "\tmflr 30\n"; - $p .= "\tlwz 0,.LCL$pcrel_label-.LCF$pcrel_label(30)\n"; - $p .= "\tadd 30,0,30\n"; - } elsif ($TargetPlatform =~ /^i386-apple-darwin.*/m && $pcrel_label ne "") { - $p .= "\tcall ___i686.get_pc_thunk.$pcrel_reg\n"; - $p .= "$pcrel_label:\n"; - } - - # glue together what's left - $c = $p . $r; - } - } - - if ( $TargetPlatform =~ /^mips-/m ) { - # MIPS: first, this basic sequence may occur "--- END ---" or not - $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/m; - } - - # toss all epilogue stuff; again, paranoidly - if ( $c =~ /--- END ---/m ) { - # Gcc may decide to replicate the function epilogue. We want - # to process all epilogues, so we split the function and then - # loop here. - @fragments = split(/--- END ---/m, $c); - $r = shift(@fragments); - - # Rebuild `c'; processed fragments will be appended to `c' - $c = $r; - - foreach $e (@fragments) { - # etail holds code that is after the epilogue in the assembly-code - # layout and should not be filtered as part of the epilogue. - $etail = ""; - if ($TargetPlatform =~ /^i386-/m) { - $e =~ s/^\tret\n//m; - $e =~ s/^\tpopl\s+\%edi\n//m; - $e =~ s/^\tpopl\s+\%esi\n//m; - $e =~ s/^\tpopl\s+\%edx\n//m; - $e =~ s/^\tpopl\s+\%ecx\n//m; - $e =~ s/^\taddl\s+\$\d+,\s*\%esp\n//m; - $e =~ s/^\tsubl\s+\$-\d+,\s*\%esp\n//m; - } elsif ($TargetPlatform =~ /^ia64-/m) { - # The epilogue is first split into: - # $e, the epilogue code (up to the return instruction) - # $etail, non-epilogue code (after the return instruction) - # The return instruction is stripped in the process. - if (!(($e, $etail) = split(/^\tbr\.ret\.sptk\.many b0\n/m, $e))) { - die "Epilogue doesn't seem to have one return instruction: $e\n"; - } - # Remove 'endp' directive from the tail - $etail =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m; - - # If a return value is saved here, discard it - $e =~ s/^\tmov r8 = r14\n//m; - - # Remove floating-point fill instructions. - # Only fp registers 2-5 and 16-23 are saved by the runtime. - if ($e =~ s/^\tldf\.fill f([2-5]|1[6-9]|2[0-3]) = \[r1[4-9]\](, [0-9]+)?\n//gm) { - # Being paranoid, only try to remove this if we saw a fill - # operation. - $e =~ s/^\tadds r1[4-9] = [0-9]+, r12//gm; - } - - $e =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions - $e =~ s/^\tmov ar\.pfs = r\d+\n//m; - $e =~ s/^\tmov ar\.lc = r\d+\n//m; - $e =~ s/^\tmov pr = r\d+, -1\n//m; - $e =~ s/^\tmov b0 = r\d+\n//m; - $e =~ s/^\t\.restore sp\n\tadds r12 = \d+, r12\n//m; - #$e =~ s/^\tbr\.ret\.sptk\.many b0\n//; # already removed - $e =~ s/^\t\.(mii|mmi|mfi|mib)\n//gm; # bundling is no longer sensible - $e =~ s/^\t;;\n//gm; # discard stops - stop at end of body is sufficient - $e =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments - } elsif ($TargetPlatform =~ /^m68k-/m) { - $e =~ s/^\tunlk a6\n//m; - $e =~ s/^\trts\n//m; - } elsif ($TargetPlatform =~ /^mips-/m) { - $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//m; - $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//m; - $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//m; - $e =~ s/^\tj\t\$31\n//m; - } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) { - $e =~ s/^\taddi r1,r1,\d+\n//m; - $e =~ s/^\tlwz r\d+,\d+\(r1\)\n//m; - $e =~ s/^\tlmw r\d+,-\d+\(r1\)\n//m; - $e =~ s/^\tmtlr r0\n//m; - $e =~ s/^\tblr\n//m; - $e =~ s/^\tb restFP ;.*\n//m; - } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) { - $e =~ s/^\tmr 3,0\n//m; - $e =~ s/^\taddi 1,1,\d+\n//m; - $e =~ s/^\tld 0,16\(1\)\n//m; - $e =~ s/^\tmtlr 0\n//m; - - # callee-save registers - $e =~ s/^\tld \d+,-?\d+\(1\)\n//gm; - $e =~ s/^\tlfd \d+,-?\d+\(1\)\n//gm; - - # get rid of the debug junk along with the blr - $e =~ s/^\tblr\n\t.long .*\n\t.byte .*\n//m; - - # incase we missed it with the last one get the blr alone - $e =~ s/^\tblr\n//m; - } else { - print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n"; - } - - print STDERR "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/m; - - # glue together what's left - $c .= $e . $etail; - } - $c =~ s/\n\t\n/\n/m; # junk blank line - } - else { - if ($TargetPlatform =~ /^ia64-/m) { - # On IA64, remove an .endp directive even if no epilogue was found. - # Code optimizations may have removed the "--- END ---" token. - $c =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m; - } - } - - # On SPARCs, we don't do --- BEGIN/END ---, we just - # toss the register-windowing save/restore/ret* instructions - # directly unless they've been generated by function definitions in header - # files on Solaris: - if ( $TargetPlatform =~ /^sparc-/m ) { - if ( ! ( $TargetPlatform =~ /solaris2$/m && $chkcat[$i] eq 'unknown' )) { - $c =~ s/^\t(save.*|restore.*|ret|retl)\n//gm; - } - # throw away PROLOGUE comments - $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//m; - } - - # On Alphas, the prologue mangling is done a little later (below) - - # toss all calls to __DISCARD__ - $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//gom; - $c =~ s/^\tjsr\s+\$26\s*,\s*${T_US}__DISCARD__\n//gom if $TargetPlatform =~ /^alpha-/m; - $c =~ s/^\tbl\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /^powerpc-apple-darwin.*/m; - $c =~ s/^\tbl\s+__DISCARD__(\@plt)?\n//gom if $TargetPlatform =~ /^powerpc-.*-linux/m; - $c =~ s/^\tbl\s+\.__DISCARD__\n\s+nop\n//gom if $TargetPlatform =~ /^powerpc64-.*-linux/m; - $c =~ s/^\tcall\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /i386-apple-darwin.*/m; - - # IA64: fix register allocation; mangle tailcalls into jumps - if ($TargetPlatform =~ /^ia64-/m) { - ia64_rename_registers($ia64_locnum, $ia64_outnum) if (defined($ia64_locnum)); - ia64_mangle_tailcalls(); - } - - # MIPS: that may leave some gratuitous asm macros around - # (no harm done; but we get rid of them to be tidier) - $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/m - if $TargetPlatform =~ /^mips-/m; - - # toss stack adjustment after DoSparks - $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/gm - if $TargetPlatform =~ /^m68k-/m; # this looks old... - - if ( $TargetPlatform =~ /^alpha-/m && - ! $magic_rdata_seen && - $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/m ) { - $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/m; - $magic_rdata_seen = 1; - } - - # pick some end-things and move them to the next chunk - - # pin a funny end-thing on (for easier matching): - $c .= 'FUNNY#END#THING'; - - while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/om ) { - - $to_move = $1; - - # on x86 we try not to copy any directives into a literal - # chunk, rather we keep looking for the next real chunk. This - # is because we get things like - # - # .globl blah_closure - # .LC32 - # .string "..." - # blah_closure: - # ... - # - if ( $TargetPlatform =~ /^(i386|sparc|powerpc)/m && $to_move =~ /${T_COPY_DIRVS}/m ) { - $j = $i + 1; - while ( $j < $numchks && $chk[$j] =~ /$T_CONST_LBL/m) { - $j++; - } - if ( $j < $numchks ) { - $chk[$j] = $to_move . $chk[$j]; - } - } - - elsif ( ( $i < ($numchks - 1) - && ( $to_move =~ /${T_COPY_DIRVS}/m - || ( $TargetPlatform =~ /^hppa/m - && $to_move =~ /align/m - && $chkcat[$i+1] eq 'literal') - ) - ) - || ($to_move =~ /^[ \t]*\.section[ \t]+\.note\.GNU-stack,/m) - ) { - $chk[$i + 1] = $to_move . $chk[$i + 1]; - # otherwise they're tossed - } - - $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/om; - } - - if ( $TargetPlatform =~ /^alpha-/m && $c =~ /^\t\.ent\s+(\S+)/m ) { - $ent = $1; - # toss all prologue stuff, except for loading gp, and the ..ng address - unless ($c =~ /\.ent.*\n\$.*\.\.ng:/m) { - if (($p, $r) = split(/^\t\.prologue/m, $c)) { - # use vars '$junk'; # Unused? - if (($keep, $junk) = split(/\.\.ng:/m, $p)) { - $keep =~ s/^\t\.frame.*\n/\t.frame \$30,0,\$26,0\n/m; - $keep =~ s/^\t\.(mask|fmask).*\n//gm; - $c = $keep . "..ng:\n"; - } else { - print STDERR "malformed code block ($ent)?\n" - } - } - $c .= "\t.prologue" . $r; - } - } - - $c =~ s/FUNNY#END#THING//m; - -# print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c; - - $chk[$i] = $c; # update w/ convenience copy - } - - # open CHUNKS, ">/tmp/chunks2" or die "Cannot open /tmp/chunks2: $!\n"; - # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } - # close CHUNKS; - - if ( $TargetPlatform =~ /^alpha-/m ) { - # print out the header stuff first - $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/m; - print OUTASM $chk[0]; - - } elsif ( $TargetPlatform =~ /^hppa/m ) { - print OUTASM $chk[0]; - - } elsif ( $TargetPlatform =~ /^mips-/m ) { - $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0]; - - # get rid of horrible "Revision: .*$" strings - local(@lines0) = split(/\n/m, $chk[0]); - local($z) = 0; - while ( $z <= $#lines0 ) { - if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/m ) { - undef($lines0[$z]); - $z++; - while ( $z <= $#lines0 ) { - undef($lines0[$z]); - last if $lines0[$z] =~ /[,\t]0x0$/m; - $z++; - } - } - $z++; - } - $chk[0] = join("\n", @lines0); - $chk[0] =~ s/\n\n+/\n/m; - print OUTASM $chk[0]; - } - - # print out all the literal strings next - for ($i = 0; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'literal' ) { - - # HACK: try to detect 16-byte constants and align them - # on a 16-byte boundary. x86_64 sometimes needs 128-bit - # aligned constants, and so does Darwin/x86. - if ( $TargetPlatform =~ /^x86_64/m - || $TargetPlatform =~ /^i386-apple-darwin/m ) { - $z = $chk[$i]; - if ($z =~ /(\.long.*\n.*\.long.*\n.*\.long.*\n.*\.long|\.quad.*\n.*\.quad)/m) { - print OUTASM $T_HDR_literal16; - } else { - print OUTASM $T_HDR_literal; - } - } else { - print OUTASM $T_HDR_literal; - } - - print OUTASM $chk[$i]; - print OUTASM "; end literal\n" if $TargetPlatform =~ /^hppa/m; # for the splitter - - $chkcat[$i] = 'DONE ALREADY'; - } - } - - # on the HPPA, print out all the bss next - if ( $TargetPlatform =~ /^hppa/m ) { - for ($i = 1; $i < $numchks; $i++) { - if ( $chkcat[$i] eq 'bss' ) { - print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n"; - print OUTASM $chk[$i]; - - $chkcat[$i] = 'DONE ALREADY'; - } - } - } - - # $numchks + 1 as we have the extra one for .note.GNU-stack - for ($i = $FIRST_MANGLABLE; $i < $numchks + 1; $i++) { -# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n"; - - next if $chkcat[$i] eq 'DONE ALREADY'; - - if ( $chkcat[$i] eq 'misc' || $chkcat[$i] eq 'unknown' ) { - if ($chk[$i] ne '') { - print OUTASM $T_HDR_misc; - &print_doctored($chk[$i], 0); - } - - } elsif ( $chkcat[$i] eq 'verbatim' ) { - print OUTASM $chk[$i]; - - } elsif ( $chkcat[$i] eq 'toss' ) { - print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n"; - - } elsif ( $chkcat[$i] eq 'data' ) { - if ($chk[$i] ne '') { - print OUTASM $T_HDR_data; - print OUTASM $chk[$i]; - } - - } elsif ( $chkcat[$i] eq 'splitmarker' ) { - # we can just re-constitute this one... - # NB: we emit _three_ underscores no matter what, - # so ghc-split doesn't have to care. - print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n"; - - } elsif ( $chkcat[$i] eq 'closure' - || $chkcat[$i] eq 'srt' - || $chkcat[$i] eq 'infotbl' - || $chkcat[$i] eq 'entry') { # do them in that order - $symb = $chksymb[$i]; - - # CLOSURE - if ( defined($closurechk{$symb}) ) { - print OUTASM $T_HDR_closure; - print OUTASM $chk[$closurechk{$symb}]; - $chkcat[$closurechk{$symb}] = 'DONE ALREADY'; - } - - # SRT - if ( defined($srtchk{$symb}) ) { - print OUTASM $T_HDR_relrodata; - print OUTASM $chk[$srtchk{$symb}]; - $chkcat[$srtchk{$symb}] = 'DONE ALREADY'; - } - - # INFO TABLE - if ( defined($infochk{$symb}) ) { - - print OUTASM $T_HDR_info; - print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1); - - # entry code will be put here! - - $chkcat[$infochk{$symb}] = 'DONE ALREADY'; - } - - # ENTRY POINT - if ( defined($entrychk{$symb}) ) { - - $c = $chk[$entrychk{$symb}]; - - # If this is an entry point with an info table, - # eliminate the entry symbol and all directives involving it. - if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/m - && $TABLES_NEXT_TO_CODE eq "YES") { - @o = (); - foreach $l (split(/\n/m,$c)) { - next if $l =~ /^.*$symb_(entry|ret)${T_POST_LBL}/m; - - # If we have .type/.size direrctives involving foo_entry, - # then make them refer to foo_info instead. The information - # in these directives is used by the cachegrind annotator, - # so it is worthwhile keeping. - if ($l =~ /^\s*\.(type|size).*$symb_(entry|ret)/m) { - $l =~ s/$symb(_entry|_ret)/${symb}_info/gm; - push(@o,$l); - next; - } - next if $l =~ /^\s*\..*$symb.*\n?/m; - push(@o,$l); - } - $c = join("\n",@o) . "\n"; - } - - print OUTASM $T_HDR_entry; - - &print_doctored($c, 1); # NB: the 1!!! - - $chkcat[$entrychk{$symb}] = 'DONE ALREADY'; - } - - } elsif ( $chkcat[$i] eq 'vector' ) { - $symb = $chksymb[$i]; - - # VECTOR TABLE - if ( defined($vectorchk{$symb}) ) { - print OUTASM $T_HDR_vector; - print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); - - # direct return code will be put here! - $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; - - } elsif ( $TargetPlatform =~ /^alpha-/m ) { - # Alphas: the commented nop is for the splitter, to ensure - # that no module ends with a label as the very last - # thing. (The linker will adjust the label to point - # to the first code word of the next module linked in, - # even if alignment constraints cause the label to move!) - - print OUTASM "\t# nop\n"; - } - - } elsif ( $chkcat[$i] eq 'rodata' ) { - print OUTASM $T_HDR_rodata; - print OUTASM $chk[$i]; - $chkcat[$i] = 'DONE ALREADY'; - } elsif ( $chkcat[$i] eq 'relrodata' ) { - print OUTASM $T_HDR_relrodata; - print OUTASM $chk[$i]; - $chkcat[$i] = 'DONE ALREADY'; - } elsif ( $chkcat[$i] eq 'toc' ) { - # silly optimisation to print tocs, since they come in groups... - print OUTASM $T_HDR_toc; - local($j) = $i; - while ($chkcat[$j] eq 'toc') - { if ( $chk[$j] !~ /\.tc UpdatePAP\[TC\]/m # not needed: always turned into a jump. - ) - { - print OUTASM $chk[$j]; - } - $chkcat[$j] = 'DONE ALREADY'; - $j++; - } - - } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' ) { - # apple-darwin: dynamic linker stubs - if($chk[$i] !~ /\.indirect_symbol ___DISCARD__/m) - { # print them out unchanged, but remove the stubs for __DISCARD__ - print OUTASM $chk[$i]; - } - } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m && $chkcat[$i] eq 'get_pc_thunk' ) { - # i386-apple-darwin: __i686.get_pc_thunk.[abcd]x - print OUTASM ".section __TEXT,__textcoal_nt,coalesced,no_toc\n"; - print OUTASM $chk[$i]; - } else { - &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n"); - } - } - - print OUTASM $EXTERN_DECLS if $TargetPlatform =~ /^mips-/m; - - # finished - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} -\end{code} - -On IA64, tail calls are converted to branches at this point. The mangler -searches for function calls immediately followed by a '--- TAILCALL ---' -token. Since the compiler can put various combinations of labels, bundling -directives, nop instructions, stops, and a move of the return value -between the branch and the tail call, proper matching of the tail call -gets a little hairy. This subroutine does the mangling. - -Here is an example of a tail call before mangling: - -\begin{verbatim} - br.call.sptk.many b0 = b6 -.L211 - ;; - .mmi - mov r1 = r32 - ;; - nop.m 0 - nop.i 0 - ;; - --- TAILCALL -- - ;; -.L123 -\end{verbatim} - -\begin{code} -sub ia64_mangle_tailcalls { - # Function input and output are in $c - - # Construct the tailcall-mangling expression the first time this function - # is called. - if (!defined($IA64_MATCH_TAILCALL)) { - # One-line pattern matching constructs. None of these - # should bind references; all parenthesized terms - # should be (?:) terms. - my $stop = q/(?:\t;;\n)/; - my $bundle = q/(?:\t\.(?:mii|mib|mmi|mmb|mfi|mfb|mbb|bbb)\n)/; - my $nop = q/(?:\tnop(?:\.[mifb])?\s+\d+\n)/; - my $movgp = q/(?:\tmov r1 = r\d+\n)/; - my $postbr = q/(?:\tbr \.L\d+\n)/; - - my $noeffect = "(?:$stop$bundle?|$nop)*"; - my $postbundle = "(?:$bundle?$nop?$nop?$postbr)?"; - - # Important parts of the pattern match. The branch target - # and subsequent jump label are bound to $1 and $2 - # respectively. Sometimes there is no label. - my $callbr = q/^\tbr\.call\.sptk\.many b0 = (.*)\n/; - my $label = q/(?:^\.L([0-9]*):\n)/; - my $tailcall = q/\t--- TAILCALL ---\n/; - - $IA64_MATCH_TAILCALL = - $callbr . $label . '?' . $noeffect . $movgp . '?' . $noeffect . - $tailcall . $stop . '?' . '(?:' . $postbundle . ')?'; - } - - # Find and mangle tailcalls - while ($c =~ s/$IA64_MATCH_TAILCALL/\tbr\.few $1\n/om) { - # Eek, the gcc optimiser is getting smarter... if we see a jump to the - # --- TAILCALL --- marker then we reapply the substitution at the source sites - $c =~ s/^\tbr \.L$2\n/\t--- TAILCALL ---\n/gm if ($2); - } - - # Verify that all instances of TAILCALL were processed - if ($c =~ /^\t--- TAILCALL ---\n/m) { - die "Unmangled TAILCALL tokens remain after mangling" - } -} -\end{code} - -The number of registers allocated on the IA64 register stack is set -upon entry to the runtime with an `alloc' instruction at the entry -point of \verb+StgRun()+. Gcc uses its own `alloc' to allocate -however many registers it likes in each function. When we discard -gcc's alloc, we have to reconcile its register assignment with what -the STG uses. - -There are three stack areas: fixed registers, input/local registers, -and output registers. We move the output registers to the output -register space and leave the other registers where they are. - -\begin{code} -sub ia64_rename_registers() { - # The text to be mangled is in $c - # Find number of registers in each stack area - my ($loc, $out) = @_; - my $cout; - my $first_out_reg; - my $regnum; - my $fragment; - - # These are the register numbers used in the STG runtime - my $STG_FIRST_OUT_REG = 32 + 34; - my $STG_LAST_OUT_REG = $STG_FIRST_OUT_REG + 7; - - $first_out_reg = 32 + $loc; - - if ($first_out_reg > $STG_FIRST_OUT_REG) { - die "Too many local registers allocated by gcc"; - } - - # Split the string into fragments containing one register name each. - # Rename the register in each fragment and concatenate. - $cout = ""; - foreach $fragment (split(/(?=r\d+[^a-zA-Z0-9_.])/sm, $c)) { - if ($fragment =~ /^r(\d+)((?:[^a-zA-Z0-9_.].*)?)$/sm) { - $regnum = $1; - - if ($regnum < $first_out_reg) { - # This is a local or fixed register - - # Local registers 32 and 33 (r64 and r65) are - # used to hold saved state; they shouldn't be touched - if ($regnum == 64 || $regnum == 65) { - die "Reserved register $regnum is in use"; - } - } - else { - # This is an output register - $regnum = $regnum - $first_out_reg + $STG_FIRST_OUT_REG; - if ($regnum > $STG_LAST_OUT_REG) { - die "Register number ($regnum) is out of expected range"; - } - } - - # Update this fragment - $fragment = "r" . $regnum . $2; - } - $cout .= $fragment; - } - - $c = $cout; -} - -\end{code} - -\begin{code} -sub hppa_mash_prologue { # OK, epilogue, too - local($_) = @_; - - # toss all prologue stuff - s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/m; - - # Lie about our .CALLINFO - s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/m; - - # Get rid of P' - - s/LP'/L'/gm; - s/RP'/R'/gm; - - # toss all epilogue stuff - s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/m; - - # Sorry; we moved the _info stuff to the code segment. - s/_info,DATA/_info,CODE/gm; - - return($_); -} -\end{code} - -\begin{code} -sub print_doctored { - local($_, $need_fallthru_patch) = @_; - - if ( $TargetPlatform =~ /^x86_64-/m ) { - # Catch things like - # - # movq -4(%ebp), %rax - # jmp *%rax - # - # and optimise: - # - s/^\tmovq\s+(-?\d*\(\%r(bx|bp|13)\)),\s*(\%r(ax|cx|dx|10|11))\n\tjmp\s+\*\3/\tjmp\t\*$1/gm; - s/^\tmovl\s+\$${T_US}(.*),\s*(\%e(ax|cx|si|di))\n\tjmp\s+\*\%r\3/\tjmp\t$T_US$1/gm; - } - - if ( $TargetPlatform !~ /^i386-/m - || ! /^\t[a-z]/m # no instructions in here, apparently - || /^${T_US}__stginit_[A-Za-z0-9_]+${T_POST_LBL}/m) { - print OUTASM $_; - return; - } - - # OK, must do some x86 **HACKING** - - local($entry_patch) = ''; - local($exit_patch) = ''; - - # gotta watch out for weird instructions that - # invisibly smash various regs: - # rep* %ecx used for counting - # scas* %edi used for destination index - # cmps* %e[sd]i used for indices - # loop* %ecx used for counting - # - # SIGH. - - # We cater for: - # * use of STG reg [ nn(%ebx) ] where no machine reg avail - # - # * GCC used an "STG reg" for its own purposes - # - # * some secret uses of machine reg, requiring STG reg - # to be saved/restored - - # The most dangerous "GCC uses" of an "STG reg" are when - # the reg holds the target of a jmp -- it's tricky to - # insert the patch-up code before we get to the target! - # So here we change the jmps: - - # -------------------------------------------------------- - # it can happen that we have jumps of the form... - # jmp * - # or - # jmp - # - # a reasonably-common case is: - # - # movl $_blah, - # jmp * - # - s/^\tmovl\s+\$${T_US}(.*),\s*(\%e[acd]x)\n\tjmp\s+\*\2/\tjmp $T_US$1/gm; - - # Catch things like - # - # movl -4(%ebx), %eax - # jmp *%eax - # - # and optimise: - # - s/^\tmovl\s+(-?\d*\(\%e(bx|si)\)),\s*(\%e[acd]x)\n\tjmp\s+\*\3/\tjmp\t\*$1/gm; - - if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi? - s/^\tmovl\s+(.*),\s*\%esi\n\tjmp\s+\*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*(.*\(.*\%esi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/gm; - die "$Pgm: (mangler) still have jump involving \%esi!\n$_" - if /(jmp|call)\s+.*\%esi/m; - } - if ($StolenX86Regs <= 3 ) { # spurious uses of edi? - s/^\tmovl\s+(.*),\s*\%edi\n\tjmp\s+\*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*(.*\(.*\%edi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm; - s/^\tjmp\s+\*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/gm; - die "$Pgm: (mangler) still have jump involving \%edi!\n$_" - if /(jmp|call)\s+.*\%edi/m; - } - - # OK, now we can decide what our patch-up code is going to - # be: - - # Offsets into register table - you'd better update these magic - # numbers should you change its contents! - # local($OFFSET_R1)=0; No offset for R1 in new RTS. - local($OFFSET_Hp)=88; - - # Note funky ".=" stuff; we're *adding* to these _patch guys - if ( $StolenX86Regs <= 2 - && ( /[^0-9]\(\%ebx\)/m || /\%esi/m || /^\tcmps/m ) ) { # R1 (esi) - $entry_patch .= "\tmovl \%esi,(\%ebx)\n"; - $exit_patch .= "\tmovl (\%ebx),\%esi\n"; - - # nothing for call_{entry,exit} because %esi is callee-save - } - if ( $StolenX86Regs <= 3 - && ( /${OFFSET_Hp}\(\%ebx\)/m || /\%edi/m || /^\t(scas|cmps)/m ) ) { # Hp (edi) - $entry_patch .= "\tmovl \%edi,${OFFSET_Hp}(\%ebx)\n"; - $exit_patch .= "\tmovl ${OFFSET_Hp}(\%ebx),\%edi\n"; - - # nothing for call_{entry,exit} because %edi is callee-save - } - - # -------------------------------------------------------- - # next, here we go with non-%esp patching! - # - s/^(\t[a-z])/$entry_patch$1/m; # before first instruction - -# Before calling GC we must set up the exit condition before the call -# and entry condition when we come back - - # fix _all_ non-local jumps: - - if ( $TargetPlatform =~ /^.*-apple-darwin.*/m ) { - # On Darwin, we've got local-looking jumps that are - # actually global (i.e. jumps to Lfoo$stub or via - # Lfoo$non_lazy_ptr), so we fix those first. - # In fact, we just fix everything that contains a dollar - # because false positives don't hurt here. - - s/^(\tjmp\s+\*?L.*\$.*\n)/$exit_patch$1/gm; - } - - s/^\tjmp\s+\*${T_X86_PRE_LLBL_PAT}/\tJMP___SL/gom; - s/^\tjmp\s+${T_X86_PRE_LLBL_PAT}/\tJMP___L/gom; - - s/^(\tjmp\s+.*\n)/$exit_patch$1/gm; # here's the fix... - - s/^\tJMP___SL/\tjmp \*${T_X86_PRE_LLBL}/gom; - s/^\tJMP___L/\tjmp ${T_X86_PRE_LLBL}/gom; - - if ($StolenX86Regs == 2 ) { - die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_" - if /^\t(jmp|call)\s+.*\%e(si|di)/m; - } elsif ($StolenX86Regs == 3 ) { - die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_" - if /^\t(jmp|call)\s+.*\%edi/m; - } - - # -------------------------------------------------------- - # that's it -- print it - # - #die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia - - print OUTASM $_; - - if ( $need_fallthru_patch ) { # exit patch for end of slow entry code - print OUTASM $exit_patch; - # ToDo: make it not print if there is a "jmp" at the end - } -} -\end{code} - -\begin{code} -sub init_FUNNY_THINGS { - # use vars '%KNOWN_FUNNY_THING'; # Unused? - %KNOWN_FUNNY_THING = ( - # example - # "${T_US}stg_.*{T_POST_LBL}", 1, - ); -} -\end{code} - -The following table reversal is used for both info tables and return -vectors. In both cases, we remove the first entry from the table, -reverse the table, put the label at the end, and paste some code -(that which is normally referred to by the first entry in the table) -right after the table itself. (The code pasting is done elsewhere.) - -\begin{code} -sub rev_tbl { - # use vars '$discard1'; # Unused? - local($symb, $tbl, $discard1) = @_; - - return ($tbl) if ($TargetPlatform =~ /^ia64-/m - || $TABLES_NEXT_TO_CODE eq "NO"); - - local($before) = ''; - local($label) = ''; - local(@imports) = (); # hppa only - local(@words) = (); - local($after) = ''; - local(@lines) = split(/\n/m, $tbl); - local($i, $j); - - # Deal with the header... - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?${T_DOT_WORD}\s+/om; $i++) { - $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/om - || $lines[$i] =~ /${T_DOT_GLOBAL}/om - || $lines[$i] =~ /^${T_US}\S+_vtbl${T_POST_LBL}$/om; - - $before .= $lines[$i] . "\n"; # otherwise... - } - - $infoname = $label; - $infoname =~ s/(.|\n)*^([A-Za-z0-9_]+_info)${T_POST_LBL}$(.|\n)*/$2/m; - - # Grab the table data... - if ( $TargetPlatform !~ /^hppa/m ) { - for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/om; $i++) { - $line = $lines[$i]; - # Convert addresses of SRTs, slow entrypoints and large bitmaps - # to offsets (relative to the info label), - # in order to support position independent code. - $line =~ s/$infoname/0/m - || $line =~ s/([A-Za-z0-9_]+_srtd)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_srt(\+\d+)?)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_str)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_slow)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_btm)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_alt)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_dflt)$/$1 - $infoname/m - || $line =~ s/([A-Za-z0-9_]+_ret)$/$1 - $infoname/m; - push(@words, $line); - } - } else { # hppa weirdness - for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/m; $i++) { - # FIXME: the RTS now expects offsets instead of addresses - # for all labels in info tables. - if ($lines[$i] =~ /^\s+\.IMPORT/m) { - push(@imports, $lines[$i]); - } else { - # We don't use HP's ``function pointers'' - # We just use labels in code space, like normal people - $lines[$i] =~ s/P%//m; - push(@words, $lines[$i]); - } - } - } - - # Now throw away any initial zero word from the table. This is a hack - # that lets us reduce the size of info tables when the SRT field is not - # needed: see comments StgFunInfoTable in InfoTables.h. - # - # The .zero business is for Linux/ELF. - # The .skip business is for Sparc/Solaris/ELF. - # The .blockz business is for HPPA. -# if ($discard1) { -# if ($words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) { -# shift(@words); -# } -# } - - for (; $i <= $#lines; $i++) { - $after .= $lines[$i] . "\n"; - } - - # Alphas: If we have anonymous text (not part of a procedure), the - # linker may complain about missing exception information. Bleh. - # To suppress this, we place a .ent/.end pair around the code. - # At the same time, we have to be careful and not enclose any leading - # .file/.loc directives. - if ( $TargetPlatform =~ /^alpha-/m && $label =~ /^([A-Za-z0-9_]+):$/m) { - local ($ident) = $1; - $before =~ s/^((\s*\.(file|loc)\s+[^\n]*\n)*)/$1\t.ent $ident\n/m; - $after .= "\t.end $ident\n"; - } - - # Alphas: The heroic Simon Marlow found a bug in the Digital UNIX - # assembler (!) wherein .quad constants inside .text sections are - # first narrowed to 32 bits then sign-extended back to 64 bits. - # This obviously screws up our 64-bit bitmaps, so we work around - # the bug by replacing .quad with .align 3 + .long + .long [ccshan] - if ( $TargetPlatform =~ /^alpha-/m ) { - foreach (@words) { - if (/^\s*\.quad\s+([-+0-9].*\S)\s*$/m && length $1 >= 10) { - local ($number) = $1; - if ($number =~ /^([-+])?(0x?)?([0-9]+)$/m) { - local ($sign, $base, $digits) = ($1, $2, $3); - $base = (10, 8, 16)[length $base]; - local ($hi, $lo) = (0, 0); - foreach $i (split(//, $digits)) { - $j = $lo * $base + $i; - $lo = $j % 4294967296; - $hi = $hi * $base + ($j - $lo) / 4294967296; - } - ($hi, $lo) = (4294967295 - $hi, 4294967296 - $lo) - if $sign eq "-"; - $_ = "\t.align 3\n\t.long $lo\n\t.long $hi\n"; - # printf STDERR "TURNING %s into 0x %08x %08x\n", $number, $hi, $lo; - } else { - print STDERR "Cannot handle \".quad $number\" in info table\n"; - exit 1; - } - } - } - } - - if ( $TargetPlatform =~ /x86_64-apple-darwin/m ) { - # Tack a label to the front of the info table, too. - # For now, this just serves to work around a crash in Apple's new - # 64-bit linker (it seems to assume that there is no data before the - # first label in a section). - - # The plan for the future is to do this on all Darwin platforms, and - # to add a reference to this label after the entry code, just as the - # NCG does, so we can enable dead-code-stripping in the linker without - # losing our info tables. (Hence the name _dsp, for dead-strip preventer) - - $before .= "\n${infoname}_dsp:\n"; - } - - $tbl = $before - . (($TargetPlatform !~ /^hppa/m) ? '' : join("\n", @imports) . "\n") - . join("\n", @words) . "\n" - . $label . $after; - -# print STDERR "before=$before\n"; -# print STDERR "label=$label\n"; -# print STDERR "words=",(reverse @words),"\n"; -# print STDERR "after=$after\n"; - - $tbl; -} -\end{code} - -The HP is a major nuisance. The threaded code mangler moved info -tables from data space to code space, but unthreaded code in the RTS -still has references to info tables in data space. Since the HP -linker is very precise about where symbols live, we need to patch the -references in the unthreaded RTS as well. - -\begin{code} -sub mini_mangle_asm_hppa { - local($in_asmf, $out_asmf) = @_; - - open(INASM, "< $in_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); - open(OUTASM,"> $out_asmf") - || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n"); - - while () { - s/_info,DATA/_info,CODE/m; # Move _info references to code space - s/P%_PR/_PR/m; - print OUTASM; - } - - # finished: - close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n"); - close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n"); -} - -\end{code} - -\begin{code} -sub tidy_up_and_die { - local($return_val, $msg) = @_; - print STDERR $msg; - exit (($return_val == 0) ? 0 : 1); -} -\end{code} diff --git a/driver/mangler/ghc.mk b/driver/mangler/ghc.mk deleted file mode 100644 index c5e3bdf..0000000 --- a/driver/mangler/ghc.mk +++ /dev/null @@ -1,19 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture -# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -driver/mangler_PERL_SRC = ghc-asm.lprl -driver/mangler_dist_PROG = $(GHC_MANGLER_PGM) -driver/mangler_dist_TOPDIR = YES -driver/mangler_dist_INSTALL_IN = $(DESTDIR)$(topdir) - -$(eval $(call build-perl,driver/mangler,dist)) - diff --git a/ghc.mk b/ghc.mk index a41537f..863ddc2 100644 --- a/ghc.mk +++ b/ghc.mk @@ -544,7 +544,6 @@ BUILD_DIRS += \ ifneq "$(GhcUnregisterised)" "YES" BUILD_DIRS += \ - $(GHC_MANGLER_DIR) \ $(GHC_SPLIT_DIR) endif diff --git a/ghc/ghc.mk b/ghc/ghc.mk index cd2a027..8776566 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -113,9 +113,9 @@ $(INPLACE_LIB)/extra-gcc-opts : extra-gcc-opts # The GHC programs need to depend on all the helper programs they might call ifeq "$(GhcUnregisterised)" "NO" -$(GHC_STAGE1) : $(MANGLER) $(SPLIT) -$(GHC_STAGE2) : $(MANGLER) $(SPLIT) -$(GHC_STAGE3) : $(MANGLER) $(SPLIT) +$(GHC_STAGE1) : $(SPLIT) +$(GHC_STAGE2) : $(SPLIT) +$(GHC_STAGE3) : $(SPLIT) endif $(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts diff --git a/mk/config.mk.in b/mk/config.mk.in index b478997..4de412e 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -425,7 +425,6 @@ GHC_HP2PS_PGM = hp2ps$(exeext) GHC_GHCTAGS_PGM = ghctags$(exeext) GHC_HSC2HS_PGM = hsc2hs$(exeext) GHC_TOUCHY_PGM = touchy$(exeext) -GHC_MANGLER_PGM = ghc-asm GHC_SPLIT_PGM = ghc-split GHC_SYSMAN_PGM = SysMan GHC_GENPRIMOP_PGM = genprimopcode$(exeext) @@ -445,7 +444,6 @@ GHC_PERL = $(PERL) endif HP2PS = $(GHC_HP2PS_DIR)/$(GHC_HP2PS_PGM) -MANGLER = $(INPLACE_LIB)/$(GHC_MANGLER_PGM) SPLIT = $(INPLACE_LIB)/$(GHC_SPLIT_PGM) SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM) LTX = $(GHC_LTX_DIR)/$(GHC_LTX_PGM) diff --git a/mk/tree.mk b/mk/tree.mk index 3aa8527..2010c36 100644 --- a/mk/tree.mk +++ b/mk/tree.mk @@ -36,7 +36,6 @@ GHC_PKG_DIR = $(GHC_UTILS_DIR)/ghc-pkg GHC_GENPRIMOP_DIR = $(GHC_UTILS_DIR)/genprimopcode GHC_GENAPPLY_DIR = $(GHC_UTILS_DIR)/genapply GHC_CABAL_DIR = $(GHC_UTILS_DIR)/ghc-cabal -GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split GHC_SYSMAN_DIR = $(GHC_RTS_DIR)/parallel diff --git a/packages.git b/packages.git deleted file mode 100644 index 0af091c..0000000 --- a/packages.git +++ /dev/null @@ -1,85 +0,0 @@ -# Despite the name "package", this file contains the master list of -# the *repositories* that make up GHC. It is parsed by boot and darcs-all. -# -# Some of this information is duplicated elsewhere in the build system: -# See Trac #3896 -# In particular when adding libraries to this file, you also need to add -# the library to the SUBDIRS variable in libraries/Makefile so that they -# actually get built -# -# The repos are of several kinds: -# - The main GHC source repo -# - Each boot package lives in a repo -# - DPH is a repo that contains several packages -# - Haddock and hsc2hs are applications, built on top of GHC, -# and in turn needed to bootstrap GHC -# - ghc-tarballs is need to build GHC -# - nofib and testsuite are optional helpers -# -# The format of the lines in this file is: -# localpath tag remotepath VCS upstream -# where -# * 'localpath' is where to put the repository in a checked out tree. -# * 'remotepath' is where the repository is in the central repository. -# * 'VCS' is what version control system the repo uses. -# -# * The 'tag' determines when "darcs-all get" will get the -# repo. If the tag is "-" then it will always get it, but if there -# is a tag then a corresponding flag must be given to darcs-all, e.g. -# if you want to get the packages with an "extralibs" or "testsuite" -# tag then you need to use "darcs-all --extra --testsuite get". -# Support for new tags must be manually added to the darcs-all script. -# -# 'tag' is also used to determine which packages the build system -# deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra' -# both give this property -# -# * 'upstream' is the URL of the upstream repo, where there is one, or -# "-" if there is no upstream. -# -# Lines that start with a '#' are comments. -. - ghc.git git - -ghc-tarballs - ghc-tarballs darcs - -utils/hsc2hs - hsc2hs darcs - -# haddock does have an upstream: -# http://code.haskell.org/haddock/ -# but it stays buildable with the last stable release rather than tracking HEAD, -# and is resynced with the GHC HEAD branch by David Waern when appropriate -utils/haddock - haddock2 darcs - -libraries/array - packages/array darcs - -libraries/base - packages/base darcs - -libraries/binary - packages/binary darcs http://code.haskell.org/binary/ -libraries/bytestring - packages/bytestring darcs http://darcs.haskell.org/bytestring/ -libraries/Cabal - packages/Cabal darcs http://darcs.haskell.org/cabal/ -libraries/containers - packages/containers darcs - -libraries/directory - packages/directory darcs - -libraries/extensible-exceptions - packages/extensible-exceptions darcs - -libraries/filepath - packages/filepath darcs - -libraries/ghc-prim - packages/ghc-prim darcs - -libraries/haskeline - packages/haskeline darcs http://code.haskell.org/haskeline/ -libraries/haskell98 - packages/haskell98 darcs - -libraries/haskell2010 - packages/haskell2010 darcs - -libraries/hoopl - packages/hoopl darcs - -libraries/hpc - packages/hpc darcs - -libraries/integer-gmp - packages/integer-gmp darcs - -libraries/integer-simple - packages/integer-simple darcs - -libraries/mtl - packages/mtl darcs - -libraries/old-locale - packages/old-locale darcs - -libraries/old-time - packages/old-time darcs - -libraries/pretty - packages/pretty darcs - -libraries/process - packages/process darcs - -libraries/random - packages/random darcs - -libraries/template-haskell - packages/template-haskell darcs - -libraries/terminfo - packages/terminfo darcs http://code.haskell.org/terminfo/ -libraries/unix - packages/unix darcs - -libraries/utf8-string - packages/utf8-string darcs http://code.haskell.org/utf8-string/ -libraries/Win32 - packages/Win32 darcs - -libraries/xhtml - packages/xhtml darcs - -testsuite testsuite testsuite darcs - -nofib nofib nofib darcs - -libraries/deepseq extra packages/deepseq darcs - -libraries/parallel extra packages/parallel darcs - -libraries/stm extra packages/stm darcs - -libraries/primitive dph packages/primitive darcs http://code.haskell.org/primitive -libraries/vector dph packages/vector darcs http://code.haskell.org/vector -libraries/dph dph packages/dph darcs - diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index 8b67ce2..d6c1560 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -40,12 +40,7 @@ endif # All the .a/.so library file dependencies for this library $1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$2_$3_LIB)) -ifneq "$$(BootingFromHc)" "YES" -$1_$2_$3_MKSTUBOBJS = $$(FIND) $1/$2/build -name "*_stub.$$($3_osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to -# make using cached directory contents, or something. -else -$1_$2_$3_MKSTUBOBJS = true +ifeq "$$(BootingFromHc)" "YES" $1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/') endif @@ -70,7 +65,6 @@ ifeq "$3" "dyn" ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32" $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -78,7 +72,6 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) else $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ -shared -dynamic -dynload deploy \ -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \ -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ @@ -90,9 +83,9 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) "$$(RM)" $$(RM_OPTS) $$@ $$@.contents ifeq "$$($1_$2_SplitObjs)" "YES" $$(FIND) $$(patsubst %.$$($3_osuf),%_$$($3_osuf)_split,$$($1_$2_$3_HS_OBJS)) -name '*.$$($3_osuf)' -print >> $$@.contents - echo $$($1_$2_$3_NON_HS_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_NON_HS_OBJS) >> $$@.contents else - echo $$($1_$2_$3_ALL_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_ALL_OBJS) >> $$@.contents endif ifeq "$$(ArSupportsAtFile)" "YES" "$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ @$$@.contents @@ -121,7 +114,7 @@ BINDIST_LIBS += $$($1_$2_GHCI_LIB) endif endif $$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) - "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS) + "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't bother making ghci libs for bootstrapping packages diff --git a/sync-all b/sync-all index d89e439..d20f4e7 100755 --- a/sync-all +++ b/sync-all @@ -3,6 +3,64 @@ use strict; use Cwd; +# Usage: +# +# ./sync-all [-q] [-s] [--ignore-failure] [-r repo] +# [--nofib] [--testsuite] [--checked-out] cmd [git flags] +# +# Applies the command "cmd" to each repository in the tree. +# sync-all will try to do the right thing for both git and darcs repositories. +# +# e.g. +# ./sync-all -r http://darcs.haskell.org/ghc get +# To get any repos which do not exist in the local tree +# +# ./sync-all pull +# To pull everything from the default repos +# +# -------------- Flags ------------------- +# -q says to be quite, and -s to be silent. +# +# --ignore-failure says to ignore errors and move on to the next repository +# +# -r repo says to use repo as the location of package repositories +# +# --checked-out says that the remote repo is in checked-out layout, as +# opposed to the layout used for the main repo. By default a repo on +# the local filesystem is assumed to be checked-out, and repos accessed +# via HTTP or SSH are assumed to be in the main repo layout; use +# --checked-out to override the latter. +# +# --nofib, --testsuite also get the nofib and testsuite repos respectively +# +# ------------ Which repos to use ------------- +# sync-all uses the following algorithm to decide which remote repos to use +# +# It always computes the remote repos from a single base, $repo_base +# How is $repo_base set? +# If you say "-r repo", then that's $repo_base +# otherwise $repo_base is set by asking git where the ghc repo came +# from, and removing the last component (e.g. /ghc.git/ of /ghc/). +# +# Then sync-all iterates over the package found in the file +# ./packages; see that file for a description of the contents. +# +# If $repo_base looks like a local filesystem path, or if you give +# the --checked-out flag, sync-all works on repos of form +# $repo_base/ +# otherwise sync-all works on repos of form +# $repo_base/ +# This logic lets you say +# both sync-all -r http://darcs.haskell.org/ghc-6.12 pull +# and sync-all -r ../HEAD pull +# The latter is called a "checked-out tree". + +# NB: sync-all *ignores* the defaultrepo of all repos other than the +# root one. So the remote repos must be laid out in one of the two +# formats given by and in the file 'packages'. + +$| = 1; # autoflush stdout after each print, to avoid output after die + my $defaultrepo; my @packages; my $verbose = 2; @@ -157,6 +215,8 @@ sub scmall { my $scm; my $upstream; my $line; + my $branch_name; + my $subcommand; my $path; my $wd_before = getcwd; @@ -164,11 +224,45 @@ sub scmall { my @scm_args; my $pwd; + my @args; my ($repo_base, $checked_out_tree) = getrepo(); + my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/; + parsePackages; + @args = (); + + if ($command =~ /^remote$/) { + while (@_ > 0 && $_[0] =~ /^-/) { + push(@args,shift); + } + if (@_ < 1) { help(); } + $subcommand = shift; + if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') { + help(); + } + while (@_ > 0 && $_[0] =~ /^-/) { + push(@args,shift); + } + if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) { + help(); + } elsif (@_ < 1) { # set-url + $branch_name = 'origin'; + } else { + $branch_name = shift; + } + } elsif ($command eq 'new' || $command eq 'fetch') { + if (@_ < 1) { + $branch_name = 'origin'; + } else { + $branch_name = shift; + } + } + + push(@args, @_); + for $line (@packages) { $localpath = $$line{"localpath"}; @@ -177,6 +271,12 @@ sub scmall { $scm = $$line{"vcs"}; $upstream = $$line{"upstream"}; + # We can't create directories on GitHub, so we translate + # "package/foo" into "package-foo". + if ($is_github_repo) { + $remotepath =~ s/\//-/; + } + # Check the SCM is OK as early as possible die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git")); @@ -189,7 +289,7 @@ sub scmall { } # Work out the arguments we should give to the SCM - if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) { + if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) { @scm_args = (($scm eq "darcs" and "whatsnew") or ($scm eq "git" and "status")); @@ -217,7 +317,7 @@ sub scmall { } # The first time round the loop, default the get-mode - if (not defined($get_mode)) { + if ($scm eq "darcs" && not defined($get_mode)) { warning("adding --partial, to override use --complete"); $get_mode = "--partial"; } @@ -238,14 +338,25 @@ sub scmall { or ($scm eq "git" and "send-email")); $want_remote_repo = 1; } - elsif ($command =~ /^set-origin$/) { - @scm_args = ("remote", "set-url", "origin", $path); - } elsif ($command =~ /^fetch$/) { - @scm_args = ("fetch", "origin"); + @scm_args = ("fetch", "$branch_name"); } elsif ($command =~ /^new$/) { - @scm_args = ("log", "origin.."); + @scm_args = ("log", "$branch_name.."); + } + elsif ($command =~ /^remote$/) { + if ($subcommand eq 'add') { + @scm_args = ("remote", "add", $branch_name, $path); + } elsif ($subcommand eq 'rm') { + @scm_args = ("remote", "rm", $branch_name); + } elsif ($subcommand eq 'set-url') { + @scm_args = ("remote", "set-url", $branch_name, $path); + } + } + elsif ($command =~ /^grep$/) { + @scm_args = ("grep"); + # Hack around 'git grep' failing if there are no matches + $ignore_failure = 1; } else { die "Unknown command: $command"; @@ -255,20 +366,20 @@ sub scmall { if (repoexists ($scm, $localpath)) { if ($want_remote_repo) { if ($scm eq "darcs") { - scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path); + scm (".", $scm, @scm_args, @args, "--repodir=$localpath", $path); } else { # git pull doesn't like to be used with --work-dir # I couldn't find an alternative to chdir() here - scm ($localpath, $scm, @scm_args, @_, $path, "master"); + scm ($localpath, $scm, @scm_args, @args, $path, "master"); } } else { # git status *must* be used with --work-dir, if we don't chdir() to the dir - scm ($localpath, $scm, @scm_args, @_); + scm ($localpath, $scm, @scm_args, @args); } } elsif ($local_repo_unnecessary) { # Don't bother to change directory in this case - scm (".", $scm, @scm_args, @_); + scm (".", $scm, @scm_args, @args); } elsif ($tag eq "") { message "== Required repo $localpath is missing! Skipping"; @@ -279,6 +390,54 @@ sub scmall { } } + +sub help() +{ + # Get the built in help + my $help = < + * --complete + * --partial + * fetch + * send + * new + * remote add + * remote rm + * remote set-url [--push] + * grep + +Available package-tags are: +END + + # Collect all the tags in the packages file + my %available_tags; + open IN, "< packages" or die "Can't open packages file"; + while () { + chomp; + if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) { + if (defined($2) && $2 ne "-") { + $available_tags{$2} = 1; + } + } + elsif (! /^(#.*)?$/) { + die "Bad line: $_"; + } + } + close IN; + + # Show those tags and the help text + my @available_tags = keys %available_tags; + print "$help@available_tags\n"; + exit 1; +} + sub main { if (! -d ".git" || ! -d "compiler") { die "error: sync-all must be run from the top level of the ghc tree." @@ -327,46 +486,7 @@ sub main { } if ($#_ eq -1) { - # Get the built in help - my $help = < - * --complete - * --partial - * fetch - * send - * set-origin - * new - -Available package-tags are: -END - - # Collect all the tags in the packages file - my %available_tags; - open IN, "< packages" or die "Can't open packages file"; - while () { - chomp; - if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) { - if (defined($2) && $2 ne "-") { - $available_tags{$2} = 1; - } - } - elsif (! /^(#.*)?$/) { - die "Bad line: $_"; - } - } - close IN; - - # Show those tags and the help text - my @available_tags = keys %available_tags; - print "$help@available_tags\n"; - exit 1; + help(); } else { # Give the command and rest of the arguments to the main loop