X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=0148ca4343ab3547d040a959aea4aed146b5cc0b;hb=7f24ae51ed36c5c0308a2d0de23e243f32a0043c;hp=1a08ded807b741dc931a7b41822f5737649e4b1e;hpb=0d7bfe8ec27efee649ec0c0b6915342ad0c9c111;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 1a08ded..0148ca4 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -19,27 +19,32 @@ import IlxGen		( ilxGen )
 
 #ifdef JAVA
 import JavaGen		( javaGen )
-import OccurAnal	( occurAnalyseBinds )
 import qualified PrintJava
 import OccurAnal	( occurAnalyseBinds )
 #endif
 
+import Finder		( mkStubPaths )
+import PprC		( writeCs )
+import CmmLint		( cmmLint )
 import Packages
-import DriverState	( getExplicitPackagesAnd, getPackageCIncludes )
+import Util
 import FastString	( unpackFS )
-import AbsCSyn		( AbstractC )
-import PprAbsC		( dumpRealC, writeRealC )
+import Cmm		( Cmm )
 import HscTypes
-import CmdLineOpts
-import ErrUtils		( dumpIfSet_dyn, showPass )
+import DynFlags
+import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
 import Pretty		( Mode(..), printDoc )
-import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
+import Module		( Module, ModLocation(..) )
+import List		( nub )
+import Maybes		( firstJust )
+
+import Distribution.Package	( showPackageId )
+import Directory	( doesFileExist )
 import Monad		( when )
 import IO
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection{Steering}
@@ -48,17 +53,14 @@ import IO
 
 \begin{code}
 codeOutput :: DynFlags
-	   -> ModGuts
-	   -> AbstractC			-- Compiled abstract C
+	   -> Module
+	   -> ModLocation
+	   -> ForeignStubs
+	   -> [PackageId]
+	   -> [Cmm]			-- Compiled C--
 	   -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
