X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=2d68b830ecfc6f5ffed74dee6cf31f987d4147b6;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=d1b293353acc14ff3291fc867b16ce670c6219f0;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index d1b2933..2d68b83 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -13,10 +13,6 @@ import UniqSupply	( mkSplitUniqSupply )
 import AsmCodeGen	( nativeCodeGen )
 #endif
 
-#ifdef ILX
-import IlxGen		( ilxGen )
-#endif
-
 #ifdef JAVA
 import JavaGen		( javaGen )
 import qualified PrintJava
@@ -28,21 +24,20 @@ import PprC		( writeCs )
 import CmmLint		( cmmLint )
 import Packages
 import Util
-import FastString	( unpackFS )
-import Cmm		( Cmm )
+import Cmm		( RawCmm )
 import HscTypes
 import DynFlags
+
 import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
-import Pretty		( Mode(..), printDoc )
-import Module		( Module, ModLocation(..) )
-import List		( nub )
+import Module
 import Maybes		( firstJust )
 
-import Distribution.Package	( showPackageId )
-import Directory	( doesFileExist )
-import Monad		( when )
-import IO
+import Control.Exception
+import Control.Monad
+import System.Directory
+import System.FilePath
+import System.IO
 \end{code}
 
 %************************************************************************
@@ -57,7 +52,7 @@ codeOutput :: DynFlags
 	   -> ModLocation
 	   -> ForeignStubs
 	   -> [PackageId]
-	   -> [Cmm]			-- Compiled C--
+	   -> [RawCmm]			-- Compiled C--
 	   -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
@@ -84,22 +79,14 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 	; case hscTarget dflags of {
              HscInterpreted -> return ();
              HscAsm         -> outputAsm dflags filenm flat_abstractC;
-             HscC           -> outputC dflags filenm this_mod location 
-				 flat_abstractC stubs_exist pkg_deps
-				 foreign_stubs;
+             HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
              HscJava        -> 
 #ifdef JAVA
 			       outputJava dflags filenm mod_name tycons core_binds;
 #else
                                panic "Java support not compiled into this ghc";
 #endif
-	     HscILX         -> 
-#ifdef ILX
-			       let tycons = typeEnvTyCons type_env in
-	                       outputIlx dflags filenm mod_name tycons stg_binds;
-#else
-                               panic "ILX support not compiled into this ghc";
-#endif
+             HscNothing     -> panic "codeOutput: HscNothing"
 	  }
 	; return stubs_exist
 	}
@@ -116,8 +103,13 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 %************************************************************************
 
 \begin{code}
-outputC dflags filenm mod location flat_absC 
-	(stub_h_exists, _) packages foreign_stubs
+outputC :: DynFlags
+        -> FilePath
+        -> [RawCmm]
+        -> [PackageId]
+        -> IO ()
+
+outputC dflags filenm flat_absC packages
   = do 
        -- figure out which header files to #include in the generated .hc file:
        --
@@ -125,38 +117,22 @@ outputC dflags filenm mod location flat_absC
        --   * -#include options from the cmdline and OPTIONS pragmas
        --   * the _stub.h file, if there is one.
        --
