Various hsc2hs improvements
authorIan Lynagh <igloo@earth.li>
Tue, 25 Oct 2011 14:45:36 +0000 (15:45 +0100)
committerIan Lynagh <igloo@earth.li>
Tue, 25 Oct 2011 14:45:36 +0000 (15:45 +0100)
* Fix GHC trac #2897: Generate a separate "utils" C file containing
  wrappers for functions like printf. This means template-hsc.h
  doesn't need to includes any headers, so we don't pollute the C
  environment.
  (actually, we still need to include stddef.h).

* Use runProcess rather than system. It used to try to conditionally
  use runProcess if it was available, but never actually did. Now it
  uses it unconditionally.

* Some tidying up

C.hs
CrossCodegen.hs
DirectCodegen.hs
Main.hs
UtilsCodegen.hs [new file with mode: 0644]
hsc2hs.cabal
template-hsc.h

diff --git a/C.hs b/C.hs
index a3154a2..537d77a 100644 (file)
--- a/C.hs
+++ b/C.hs
@@ -38,7 +38,7 @@ outHeaderCProg (pos, key, arg) = case key of
             (name, args) ->
                 outCLine pos++
                 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
             (name, args) ->
                 outCLine pos++
                 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
-                "printf ("++joinLines body++");\n"
+                "hsc_printf ("++joinLines body++");\n"
     _ -> ""
    where
     joinLines = concat . intersperse " \\\n" . lines
     _ -> ""
    where
     joinLines = concat . intersperse " \\\n" . lines
@@ -66,7 +66,7 @@ outHeaderHs flags inH toks =
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value
     outOption s =
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value
     outOption s =
-       "    printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
+        "    hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
                   showCString s++"\");\n"
 
 outTokenHs :: Token -> String
                   showCString s++"\");\n"
 
 outTokenHs :: Token -> String
@@ -78,7 +78,7 @@ outTokenHs (Text pos txt) =
             outHsLine pos++
             outText rest
     where
             outHsLine pos++
             outText rest
     where
-    outText s = "    fputs (\""++showCString s++"\", stdout);\n"
+    outText s = "    hsc_fputs (\""++showCString s++"\", hsc_stdout());\n"
 outTokenHs (Special pos key arg) =
     case key of
         "include"           -> ""
 outTokenHs (Special pos key arg) =
     case key of
         "include"           -> ""
@@ -117,7 +117,7 @@ outEnum arg = case parseEnum arg of
                     cName++");\n"
                Just hsName ->
                     "    hsc_enum ("++t++", "++f++", " ++
                     cName++");\n"
                Just hsName ->
                     "    hsc_enum ("++t++", "++f++", " ++
-                    "printf (\"%s\", \""++hsName++"\"), "++
+                    "hsc_printf (\"%s\", \""++hsName++"\"), "++
                     cName++");\n"
 
 outFlagH :: Flag -> String
                     cName++");\n"
 
 outFlagH :: Flag -> String
index 6e8855a..b4f648f 100644 (file)
@@ -31,11 +31,8 @@ import Data.Foldable (concatMap)
 import Data.Maybe (fromMaybe)
 import qualified Data.Sequence as S
 import Data.Sequence ((|>),ViewL(..))
 import Data.Maybe (fromMaybe)
 import qualified Data.Sequence as S
 import Data.Sequence ((|>),ViewL(..))
-
-#ifndef HAVE_runProcess
-import System.Cmd               ( system )
-#endif
 import System.Exit              ( ExitCode(..) )
 import System.Exit              ( ExitCode(..) )
+import System.Process
 
 import C
 import Common
 
 import C
 import Common
@@ -551,17 +548,22 @@ runCompileTest testStr = do
                   (Just stdout)
 
 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
                   (Just stdout)
 
 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
-runCompiler prog args stdoutFile = do
-  let cmdLine = prog++" "++unwords args++(maybe "" (\f -> " >&"++f) stdoutFile)
-  testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
-#ifndef HAVE_runProcess
-      exitStatus <- system cmdLine
+runCompiler prog args mStdoutFile = do
+  let cmdLine =
+#if MIN_VERSION_process(1,1,0)
+            showCommandForUser prog args
 #else
 #else