-codeOutput dflags 
-	   (ModGuts {mg_module = mod_name,
-		     mg_types  = type_env,
-		     mg_foreign = foreign_stubs,
-		     mg_deps	= deps,
-		     mg_binds   = core_binds})
-	   flat_abstractC
+codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
   = 
     -- You can have C (c_output) or assembly-language (ncg_output),
     -- but not both.  [Allowing for both gives a space leak on
@@ -66,14 +68,25 @@ codeOutput dflags
 
     -- Dunno if the above comment is still meaningful now.  JRS 001024.
 
-    do	{ showPass dflags "CodeOutput"
-	; let filenm = dopt_OutName dflags 
-	; stubs_exist <- outputForeignStubs dflags foreign_stubs
-	; case dopt_HscLang dflags of {
+    do	{ when (dopt Opt_DoCmmLinting dflags) $ do
+		{ showPass dflags "CmmLint"
+		; let lints = map cmmLint flat_abstractC
+		; case firstJust lints of
+			Just err -> do { printDump err
+				       ; ghcExit dflags 1
+				       }
+			Nothing  -> return ()
+		}
+
+	; showPass dflags "CodeOutput"
+	; let filenm = hscOutName dflags 
+	; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
+	; case hscTarget dflags of {
              HscInterpreted -> return ();
              HscAsm         -> outputAsm dflags filenm flat_abstractC;
-             HscC           -> outputC dflags filenm flat_abstractC stubs_exist
-					deps foreign_stubs;
+             HscC           -> outputC dflags filenm this_mod location 
+				 flat_abstractC stubs_exist pkg_deps
+				 foreign_stubs;
              HscJava        -> 
 #ifdef JAVA
 			       outputJava dflags filenm mod_name tycons core_binds;
@@ -87,6 +100,7 @@ codeOutput dflags
 #else
                                panic "ILX support not compiled into this ghc";
 #endif
+             HscNothing     -> return ();
 	  }
 	; return stubs_exist
 	}
@@ -103,27 +117,31 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 %************************************************************************
 
 \begin{code}
-outputC dflags filenm flat_absC 
-	(stub_h_exists, _) dependencies (ForeignStubs _ _ ffi_decl_headers _ ) 
-  = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
-
+outputC dflags filenm mod location flat_absC 
+	(stub_h_exists, _) packages foreign_stubs
+  = do 
        -- figure out which header files to #include in the generated .hc file:
        --
        --   * extra_includes from packages
        --   * -#include options from the cmdline and OPTIONS pragmas
        --   * the _stub.h file, if there is one.
        --
-       let packages = dep_pkgs dependencies
-       pkg_configs <- getExplicitPackagesAnd packages
-       let pkg_names = map name pkg_configs
+       pkg_configs <- getExplicitPackagesAnd dflags packages
+       let pkg_names = map (showPackageId.package) pkg_configs
 
        c_includes <- getPackageCIncludes pkg_configs
        let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
        
+	   ffi_decl_headers 
+	      = case foreign_stubs of
+		  NoStubs 		  -> []
+		  ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs)
+			-- Remove duplicates, because distinct foreign import decls
+			-- may cite the same #include.  Order doesn't matter.
+
            all_headers =  c_includes
 		       ++ reverse cmdline_includes
-		       ++ reverse (map unpackFS ffi_decl_headers)
-			   -- reverse correct?
+		       ++ ffi_decl_headers
 
        let cc_injects = unlines (map mk_include all_headers)
        	   mk_include h_file = 
@@ -136,8 +154,10 @@ outputC dflags filenm flat_absC
 	  hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 	  hPutStr h cc_injects
 	  when stub_h_exists $ 
-	     hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
-	  writeRealC h flat_absC
+	     hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
+	  writeCs dflags h flat_absC
+  where
+    (_, stub_h) = mkStubPaths dflags mod location
 \end{code}
 
 
@@ -153,9 +173,8 @@ outputAsm dflags filenm flat_absC
 #ifndef OMIT_NATIVE_CODEGEN
 
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
-       let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen" 
-				        nativeCodeGen flat_absC ncg_uniqs
-       dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
+       ncg_output_d <- _scc_ "NativeCodeGen" 
+			  nativeCodeGen dflags flat_absC ncg_uniqs
        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
        _scc_ "OutputAsm" doOutput filenm $
 	   \f -> printDoc LeftMode f ncg_output_d
@@ -213,31 +232,53 @@ outputIlx dflags filename mod tycons stg_binds
 %************************************************************************
 
 \begin{code}
-outputForeignStubs :: DynFlags -> ForeignStubs
+outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
 		   -> IO (Bool, 	-- Header file created
 			  Bool)		-- C file created
-outputForeignStubs dflags NoStubs = return (False, False)
-outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
+outputForeignStubs dflags mod location stubs
+  | NoStubs <- stubs = do
+	-- When compiling External Core files, may need to use stub
+	-- files from a previous compilation
+	stub_c_exists <- doesFileExist stub_c
+	stub_h_exists <- doesFileExist stub_h
+	return (stub_h_exists, stub_c_exists)
+
+  | ForeignStubs h_code c_code _ _ <- stubs
   = do
+	let
+	    stub_c_output_d = pprCode CStyle c_code
+	    stub_c_output_w = showSDoc stub_c_output_d
+	
+	    -- Header file protos for "foreign export"ed functions.
+	    stub_h_output_d = pprCode CStyle h_code
+	    stub_h_output_w = showSDoc stub_h_output_d
+	-- in
+
+	createDirectoryHierarchy (directoryOf stub_c)
+
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d
 
 	-- we need the #includes from the rts package for the stub files
-	rts_pkgs <- getPackageDetails [rtsPackage]
- 	let rts_includes = concatMap mk_include (concatMap c_includes rts_pkgs)
+	let rtsid = rtsPackageId (pkgState dflags)
+ 	    rts_includes 
+		| ExtPackage pid <- rtsid = 
+			let rts_pkg = getPackageDetails (pkgState dflags) pid in
+			concatMap mk_include (includes rts_pkg)
+		| otherwise = []
 	    mk_include i = "#include \"" ++ i ++ "\"\n"
 
 	stub_h_file_exists
-           <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
+           <- outputForeignStubs_help stub_h stub_h_output_w
 		("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
 
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export stubs" stub_c_output_d
 
 	stub_c_file_exists
-           <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
+           <- outputForeignStubs_help stub_c stub_c_output_w
 		("#define IN_STG_CODE 0\n" ++ 
-		 "#include \"RtsAPI.h\"\n" ++
+		 "#include \"Rts.h\"\n" ++
 		 rts_includes ++
 		 cplusplus_hdr)
 		 cplusplus_ftr
@@ -247,13 +288,7 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _)
 
         return (stub_h_file_exists, stub_c_file_exists)
   where
-    -- C stubs for "foreign export"ed functions.
-    stub_c_output_d = pprCode CStyle c_code
-    stub_c_output_w = showSDoc stub_c_output_d
-
-    -- Header file protos for "foreign export"ed functions.
-    stub_h_output_d = pprCode CStyle h_code
-    stub_h_output_w = showSDoc stub_h_output_d
+   (stub_c, stub_h) = mkStubPaths dflags mod location
 
 cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
 cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"