-       pkg_configs <- getExplicitPackagesAnd dflags packages
-       let pkg_names = map (showPackageId.package) pkg_configs
-
-       c_includes <- getPackageCIncludes pkg_configs
-       let cmdline_includes = cmdlineHcIncludes dflags -- -#include options
-       
-	   ffi_decl_headers 
-	      = case foreign_stubs of
-		  NoStubs 		  -> []
-		  ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs)
-			-- Remove duplicates, because distinct foreign import decls
-			-- may cite the same #include.  Order doesn't matter.
-
-           all_headers =  c_includes
-		       ++ reverse cmdline_includes
-		       ++ ffi_decl_headers
-
-       let cc_injects = unlines (map mk_include all_headers)
+       let rts = getPackageDetails (pkgState dflags) rtsPackageId
+                       
+       let cc_injects = unlines (map mk_include (includes rts))
        	   mk_include h_file = 
        	    case h_file of 
        	       '"':_{-"-} -> "#include "++h_file
        	       '<':_      -> "#include "++h_file
        	       _          -> "#include \""++h_file++"\""
 
+       pkg_configs <- getPreloadPackagesAnd dflags packages
+       let pkg_names = map (display.sourcePackageId) pkg_configs
+
        doOutput filenm $ \ h -> do
 	  hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 	  hPutStr h cc_injects
-	  when stub_h_exists $ 
-	     hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
 	  writeCs dflags h flat_absC
-  where
-    (_, stub_h) = mkStubPaths dflags mod location
 \end{code}
 
 
@@ -167,20 +143,21 @@ outputC dflags filenm mod location flat_absC
 %************************************************************************
 
 \begin{code}
-outputAsm dflags filenm flat_absC
+outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 
 #ifndef OMIT_NATIVE_CODEGEN
 
+outputAsm dflags filenm flat_absC
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
-       ncg_output_d <- _scc_ "NativeCodeGen" 
-			  nativeCodeGen dflags flat_absC ncg_uniqs
-       dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" (docToSDoc ncg_output_d)
-       _scc_ "OutputAsm" doOutput filenm $
-	   \f -> printDoc LeftMode f ncg_output_d
+
+       {-# SCC "OutputAsm" #-} doOutput filenm $
+	   \f -> {-# SCC "NativeCodeGen" #-}
+	         nativeCodeGen dflags f ncg_uniqs flat_absC
   where
 
 #else /* OMIT_NATIVE_CODEGEN */
 
+outputAsm _ _ _
   = pprPanic "This compiler was built without a native code generator"
 	     (text "Use -fvia-C instead")
 
@@ -210,22 +187,6 @@ outputJava dflags filenm mod tycons core_binds
 
 %************************************************************************
 %*									*
-\subsection{Ilx}
-%*									*
-%************************************************************************
-
-\begin{code}
-#ifdef ILX
-outputIlx dflags filename mod tycons stg_binds
-  =  doOutput filename (\ f -> printForC f pp_ilx)
-  where
-    pp_ilx = ilxGen mod tycons stg_binds
-#endif
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection{Foreign import/export}
 %*									*
 %************************************************************************
@@ -235,15 +196,15 @@ outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
 		   -> IO (Bool, 	-- Header file created
 			  Bool)		-- C file created
 outputForeignStubs dflags mod location stubs
-  | NoStubs <- stubs = do
+ = 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)
 
-  | ForeignStubs h_code c_code _ _ <- stubs
-  = do
+   ForeignStubs h_code c_code -> do
 	let
 	    stub_c_output_d = pprCode CStyle c_code
 	    stub_c_output_w = showSDoc stub_c_output_d
@@ -253,18 +214,15 @@ outputForeignStubs dflags mod location stubs
 	    stub_h_output_w = showSDoc stub_h_output_d
 	-- in
 
-	createDirectoryHierarchy (directoryOf stub_c)
+	createDirectoryHierarchy (takeDirectory stub_c)
 
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d
 
 	-- we need the #includes from the rts package for the stub files
-	let rtsid = rtsPackageId (pkgState dflags)
- 	    rts_includes 
-		| ExtPackage pid <- rtsid = 
-			let rts_pkg = getPackageDetails (pkgState dflags) pid in
-			concatMap mk_include (includes rts_pkg)
-		| otherwise = []
+	let rts_includes = 
+	       let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in
+	       concatMap mk_include (includes rts_pkg)
 	    mk_include i = "#include \"" ++ i ++ "\"\n"
 
 	stub_h_file_exists
@@ -287,15 +245,17 @@ outputForeignStubs dflags mod location stubs
 
         return (stub_h_file_exists, stub_c_file_exists)
   where
-   (stub_c, stub_h) = mkStubPaths dflags mod location
+   (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
+
+   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+   cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 
-cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
-cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 
 -- Don't use doOutput for dumping the f. export stubs
 -- since it is more than likely that the stubs file will
 -- turn out to be empty, in which case no file should be created.
-outputForeignStubs_help fname ""      header footer = return False
+outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
+outputForeignStubs_help _fname ""      _header _footer = return False
 outputForeignStubs_help fname doc_str header footer
    = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
         return True