-      hOut <- maybe (return Nothing) (fmap Just . openFile stdoutFile WriteMode) stdoutFile
-      process <- runProcess prog args Nothing Nothing Nothing hOut hOut
-      maybe (return ()) hClose hOut
-      exitStatus <- waitForProcess process
+            unwords (prog : args)
 #endif
 #endif
+  testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
+      mHOut <- case mStdoutFile of
+               Nothing -> return Nothing
+               Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode
+      process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut
+      case mHOut of
+          Just hOut -> hClose hOut
+          Nothing -> return ()
+      exitStatus <- waitForProcess process
       return $ case exitStatus of
                  ExitSuccess -> True
                  ExitFailure _ -> False
       return $ case exitStatus of
                  ExitSuccess -> True
                  ExitFailure _ -> False
@@ -575,8 +577,8 @@ outputCross config outName outDir outBase inName toks =
            `testFinally` (liftTestIO $ hClose file))
            `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
     where
            `testFinally` (liftTestIO $ hClose file))
            `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
     where
-    env = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
-    runTestMonad x = runTest x env 0 >>= (handleError . fst)
+    tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
+    runTestMonad x = runTest x tmenv 0 >>= (handleError . fst)
 
     handleError (Left e) = die (e++"\n")
     handleError (Right ()) = return ()
 
     handleError (Left e) = die (e++"\n")
     handleError (Right ()) = return ()
index 0e132ab..deec791 100644 (file)
@@ -15,6 +15,7 @@ import C
 import Common
 import Flags
 import HSCParser
 import Common
 import Flags
 import HSCParser
+import UtilsCodegen
 
 outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
 outputDirect config outName outDir outBase name toks = do
 
 outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
 outputDirect config outName outDir outBase name toks = do
@@ -70,18 +71,19 @@ outputDirect config outName outDir outBase name toks = do
     when (cNoCompile config) $ exitWith ExitSuccess
 
     rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
     when (cNoCompile config) $ exitWith ExitSuccess
 
     rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
-       (  ["-c"]
+        (  ["-c"]
         ++ [cProgName]
         ++ ["-o", oProgName]
         ++ [f | CompFlag f <- flags]
         ++ [cProgName]
         ++ ["-o", oProgName]
         ++ [f | CompFlag f <- flags]
-       )
-    possiblyRemove cProgName $ do
+        )
+    possiblyRemove cProgName $
+        withUtilsObject config outDir outBase $ \oUtilsName -> do
 
       rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
 
       rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
-        (  [oProgName]
+        (  [oProgName, oUtilsName]
         ++ ["-o", progName]
         ++ [f | LinkFlag f <- flags]
         ++ ["-o", progName]
         ++ [f | LinkFlag f <- flags]
-       )
+        )
       possiblyRemove oProgName $ do
 
         rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
       possiblyRemove oProgName $ do
 
         rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
diff --git a/Main.hs b/Main.hs
index 33324f2..ba516d4 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -144,11 +144,7 @@ findTemplate usage mb_libdir config
        -- Paths_hsc2hs isn't too useful for a
        -- relocatable binary, though.
          let
        -- Paths_hsc2hs isn't too useful for a
        -- relocatable binary, though.
          let
-#if defined(NEW_GHC_LAYOUT)
              templ1 = path ++ "/template-hsc.h"
              templ1 = path ++ "/template-hsc.h"
-#else
-             templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h"
-#endif
              incl = path ++ "/include/"
          exists1 <- doesFileExist templ1
          if exists1
              incl = path ++ "/include/"
          exists1 <- doesFileExist templ1
          if exists1
