Fix segfault in array copy primops on 32-bit

[ghc-hetmet.git] / compiler / main / CodeOutput.lhs

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 83f23cf..b58b7cd 100644 (file)
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -8,31 +8,26 @@ module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
 
-#ifndef OMIT_NATIVE_CODEGEN
-import UniqSupply      ( mkSplitUniqSupply )
-import AsmCodeGen      ( nativeCodeGen )
-#endif
+import AsmCodeGen ( nativeCodeGen )
+import LlvmCodeGen ( llvmCodeGen )
 
-#ifdef JAVA
-import JavaGen         ( javaGen )
-import qualified PrintJava
-import OccurAnal       ( occurAnalyseBinds )
-#endif
+import UniqSupply      ( mkSplitUniqSupply )
 
 import Finder          ( mkStubPaths )
 import PprC            ( writeCs )
 import CmmLint         ( cmmLint )
 import Packages
 import Util
-import Cmm             ( RawCmm )
+import OldCmm          ( RawCmm )
 import HscTypes
 import DynFlags
 import Config
+import SysTools
 
 import ErrUtils                ( dumpIfSet_dyn, showPass, ghcExit )
 import Outputable
 import Module
-import Maybes          ( firstJust )
+import Maybes          ( firstJusts )
 
 import Control.Exception
 import Control.Monad
@@ -54,7 +49,7 @@ codeOutput :: DynFlags
           -> ForeignStubs
           -> [PackageId]
           -> [RawCmm]                  -- Compiled C--
-          -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
+           -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
 
 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
   = 
@@ -67,7 +62,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
     do { when (dopt Opt_DoCmmLinting dflags) $ do
                { showPass dflags "CmmLint"
                ; let lints = map cmmLint flat_abstractC
-               ; case firstJust lints of
+               ; case firstJusts lints of
                        Just err -> do { printDump err
                                       ; ghcExit dflags 1
                                       }
@@ -81,12 +76,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
              HscInterpreted -> return ();
              HscAsm         -> outputAsm dflags filenm flat_abstractC;
              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
+             HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
              HscNothing     -> panic "codeOutput: HscNothing"
          }
        ; return stubs_exist
@@ -145,44 +135,30 @@ outputC dflags filenm flat_absC packages
 
 \begin{code}
 outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-
-#ifndef OMIT_NATIVE_CODEGEN
-
 outputAsm dflags filenm flat_absC
+ | cGhcWithNativeCodeGen == "YES"
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
 
        {-# SCC "OutputAsm" #-} doOutput filenm $
-          \f -> {-# SCC "NativeCodeGen" #-}
-                nativeCodeGen dflags f ncg_uniqs flat_absC
-  where
-
-#else /* OMIT_NATIVE_CODEGEN */
+           \f -> {-# SCC "NativeCodeGen" #-}
+                 nativeCodeGen dflags f ncg_uniqs flat_absC
 
-outputAsm _ _ _
-  = pprPanic "This compiler was built without a native code generator"
-            (text "Use -fvia-C instead")
-
-#endif
+ | otherwise
+  = panic "This compiler was built without a native code generator"
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{Java}
+\subsection{LLVM}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-#ifdef JAVA
-outputJava dflags filenm mod tycons core_binds
-  = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
-       -- User style printing for now to keep indentation
-  where
-    occ_anal_binds = occurAnalyseBinds core_binds
-       -- Make sure we have up to date dead-var information
-    java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
-    pp_java   = PrintJava.compilationUnit java_code
-#endif
+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}
 
 
@@ -195,18 +171,21 @@ outputJava dflags filenm mod tycons core_binds
 \begin{code}
 outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
                   -> IO (Bool,         -- Header file created
-                         Bool)         -- C file created
+                          Maybe FilePath) -- C file created
 outputForeignStubs dflags mod location stubs
- = case stubs of
-   NoStubs -> do
+ = do
+   let stub_h = mkStubPaths dflags (moduleName mod) location
+   stub_c <- newTempName dflags "c"
+
+   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)
+        stub_h_exists <- doesFileExist stub_h
+        return (stub_h_exists, Nothing)
 
-   ForeignStubs h_code c_code -> do
-       let
+     ForeignStubs h_code c_code -> do
+        let
            stub_c_output_d = pprCode CStyle c_code
            stub_c_output_w = showSDoc stub_c_output_d
        
@@ -215,7 +194,7 @@ outputForeignStubs dflags mod location stubs
            stub_h_output_w = showSDoc stub_h_output_d
        -- in
 
-       createDirectoryHierarchy (takeDirectory stub_c)
+        createDirectoryHierarchy (takeDirectory stub_h)
 
        dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d
@@ -249,10 +228,10 @@ outputForeignStubs dflags mod location stubs
           -- isn't really HC code, so we need to define IN_STG_CODE==0 to
           -- avoid the register variables etc. being enabled.
 
-        return (stub_h_file_exists, stub_c_file_exists)
-  where
-   (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
-
+        return (stub_h_file_exists, if stub_c_file_exists
+                                       then Just stub_c
+                                       else Nothing )
+ where
    cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
    cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"