X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=2b0d745ae3bcddea19ff9385be17f439ad2cc3b8;hb=9c383315203f0ad7cfd65272d04d921c0cef3cec;hp=9e0dada123e15e50fbfbf1bfab80ca96fb0b22b2;hpb=45ddebc0dc20f013eff011a157b42acb37ea7598;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 9e0dada..2b0d745 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -19,25 +19,24 @@ import IlxGen		( ilxGen )
 
 #ifdef JAVA
 import JavaGen		( javaGen )
+import OccurAnal	( occurAnalyseBinds )
 import qualified PrintJava
+import OccurAnal	( occurAnalyseBinds )
 #endif
 
+import FastString	( unpackFS )
 import DriverState	( v_HCHeader )
-import TyCon		( TyCon )
 import Id		( Id )
-import CoreSyn		( CoreBind )
-import OccurAnal	( occurAnalyseBinds )
 import StgSyn		( StgBinding )
 import AbsCSyn		( AbstractC )
 import PprAbsC		( dumpRealC, writeRealC )
-import Module		( Module )
+import HscTypes		( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons )
 import CmdLineOpts
 import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
 import Pretty		( Mode(..), printDoc )
 import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
-
-import IOExts
+import DATA_IOREF	( readIORef, writeIORef )
 import Monad		( when )
 import IO
 \end{code}
@@ -51,17 +50,20 @@ import IO
 
 \begin{code}
 codeOutput :: DynFlags
-	   -> Module
-	   -> [TyCon]			-- Local tycons
-	   -> [CoreBind]		-- Core bindings
+	   -> ModGuts
 	   -> [(StgBinding,[Id])]	-- The STG program with SRTs
-	   -> SDoc 		-- C stubs for foreign exported functions
-	   -> SDoc		-- Header file prototype for foreign exported functions
-	   -> AbstractC		-- Compiled abstract C
+	   -> AbstractC			-- Compiled abstract C
 	   -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
-codeOutput dflags mod_name tycons core_binds stg_binds 
-	   c_code h_code flat_abstractC
-  = -- You can have C (c_output) or assembly-language (ncg_output),
+codeOutput dflags 
+	   (ModGuts {mg_module = mod_name,
+		     mg_types  = type_env,
+		     mg_foreign = foreign_stubs,
+		     mg_binds   = core_binds})
+	   stg_binds flat_abstractC
+  = let
+	tycons = typeEnvTyCons type_env
+    in
+    -- You can have C (c_output) or assembly-language (ncg_output),
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
 
@@ -69,7 +71,7 @@ codeOutput dflags mod_name tycons core_binds stg_binds
 
     do	{ showPass dflags "CodeOutput"
 	; let filenm = dopt_OutName dflags 
-	; stub_names <- outputForeignStubs dflags c_code h_code
+	; stub_names <- outputForeignStubs dflags foreign_stubs
 	; case dopt_HscLang dflags of
              HscInterpreted -> return stub_names
              HscAsm         -> outputAsm dflags filenm flat_abstractC
@@ -93,12 +95,7 @@ codeOutput dflags mod_name tycons core_binds stg_binds
 	}
 
 doOutput :: String -> (Handle -> IO ()) -> IO ()
-doOutput filenm io_action
-  = (do	handle <- openFile filenm WriteMode
-	io_action handle
-	hClose handle)
-    `catch` (\err -> pprPanic "Failed to open or write code output file" 
-			      (text filenm))
+doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 \end{code}
 
 
@@ -192,7 +189,20 @@ outputIlx dflags filename mod tycons stg_binds
 %************************************************************************
 
 \begin{code}
-outputForeignStubs dflags c_code h_code
+    -- Turn the list of headers requested in foreign import
+    -- declarations into a string suitable for emission into generated
+    -- C code...
+mkForeignHeaders headers
+  = unlines 
+  . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"")
+  . reverse 
+  $ headers
+
+outputForeignStubs :: DynFlags -> ForeignStubs
+		   -> IO (Bool, 	-- Header file created
+			  Bool)		-- C file created
+outputForeignStubs dflags NoStubs = return (False, False)
+outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _)
   = do
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d
@@ -204,16 +214,19 @@ outputForeignStubs dflags c_code h_code
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export stubs" stub_c_output_d
 
-        hc_header <- readIORef v_HCHeader
+	  -- Extend the list of foreign headers (used in outputC)
+        fhdrs <- readIORef v_HCHeader
+	let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs
+        writeIORef v_HCHeader new_fhdrs
 
 	stub_c_file_exists
            <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
 		("#define IN_STG_CODE 0\n" ++ 
-		 hc_header ++
+		 new_fhdrs ++
 		 "#include \"RtsAPI.h\"\n" ++
 		 cplusplus_hdr)
 		 cplusplus_ftr
-	   -- we're adding the default hc_header to the stub file, but this
+	   -- We're adding the default hc_header to the stub file, but this
 	   -- isn't really HC code, so we need to define IN_STG_CODE==0 to
 	   -- avoid the register variables etc. being enabled.