From: sewardj Date: Tue, 24 Oct 2000 13:23:33 +0000 (+0000) Subject: [project @ 2000-10-24 13:23:33 by sewardj] X-Git-Tag: Approximately_9120_patches~3520 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6eed516972e32ac6718c0aca708649df3f5c22fa;p=ghc-hetmet.git [project @ 2000-10-24 13:23:33 by sewardj] Compile everything needed by main/HscMain. --- diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 7459929..2509004 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -28,6 +28,7 @@ module CmdLineOpts ( dopt_CoreToDo, dopt_StgToDo, dopt_HscLang, + dopt_OutName, -- profiling opts opt_AutoSccsOnAllToplevs, @@ -276,10 +277,11 @@ data DynFlag deriving (Eq) data DynFlags = DynFlags { - coreToDo :: CoreToDo, - stgToDo :: StgToDo, - hscLang :: HscLang, - flags :: [DynFlag] + coreToDo :: CoreToDo, + stgToDo :: StgToDo, + hscLang :: HscLang, + hscOutName :: String, -- name of the file in which to place output + flags :: [DynFlag] } dopt :: DynFlag -> DynFlags -> Bool @@ -291,10 +293,13 @@ dopt_CoreToDo = coreToDo dopt_StgToDo :: DynFlags -> StgToDo dopt_StgToDo = stgToDo +dopt_OutName :: DynFlags -> String +dopt_OutName = hscOutName + data HscLang - = HscC String -- String is the filename to put output into - | HscAsm String -- ditto - | HscJava String -- ditto + = HscC + | HscAsm + | HscJava | HscInterpreter dopt_HscLang :: DynFlags -> HscLang diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 727f771..a8b7d01 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -31,8 +31,8 @@ import Module ( Module ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn ) import Outputable -import CmdLineOpts ( DynFlags(..), HscLang(..) ) -import TmpFiles ( newTmpName ) +import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) +import TmpFiles ( newTempName ) import IO ( IOMode(..), hClose, openFile, Handle ) \end{code} @@ -63,17 +63,18 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds -- Dunno if the above comment is still meaningful now. JRS 001024. - do stub_names <- outputForeignStubs c_code h_code + do let filenm = dopt_OutName dflags + stub_names <- outputForeignStubs dflags c_code h_code case dopt_HscLang dflags of HscInterpreter -> return stub_names - HscAsm filenm -> outputAsm dflags filenm flat_abstractC ncg_uniqs + HscAsm -> outputAsm dflags filenm flat_abstractC ncg_uniqs >> return stub_names - HscC filenm -> outputC dflags filenm flat_abstractC + HscC -> outputC dflags filenm flat_abstractC >> return stub_names - HscJava filenm -> outputJava dflags filenm mod_name tycons core_binds + HscJava -> outputJava dflags filenm mod_name tycons core_binds >> return stub_names -doOutput :: (Handle -> IO ()) -> IO () +doOutput :: String -> (Handle -> IO ()) -> IO () doOutput filenm io_action = (do handle <- openFile filenm WriteMode io_action handle @@ -91,7 +92,7 @@ doOutput filenm io_action \begin{code} outputC dflags filenm flat_absC - = do dumpIfSet_dyn Opt_D_dump_realC dflags "Real C" (dumpRealC flat_absC) + = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC) doOutput filenm (\ h -> writeRealC h flat_absC) \end{code} @@ -107,8 +108,8 @@ outputAsm dflags filenm flat_absC ncg_uniqs #ifndef OMIT_NATIVE_CODEGEN - = do dumpIfSet_dyn Opt_D_dump_stix dflags "Final stix code" stix_final - dumpIfSet_dyn Opt_D_dump_asm dflags "Asm code" ncg_output_d + = do dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final + dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d doOutput filenm ( \f -> printForAsm f ncg_output_d) where (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs @@ -147,13 +148,13 @@ outputJava dflags filenm mod tycons core_binds \begin{code} outputForeignStubs dflags c_code h_code = do - dumpIfSet_dyn Opt_D_dump_foreign dflags + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d maybe_stub_h_file <- outputForeignStubs_help True{-.h output-} stub_h_output_w - dumpIfSet_dyn Opt_D_dump_foreign dflags + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d maybe_stub_c_file @@ -173,13 +174,11 @@ outputForeignStubs dflags c_code h_code -- Don't use doOutput for dumping the f. export stubs -- since it is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. -outputForeignStubs_help is_header switch "" = return Nothing -outputForeignStubs_help is_header switch doc_str = - case switch of - Nothing -> return Nothing - Just fname -> newTempName suffix >>= \ fname -> - writeFile fname (include_prefix ++ doc_str) >> - return (Just suffix) +outputForeignStubs_help is_header "" = return Nothing +outputForeignStubs_help is_header doc_str + = newTempName suffix >>= \ fname -> + writeFile fname (include_prefix ++ doc_str) >> + return (Just suffix) where suffix | is_header = "h_stub" diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs index 310c747..39e05b9 100644 --- a/ghc/compiler/main/TmpFiles.hs +++ b/ghc/compiler/main/TmpFiles.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: TmpFiles.hs,v 1.3 2000/10/23 09:03:27 simonpj Exp $ +-- $Id: TmpFiles.hs,v 1.4 2000/10/24 13:23:33 sewardj Exp $ -- -- Temporary file management -- @@ -21,7 +21,9 @@ import Config import Util -- hslibs --- import Posix commented out SLPJ +#ifndef mingw32_TARGET_OS +import Posix ( getProcessID ) +#endif import Exception import IOExts @@ -57,6 +59,13 @@ cleanTempFiles verbose = do type Suffix = String -- find a temporary name that doesn't already exist. +#ifdef mingw32_TARGET_OS +getProcessID :: IO Int +getProcessID + = do putStr "warning: faking getProcessID in main/TmpFiles.lhs" + return 12345 +#endif + newTempName :: Suffix -> IO FilePath newTempName extn = do x <- getProcessID diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d82fe3f..7cf5dd2 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.43 2000/10/24 08:40:10 simonpj Exp $ +$Id: Parser.y,v 1.44 2000/10/24 13:23:33 sewardj Exp $ Haskell grammar. @@ -278,7 +278,7 @@ importdecls :: { [RdrNameImportDecl] } importdecl :: { RdrNameImportDecl } : 'import' srcloc maybe_src optqualified CONID maybeas maybeimpspec - { ImportDecl (mkSrcModuleFS $5) $3 $4 $6 $7 $2 } + { ImportDecl (mkModuleNameFS $5) $3 $4 $6 $7 $2 } maybe_src :: { WhereFrom } : '{-# SOURCE' '#-}' { ImportByUserSource } @@ -875,7 +875,7 @@ dbind : ipvar '=' exp { ($1, $3) } depreclist :: { [RdrName] } depreclist : deprec_var { [$1] } - | deprec_var ',' depreclist { $1 : $2 } + | deprec_var ',' depreclist { $1 : $3 } deprec_var :: { RdrName } deprec_var : var { $1 } @@ -1061,7 +1061,7 @@ layout_on_for_do :: { () } : {% layoutOn False } -- Miscellaneous (mostly renamings) modid :: { ModuleName } - : CONID { mkSrcModuleFS $1 } + : CONID { mkModuleNameFS $1 } tycon :: { RdrName } : CONID { mkUnqual tcClsName $1 }