X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=e7e818fa50b3d255a08141ca7750d2015bdb663e;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hp=61b10bcc3821e4bf290e937a4edcc2440840297f;hpb=5ddee764beb312933256096d03df7c3ec47ac452;p=ghc-hetmet.git

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 61b10bc..e7e818f 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -23,19 +23,15 @@ import Finder		( mkStubPaths )
 import PprC		( writeCs )
 import CmmLint		( cmmLint )
 import Packages
-import PackageConfig	( rtsPackageId )
 import Util
 import FastString	( unpackFS )
-import Cmm		( Cmm )
+import Cmm		( RawCmm )
 import HscTypes
 import DynFlags
 
-import StaticFlags      ( opt_DoTickyProfiling )
-
 import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
-import Pretty		( Mode(..), printDoc )
-import Module		( Module, ModLocation(..), moduleName )
+import Module
 import List		( nub )
 import Maybes		( firstJust )
 
@@ -57,7 +53,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
@@ -93,6 +89,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 #else
                                panic "Java support not compiled into this ghc";
 #endif
+             HscNothing     -> panic "codeOutput: HscNothing"
 	  }
 	; return stubs_exist
 	}
@@ -109,6 +106,14 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 %************************************************************************
 
 \begin{code}
+outputC :: DynFlags
+        -> FilePath -> Module -> ModLocation
+        -> [RawCmm]
+        -> (Bool, Bool)
+        -> [PackageId]
+        -> ForeignStubs
+        -> IO ()
+
 outputC dflags filenm mod location flat_absC 
 	(stub_h_exists, _) packages foreign_stubs
   = do 
@@ -126,8 +131,8 @@ outputC dflags filenm mod location flat_absC
        
 	   ffi_decl_headers 
 	      = case foreign_stubs of
-		  NoStubs 		  -> []
-		  ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs)
+		  NoStubs 		-> []
+		  ForeignStubs _ _ fdhs -> map unpackFS (nub fdhs)
 			-- Remove duplicates, because distinct foreign import decls
 			-- may cite the same #include.  Order doesn't matter.
 
@@ -146,10 +151,10 @@ outputC dflags filenm mod location flat_absC
 	  hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 	  hPutStr h cc_injects
 	  when stub_h_exists $ 
-	     hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"")
+	     hPutStrLn h ("#include \"" ++ inc_stub_h ++ "\"")
 	  writeCs dflags h flat_absC
   where
-    (_, stub_h) = mkStubPaths dflags (moduleName mod) location
+    (_, _, inc_stub_h) = mkStubPaths dflags (moduleName mod) location
 \end{code}
 
 
@@ -160,16 +165,16 @@ outputC dflags filenm mod location flat_absC
 %************************************************************************
 
 \begin{code}
+outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
 outputAsm dflags filenm flat_absC
 
 #ifndef OMIT_NATIVE_CODEGEN
 
   = 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 */
@@ -212,15 +217,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
@@ -261,15 +266,17 @@ outputForeignStubs dflags mod location stubs
 
         return (stub_h_file_exists, stub_c_file_exists)
   where
-   (stub_c, stub_h) = mkStubPaths dflags (moduleName 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