X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FCodeOutput.lhs;h=bc2dd1eafc5d225bd3a4584b1c6f7471efdd08e8;hp=e7e818fa50b3d255a08141ca7750d2015bdb663e;hb=24a3fee9f3ff6cef6fe471ab6f0a7ba9ac001faf;hpb=bdd9123e3852e350a5f66cb5e4b267626d0e7596

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index e7e818f..bc2dd1e 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -9,9 +9,11 @@ module CodeOutput( codeOutput, outputForeignStubs ) where
 #include "HsVersions.h"
 
 #ifndef OMIT_NATIVE_CODEGEN
-import UniqSupply	( mkSplitUniqSupply )
 import AsmCodeGen	( nativeCodeGen )
 #endif
+import LlvmCodeGen ( llvmCodeGen )
+
+import UniqSupply	( mkSplitUniqSupply )
 
 #ifdef JAVA
 import JavaGen		( javaGen )
@@ -24,21 +26,21 @@ import PprC		( writeCs )
 import CmmLint		( cmmLint )
 import Packages
 import Util
-import FastString	( unpackFS )
 import Cmm		( RawCmm )
 import HscTypes
 import DynFlags
+import Config
 
 import ErrUtils		( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
 import Module
-import List		( nub )
 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}
 
 %************************************************************************
@@ -80,9 +82,8 @@ 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;
+             HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
              HscJava        -> 
 #ifdef JAVA
 			       outputJava dflags filenm mod_name tycons core_binds;
@@ -107,15 +108,12 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
 
 \begin{code}
 outputC :: DynFlags
-        -> FilePath -> Module -> ModLocation
+        -> FilePath
         -> [RawCmm]
-        -> (Bool, Bool)
         -> [PackageId]
-        -> ForeignStubs
         -> IO ()
 
-outputC dflags filenm mod location flat_absC 
-	(stub_h_exists, _) packages foreign_stubs
+outputC dflags filenm flat_absC packages
   = do 
        -- figure out which header files to #include in the generated .hc file:
        --
@@ -123,38 +121,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 <- getPreloadPackagesAnd 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 rts = getPackageDetails (pkgState dflags) rtsPackageId
                        
-       let cc_injects = unlines (map mk_include all_headers)
+       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 \"" ++ inc_stub_h ++ "\"")
 	  writeCs dflags h flat_absC
-  where
-    (_, _, inc_stub_h) = mkStubPaths dflags (moduleName mod) location
 \end{code}
 
 
@@ -166,10 +148,10 @@ outputC dflags filenm mod location flat_absC
 
 \begin{code}
 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-outputAsm dflags filenm flat_absC
 
 #ifndef OMIT_NATIVE_CODEGEN
 
+outputAsm dflags filenm flat_absC
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
        {-# SCC "OutputAsm" #-} doOutput filenm $
@@ -179,6 +161,7 @@ outputAsm dflags filenm flat_absC
 
 #else /* OMIT_NATIVE_CODEGEN */
 
+outputAsm _ _ _
   = pprPanic "This compiler was built without a native code generator"
 	     (text "Use -fvia-C instead")
 
@@ -188,6 +171,20 @@ outputAsm dflags filenm flat_absC
 
 %************************************************************************
 %*									*
+\subsection{LLVM}
+%*									*
+%************************************************************************
+
+\begin{code}
+outputLlvm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
+outputLlvm dflags filenm flat_absC
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+       doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Java}
 %*									*
 %************************************************************************
@@ -225,7 +222,7 @@ outputForeignStubs dflags mod location stubs
 	stub_h_exists <- doesFileExist stub_h
 	return (stub_h_exists, stub_c_exists)
 
-   ForeignStubs h_code c_code _ -> 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
@@ -235,7 +232,7 @@ 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
@@ -246,6 +243,10 @@ outputForeignStubs dflags mod location stubs
 	       concatMap mk_include (includes rts_pkg)
 	    mk_include i = "#include \"" ++ i ++ "\"\n"
 
+            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
+            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
+                         | otherwise = ""
+
 	stub_h_file_exists
            <- outputForeignStubs_help stub_h stub_h_output_w
 		("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
@@ -258,6 +259,7 @@ outputForeignStubs dflags mod location stubs
 		("#define IN_STG_CODE 0\n" ++ 
 		 "#include \"Rts.h\"\n" ++
 		 rts_includes ++
+		 ffi_includes ++
 		 cplusplus_hdr)
 		 cplusplus_ftr
 	   -- We're adding the default hc_header to the stub file, but this