@@ -202,11 +198,7 @@ parseFile name
            die (name'++":"++show line++": "++msg++"\n")
 
 getLibDir :: IO (Maybe String)
            die (name'++":"++show line++": "++msg++"\n")
 
 getLibDir :: IO (Maybe String)
-#if defined(NEW_GHC_LAYOUT)
 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
 getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
-#else
-getLibDir = getExecDir "/bin/hsc2hs.exe"
-#endif
 
 -- (getExecDir cmd) returns the directory in which the current
 --                  executable, which should be called 'cmd', is running
 
 -- (getExecDir cmd) returns the directory in which the current
 --                  executable, which should be called 'cmd', is running
diff --git a/UtilsCodegen.hs b/UtilsCodegen.hs
new file mode 100644 (file)
index 0000000..7673dce
--- /dev/null
@@ -0,0 +1,85 @@
+{-# LANGUAGE CPP #-}
+module UtilsCodegen where
+
+{-
+Generate the utility code for hsc2hs.
+
+We don't want to include C headers in template-hsc.h
+See GHC trac #2897
+-}
+
+import Control.Monad
+
+import C
+import Common
+import Flags
+
+withUtilsObject :: Config -> FilePath -> FilePath
+                -> (FilePath -> IO a)
+                -> IO a
+withUtilsObject config outDir outBase f = do
+
+    let beVerbose = cVerbose config
+        flags     = cFlags config
+        possiblyRemove = if cKeepFiles config
+                         then flip const
+                         else finallyRemove
+        cUtilsName = outDir ++ outBase ++ "_hsc_utils.c"
+        oUtilsName = outDir ++ outBase ++ "_hsc_utils.o"
+
+    possiblyRemove cUtilsName $ do
+        writeBinaryFile cUtilsName $ unlines $
+            ["#include <stddef.h>",
+             "#include <string.h>",
+             "#include <stdio.h>",
+             "#include <stdarg.h>",
+             "#include <ctype.h>",
+             "",
+             outTemplateHeaderCProg (cTemplate config),
+             "",
+             "int hsc_printf(const char *format, ...) {",
+             "    int r;",
+             "    va_list argp;",
+             "    va_start(argp, format);",
+             "    r = vprintf(format, argp);",
+             "    va_end(argp);",
+             "    return r;",
+             "}",
+             "",
+             "int hsc_toupper(int c) {",
+             "    return toupper(c);",
+             "}",
+             "",
+             "int hsc_tolower(int c) {",
+             "    return tolower(c);",
+             "}",
+             "",
+             "int hsc_putchar(int c) {",
+             "    return putchar(c);",
+             "}",
+             "",
+             -- "void" should really be "FILE", but we aren't able to
+             -- refer to "FILE" in template-hsc.h as we don't want to
+             -- include <stdio.h> there
+             "int hsc_fputs(const char *s, void *stream) {",
+             "    return fputs(s, stream);",
+             "}",
+             "",
+             -- "void" should really be "FILE", but we aren't able to
+             -- refer to "FILE" in template-hsc.h as we don't want to
+             -- include <stdio.h> there
+             "void *hsc_stdout(void) {",
+             "    return stdout;",
+             "}"
+            ]
+
+        possiblyRemove oUtilsName $ do
+           unless (cNoCompile config) $
+               rawSystemL ("compiling " ++ cUtilsName)
+                          beVerbose
+                          (cCompiler config)
+                          (["-c", cUtilsName, "-o", oUtilsName] ++
+                           [cFlag | CompFlag cFlag <- flags])
+
+           f oUtilsName
+
index 71ede66..c2747ef 100644 (file)
@@ -23,28 +23,21 @@ Data-Files: template-hsc.h
 build-type: Simple
 cabal-version: >=1.2
 
 build-type: Simple
 cabal-version: >=1.2
 
-Flag base4
-    Description: Choose the even newer, even smaller, split-up base package.
-
-Flag base3
-    Description: Choose the new smaller, split-up base package.
-
 Executable hsc2hs
     Main-Is: Main.hs
 Executable hsc2hs
     Main-Is: Main.hs
-    Other-Modules: HSCParser, DirectCodegen, CrossCodegen, Common, C, Flags
+    Other-Modules: HSCParser,
+                   DirectCodegen,
+                   CrossCodegen,
+                   UtilsCodegen,
+                   Common,
+                   C,
+                   Flags
     -- needed for ReadP (used by Data.Version)
     Hugs-Options: -98
     Extensions: CPP, ForeignFunctionInterface
 
     -- needed for ReadP (used by Data.Version)
     Hugs-Options: -98
     Extensions: CPP, ForeignFunctionInterface
 
-    if flag(base4)
-        Build-Depends: base       >= 4   && < 5
-    if flag(base3)
-        Build-Depends: base       >= 3   && < 4
-    if !flag(base3) && !flag(base4)
-        Build-Depends: base       < 3
-
-    if flag(base3) || flag(base4)
-        Build-Depends: directory  >= 1   && < 1.2,
-                       process    >= 1   && < 1.2
-    Build-Depends: containers >= 0.2 && < 0.5
+    Build-Depends: base       >= 4   && < 5,
+                   containers >= 0.2 && < 0.5,
+                   directory  >= 1   && < 1.2,
+                   process    >= 1   && < 1.2
 
 
index 4712c1f..6f47168 100644 (file)
@@ -1,9 +1,19 @@
 
 
+/* We need stddef to be able to use size_t. Hopefully this won't cause
+   any problems along the lines of ghc trac #2897. */
 #include <stddef.h>
 #include <stddef.h>
-#include <string.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <ctype.h>
+
+/* hsc_* are defined in the generated utils.c */
+int hsc_printf(const char *format, ...);
+int hsc_toupper(int c);
+int hsc_tolower(int c);
+int hsc_putchar(int c);
+/* "void" should really be "FILE", but we aren't able to refer to "FILE"
+   as we don't want to include <stdio.h> here */
+int hsc_fputs(const char *s, void *stream);
+/* "void" should really be "FILE", but we aren't able to refer to "FILE"
+   as we don't want to include <stdio.h> here */
+void *hsc_stdout(void);
 
 /* For the single-argument macros we make the macros variadic (the
    argument is x... rather than simply x) so that arguments containing
 
 /* For the single-argument macros we make the macros variadic (the
    argument is x... rather than simply x) so that arguments containing
 
 #if __NHC__
 #define hsc_line(line, file) \
 
 #if __NHC__
 #define hsc_line(line, file) \
-    printf ("# %d \"%s\"\n", line, file);
+    hsc_printf ("# %d \"%s\"\n", line, file);
 #else
 #define hsc_line(line, file) \
 #else
 #define hsc_line(line, file) \
-    printf ("{-# LINE %d \"%s\" #-}\n", line, file);
+    hsc_printf ("{-# LINE %d \"%s\" #-}\n", line, file);
 #endif
 
 #define hsc_const(x...)                     \
     if ((x) < 0)                            \
 #endif
 
 #define hsc_const(x...)                     \
     if ((x) < 0)                            \
-        printf ("%ld", (long)(x));          \
+        hsc_printf ("%ld", (long)(x));      \
     else                                    \
     else                                    \
-        printf ("%lu", (unsigned long)(x));
+        hsc_printf ("%lu", (unsigned long)(x));
 
 #define hsc_const_str(x...)                                       \
     {                                                             \
         const char *s = (x);                                      \
 
 #define hsc_const_str(x...)                                       \
     {                                                             \
         const char *s = (x);                                      \
-        printf ("\"");                                            \
+        hsc_printf ("\"");                                        \
         while (*s != '\0')                                        \
         {                                                         \
             if (*s == '"' || *s == '\\')                          \
         while (*s != '\0')                                        \
         {                                                         \
             if (*s == '"' || *s == '\\')                          \
-                printf ("\\%c", *s);                              \
+                hsc_printf ("\\%c", *s);                          \
             else if (*s >= 0x20 && *s <= 0x7E)                    \
             else if (*s >= 0x20 && *s <= 0x7E)                    \
-                printf ("%c", *s);                                \
+                hsc_printf ("%c", *s);                            \
             else                                                  \
             else                                                  \
-                printf ("\\%d%s",                                 \
+                hsc_printf ("\\%d%s",                             \
                         (unsigned char) *s,                       \
                         s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \
             ++s;                                                  \
         }                                                         \
                         (unsigned char) *s,                       \
                         s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \
             ++s;                                                  \
         }                                                         \
-        printf ("\"");                                            \
+        hsc_printf ("\"");                                        \
     }
 
 #define hsc_type(t...)                                      \
     if ((t)(int)(t)1.4 == (t)1.4)                           \
     }
 
 #define hsc_type(t...)                                      \
     if ((t)(int)(t)1.4 == (t)1.4)                           \
-        printf ("%s%lu",                                    \
+        hsc_printf ("%s%lu",                                \
                 (t)(-1) < (t)0 ? "Int" : "Word",            \
                 (unsigned long)sizeof (t) * 8);             \
     else                                                    \
                 (t)(-1) < (t)0 ? "Int" : "Word",            \
                 (unsigned long)sizeof (t) * 8);             \
     else                                                    \
-        printf ("%s",                                       \
+        hsc_printf ("%s",                                   \
                 sizeof (t) >  sizeof (double) ? "LDouble" : \
                 sizeof (t) == sizeof (double) ? "Double"  : \
                 "Float");
 
 #define hsc_peek(t, f) \
                 sizeof (t) >  sizeof (double) ? "LDouble" : \
                 sizeof (t) == sizeof (double) ? "Double"  : \
                 "Float");
 
 #define hsc_peek(t, f) \
-    printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", (long) offsetof (t, f));
+    hsc_printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", \
+                (long) offsetof (t, f));
 
 #define hsc_poke(t, f) \
 
 #define hsc_poke(t, f) \
-    printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", (long) offsetof (t, f));
+    hsc_printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", \
+                (long) offsetof (t, f));
 
 #define hsc_ptr(t, f) \
 
 #define hsc_ptr(t, f) \
-    printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", (long) offsetof (t, f));
+    hsc_printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", \
+                (long) offsetof (t, f));
 
 #define hsc_offset(t, f) \
 
 #define hsc_offset(t, f) \
-    printf("(%ld)", (long) offsetof (t, f));
+    hsc_printf("(%ld)", (long) offsetof (t, f));
 
 #define hsc_size(t...) \
 
 #define hsc_size(t...) \
-    printf("(%ld)", (long) sizeof(t));
+    hsc_printf("(%ld)", (long) sizeof(t));
 
 #define hsc_enum(t, f, print_name, x)         \
     print_name;                               \
 
 #define hsc_enum(t, f, print_name, x)         \
     print_name;                               \
-    printf (" :: %s\n", #t);                  \
+    hsc_printf (" :: %s\n", #t);                  \
     print_name;                               \
     print_name;                               \
-    printf (" = %s ", #f);                    \
+    hsc_printf (" = %s ", #f);                    \
     if ((x) < 0)                              \
     if ((x) < 0)                              \
-        printf ("(%ld)\n", (long)(x));        \
+        hsc_printf ("(%ld)\n", (long)(x));        \
     else                                      \
     else                                      \
-        printf ("%lu\n", (unsigned long)(x));
+        hsc_printf ("%lu\n", (unsigned long)(x));
 
 #define hsc_haskellize(x...)                                       \
     {                                                              \
 
 #define hsc_haskellize(x...)                                       \
     {                                                              \
         int upper = 0;                                             \
         if (*s != '\0')                                            \
         {                                                          \
         int upper = 0;                                             \
         if (*s != '\0')                                            \
         {                                                          \
-            putchar (tolower (*s));                                \
+            hsc_putchar (hsc_tolower (*s));                        \
             ++s;                                                   \
             while (*s != '\0')                                     \
             {                                                      \
             ++s;                                                   \
             while (*s != '\0')                                     \
             {                                                      \
                     upper = 1;                                     \
                 else                                               \
                 {                                                  \
                     upper = 1;                                     \
                 else                                               \
                 {                                                  \
-                    putchar (upper ? toupper (*s) : tolower (*s)); \
+                    hsc_putchar (upper ? hsc_toupper (*s)          \
+                                       : hsc_tolower (*s));        \
                     upper = 0;                                     \
                 }                                                  \
                 ++s;                                               \
                     upper = 0;                                     \
                 }                                                  \
                 ++s;                                               \