From: simonmar Date: Thu, 29 Jun 2000 13:08:59 +0000 (+0000) Subject: [project @ 2000-06-29 13:08:59 by simonmar] X-Git-Tag: Approximately_9120_patches~4118 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=01379cdcb8eee51d5ad20732589c6d26eb6bdb3b;p=ghc-hetmet.git [project @ 2000-06-29 13:08:59 by simonmar] hi files are now named after the module being compiled, not the original filename (unless of course the user has specified -ohi ). --- diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 25d080e..984ff7b 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -136,7 +136,9 @@ module CmdLineOpts ( opt_OmitInterfacePragmas, opt_ProduceExportCStubs, opt_ProduceExportHStubs, - opt_ProduceHi, + opt_HiFile, + opt_HiDir, + opt_HiSuf, opt_NoPruneTyDecls, opt_NoPruneDecls, opt_ReportCompile, @@ -418,7 +420,11 @@ opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") opt_ProduceExportCStubs = lookup_str "-F=" opt_ProduceExportHStubs = lookup_str "-FH=" -opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time + +-- where to generate the .hi file +opt_HiFile = lookup_str "-hifile=" +opt_HiDir = lookup_str "-hidir=" +opt_HiSuf = lookup_str "-hisuf=" -- Language for output: "C", "asm", "java", maybe more -- Nothing => don't output anything diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 7370529..fbca8ce 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -20,7 +20,6 @@ import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), Version, bumpVersion, initialVersion, isLoopBreaker ) import RnMonad -import RnEnv ( availName ) import TcInstUtil ( InstInfo(..) ) @@ -42,8 +41,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..), import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) -import Module ( moduleString, pprModule, pprModuleName ) -import RdrName ( RdrName ) +import Module ( moduleString, pprModule, pprModuleName, moduleUserString ) import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule, Name, NamedThing(..) ) @@ -59,18 +57,17 @@ import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, ) import PprType -import FunDeps ( pprFundeps ) import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) import Bag ( bagToList, isEmptyBag ) import Maybes ( catMaybes, maybeToBool ) -import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap ) import UniqFM ( lookupUFM, listToUFM ) -import UniqSet ( uniqSetToList ) import Util ( sortLt, mapAccumL ) import SrcLoc ( noSrcLoc ) import Bag import Outputable + +import Maybe ( isNothing ) \end{code} @@ -84,10 +81,22 @@ import Outputable writeIface this_mod old_iface new_iface local_tycons local_classes inst_info final_ids tidy_binds tidy_orphan_rules - = case opt_ProduceHi of { - Nothing -> return () ; -- not producing any .hi file - - Just filename -> + = + if isNothing opt_HiDir && isNothing opt_HiFile + then return () -- not producing any .hi file + else + + let + hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf } + filename = case opt_HiFile of { + Just f -> f; + Nothing -> + case opt_HiDir of { + Just dir -> dir ++ '/':moduleUserString this_mod + ++ '.':hi_suf; + Nothing -> panic "writeIface" + }} + in case checkIface old_iface full_new_iface of { Nothing -> do { putStrLn "Interface file unchanged" ; @@ -105,7 +114,7 @@ writeIface this_mod old_iface new_iface if_hdl <- openFile filename WriteMode printForIface if_hdl (pprIface final_iface) hClose if_hdl - }} + } where full_new_iface = completeIface new_iface local_tycons local_classes inst_info final_ids tidy_binds diff --git a/ghc/driver/Main.hs b/ghc/driver/Main.hs index 1403830..13ca445 100644 --- a/ghc/driver/Main.hs +++ b/ghc/driver/Main.hs @@ -1273,8 +1273,7 @@ run_phase Hsc basename input_fn output_fn -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the import path, since this is -- what gcc does, and it's probably what you want. - let (root,dir) = break (=='/') (reverse basename) - current_dir = if null dir then "." else reverse dir + let current_dir = getdir basename paths <- readIORef include_paths writeIORef include_paths (current_dir : paths) @@ -1305,27 +1304,26 @@ run_phase Hsc basename input_fn output_fn add files_to_clean tmp_stub_h add files_to_clean tmp_stub_c + -- figure out where to put the .hi file + ohi <- readIORef output_hi + hisuf <- readIORef hi_suf + let hi_flags = case ohi of + Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ] + Just fn -> [ "-hifile="++fn ] + + -- run the compiler! run_something "Haskell Compiler" (unwords (hsc : input_fn : ( hsc_opts - ++ [ hi_flag, " -ofile="++output_fn ] - ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ] + ++ hi_flags + ++ [ + "-ofile="++output_fn, + "-F="++tmp_stub_c, + "-FH="++tmp_stub_h + ] ++ stat_opts ))) - -- Copy the .hi file into the current dir if it changed - on doing_hi - (do ohi <- readIORef output_hi - hisuf <- readIORef hi_suf - let hi_target = case ohi of - Nothing -> basename ++ '.':hisuf - Just fn -> fn - new_hi_file <- fileExist tmp_hi_file - on new_hi_file - (run_something "Copy hi file" - (unwords ["mv", tmp_hi_file, hi_target])) - ) - -- Generate -Rghc-timing info on (timing) ( run_something "Generate timing stats" @@ -1973,6 +1971,11 @@ take_longest_prefix s c = reverse pre newsuf :: String -> String -> String newsuf suf s = remove_suffix s '.' ++ suf +-- getdir strips the filename off the input string, returning the directory. +getdir :: String -> String +getdir s = if null dir then "." else init dir + where dir = take_longest_prefix s '/' + newdir :: String -> String -> String newdir dir s = dir ++ '/':drop_longest_prefix s '/'