Hi Ian,
I updated my hsc2hs patch as you suggested -- running
hsc2hs --cross-safe
will check for only the subset of hsc2hs which is
supported by the cross-compilation mode. I also
updated to the newest GHC head. The new patches
are attached, please take a look.
patch.hsc2hs_cross
Patch for ghc/utils/hsc2hs; the main functionality,
adding hsc2hs --cross-compile and hsc2hs --cross-safe.
patch.ghc-mk
Patch for ghc/, passes --cross-safe to hsc2hs in config.mk.in.
patch.base
Patch for libraries/base, updates System/Event/Poll.hsc to
compile correctly under cross-compilation. This is an
unfortunate discrepancy between hsc2hs and hsc2hs --cross-compile:
the original Poll.hsc had the following:
#{enum Event, Event
, pollIn = POLLIN
, pollOut = POLLOUT
#ifdef POLLRDHUP
, pollRdHup = POLLRDHUP
#endif
, pollErr = POLLERR
, pollHup = POLLHUP
}
Placing #ifdefs within an #{enum} *works* in hsc2hs, however
it's only by fragile accident (hsc2hs does not actively try
to handle the #ifdefs, they just get pasted at opportune
places in the .c file). Say, if you move the #ifdef up to
the first element (pollIn), it fails to compile. Rather
than mimic this behavior in hsc2hs --cross-compile, I just
patched Poll.hsc to not do this.
libraries/unix patch.unix
System/Posix/Files.hsc depends on a peculiarity of hsc2hs
-- it checks for an #define (HAVE_LCHOWN) which gets defined
in a header file which is #include'd below the check! This
happens to work for hsc2hs because of the way it does codegen,
but the cross-compile mode doesn't show the same behavior (IMHO,
the cross-compile's behavior is the one that people expect).
So rearrange the lines in Files.hsc so HsUnix.h is included
before HAVE_LCHOWN is checked.
diff -rN -Naup old-hsc2hs/hsc2hs.cabal new-hsc2hs/hsc2hs.cabal
--- old-hsc2hs/hsc2hs.cabal 2010-12-22 22:35:34.236121001 -0800
+++ new-hsc2hs/hsc2hs.cabal 2010-12-22 22:35:34.236121001 -0800
@@ -31,6 +31,7 @@ Flag base3
Executable hsc2hs
Main-Is: Main.hs
+ Other-Modules: HSCParser, CrossCodegen, DirectCodegen
-- needed for ReadP (used by Data.Version)
Hugs-Options: -98
Extensions: CPP, ForeignFunctionInterface
@@ -45,4 +46,4 @@ Executable hsc2hs
if flag(base3) || flag(base4)
Build-Depends: directory >= 1 && < 1.2,
process >= 1 && < 1.1
-
+ Build-Depends: containers >= 0.2 && < 0.5
diff -rN -Naup old-hsc2hs/Main.hs new-hsc2hs/Main.hs
--- old-hsc2hs/Main.hs 2010-12-22 22:35:34.226121001 -0800
+++ new-hsc2hs/Main.hs 2010-12-22 22:35:34.236121001 -0800
@@ -10,36 +10,28 @@
--
-- See the documentation in the Users' Guide for more details.
+-- Needed for mingw32_HOST_OS, NEW_GHC_LAYOUT
#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
#include "../../includes/ghcconfig.h"
#endif
-import Control.Exception ( bracket_ )
-import qualified Control.Exception as Exception
-import Control.Monad ( MonadPlus(..), liftM, liftM2, when )
-import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit,
- toUpper, intToDigit, ord )
-import Data.List ( intersperse, isSuffixOf )
+import Data.List ( isSuffixOf )
import System.Console.GetOpt
#if defined(mingw32_HOST_OS)
import Foreign
import Foreign.C.String
#endif
-import System.Directory ( removeFile, doesFileExist, findExecutable )
import System.Environment ( getProgName, getArgs )
import System.Exit ( ExitCode(..), exitWith )
import System.IO
-#if __GLASGOW_HASKELL__ >= 604
-import System.Process ( runProcess, waitForProcess )
-#define HAVE_runProcess
-#endif
+import System.Directory ( doesFileExist, findExecutable )
-import System.Cmd ( rawSystem )
-#ifndef HAVE_runProcess
-import System.Cmd ( system )
-#endif
+import Control.Monad ( liftM, forM_ )
+import HSCParser ( runParser, parser, ParseResult(..),
SourcePos(..), Token(..) )
+import DirectCodegen ( Flag(..), die, outputDirect, dosifyPath,
splitName, splitExt, unDosifyPath )
+import CrossCodegen ( outputCross )
#ifndef BUILD_NHC
import Paths_hsc2hs as Main ( getDataFileName, version )
@@ -58,20 +50,6 @@ default_compiler = "gcc"
versionString :: String
versionString = "hsc2hs version " ++ showVersion version ++ "\n"
-data Flag
- = Help
- | Version
- | Template String
- | Compiler String
- | Linker String
- | CompFlag String
- | LinkFlag String
- | NoCompile
- | Include String
- | Define String (Maybe String)
- | Output String
- | Verbose
-
template_flag :: Flag -> Bool
template_flag (Template _) = True
template_flag _ = False
@@ -108,6 +86,12 @@ options = [
"as if placed in the source",
Option [] ["no-compile"] (NoArg NoCompile)
"stop after writing *_hsc_make.c",
+ Option ['x'] ["cross-compile"] (NoArg CrossCompile)
+ "activate cross-compilation mode",
+ Option [] ["cross-safe"] (NoArg CrossSafe)
+ "restrict .hsc directives to those supported by --cross-compile",
+ Option ['k'] ["keep-files"] (NoArg KeepFiles)
+ "do not remove temporary files",
Option ['v'] ["verbose"] (NoArg Verbose)
"dump commands to stderr",
Option ['?'] ["help"] (NoArg Help)
@@ -119,24 +103,49 @@ main :: IO ()
main = do
prog <- getProgramName
let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
+ usage = usageInfo header options
args <- getArgs
let (flags, files, errs) = getOpt Permute options args
+ case (files, errs) of
+ (_, _)
+ | any isHelp flags -> bye usage
+ | any isVersion flags -> bye versionString
+ where
+ isHelp Help = True; isHelp _ = False
+ isVersion Version = True; isVersion _ = False
+ ((_:_), []) -> processFiles flags files usage
+ (_, _ ) -> die (concat errs ++ usage)
+
+getProgramName :: IO String
+getProgramName = liftM (`withoutSuffix` "-bin") getProgName
+ where str `withoutSuffix` suff
+ | suff `isSuffixOf` str = take (length str - length suff) str
+ | otherwise = str
- -- If there is no Template flag explicitly specified, try
- -- to find one. We first look near the executable. This only
- -- works on Win32 or Hugs (getExecDir). If this finds a template
- -- file then it's certainly the one we want, even if hsc2hs isn't
- -- installed where we told Cabal it would be installed.
- --
- -- Next we try the location we told Cabal about.
- --
- -- If neither of the above work, then hopefully we're on Unix and
- -- there's a wrapper script which specifies an explicit template flag.
+bye :: String -> IO a
+bye s = putStr s >> exitWith ExitSuccess
+
+processFiles :: [Flag] -> [FilePath] -> String -> IO ()
+processFiles flags files usage = do
mb_libdir <- getLibDir
- flags_w_tpl0 <-
- if any template_flag flags then return flags
- else do mb_templ1 <-
+ -- If there's no template specified on the commandline, try to locate it
+ flags_w_tpl <- case filter template_flag flags of
+ [_] -> return flags
+ (_:_) -> -- take only the last --template flag on the cmd line
+ let (before,tpl:after) = break template_flag (reverse flags)
+ in return $ reverse (before ++ tpl : filter
(not.template_flag) after)
+ [] -> do -- If there is no Template flag explicitly specified, try
+ -- to find one. We first look near the executable. This only
+ -- works on Win32 or Hugs (getExecDir). If this finds a
template
+ -- file then it's certainly the one we want, even if hsc2hs
isn't
+ -- installed where we told Cabal it would be installed.
+ --
+ -- Next we try the location we told Cabal about.
+ --
+ -- If neither of the above work, then hopefully we're on Unix
and
+ -- there's a wrapper script which specifies an explicit
template flag.
+ mb_templ1 <-
case mb_libdir of
Nothing -> return Nothing
Just path -> do
@@ -155,429 +164,15 @@ main = do
then return $ Just (Template templ1,
CompFlag ("-I" ++ incl))
else return Nothing
- case mb_templ1 of
- Just (templ1, incl) -> return (templ1 : flags ++ [incl])
- Nothing -> do
- templ2 <- getDataFileName "template-hsc.h"
- exists2 <- doesFileExist templ2
- if exists2 then return (Template templ2 : flags)
- else return flags
-
- -- take only the last --template flag on the cmd line
- let
- (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
- flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
-
- case (files, errs) of
- (_, _)
- | any isHelp flags_w_tpl -> bye (usageInfo header options)
- | any isVersion flags_w_tpl -> bye versionString
- where
- isHelp Help = True; isHelp _ = False
- isVersion Version = True; isVersion _ = False
- ((_:_), []) -> mapM_ (processFile flags_w_tpl mb_libdir) files
- (_, _ ) -> die (concat errs ++ usageInfo header options)
-
-getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` "-bin") getProgName
- where str `withoutSuffix` suff
- | suff `isSuffixOf` str = take (length str - length suff) str
- | otherwise = str
-
-bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
-
-die :: String -> IO a
-die s = hPutStr stderr s >> exitWith (ExitFailure 1)
-
-processFile :: [Flag] -> Maybe String -> String -> IO ()
-processFile flags mb_libdir name
- = do let file_name = dosifyPath name
- h <- openBinaryFile file_name ReadMode
- -- use binary mode so we pass through UTF-8, see GHC ticket #3837
- -- But then on Windows we end up turning things like
- -- #let alignment t = e^M
- -- into
- -- #define hsc_alignment(t ) printf ( e^M);
- -- which gcc doesn't like, so strip out any ^M characters.
- s <- hGetContents h
- let s' = filter ('\r' /=) s
- case parser of
- Parser p -> case p (SourcePos file_name 1) s' of
- Success _ _ _ toks -> output mb_libdir flags file_name toks
- Failure (SourcePos name' line) msg ->
- die (name'++":"++show line++": "++msg++"\n")
-
-------------------------------------------------------------------------
--- A deterministic parser which remembers the text which has been parsed.
-
-newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
-
-data ParseResult a = Success !SourcePos String String a
- | Failure !SourcePos String
-
-data SourcePos = SourcePos String !Int
-
-updatePos :: SourcePos -> Char -> SourcePos
-updatePos pos@(SourcePos name line) ch = case ch of
- '\n' -> SourcePos name (line + 1)
- _ -> pos
-
-instance Monad Parser where
- return a = Parser $ \pos s -> Success pos [] s a
- Parser m >>= k =
- Parser $ \pos s -> case m pos s of
- Success pos' out1 s' a -> case k a of
- Parser k' -> case k' pos' s' of
- Success pos'' out2 imp'' b ->
- Success pos'' (out1++out2) imp'' b
- Failure pos'' msg -> Failure pos'' msg
- Failure pos' msg -> Failure pos' msg
- fail msg = Parser $ \pos _ -> Failure pos msg
-
-instance MonadPlus Parser where
- mzero = fail "mzero"
- Parser m `mplus` Parser n =
- Parser $ \pos s -> case m pos s of
- success@(Success _ _ _ _) -> success
- Failure _ _ -> n pos s
-
-getPos :: Parser SourcePos
-getPos = Parser $ \pos s -> Success pos [] s pos
-
-setPos :: SourcePos -> Parser ()
-setPos pos = Parser $ \_ s -> Success pos [] s ()
-
-message :: Parser a -> String -> Parser a
-Parser m `message` msg =
- Parser $ \pos s -> case m pos s of
- success@(Success _ _ _ _) -> success
- Failure pos' _ -> Failure pos' msg
-
-catchOutput_ :: Parser a -> Parser String
-catchOutput_ (Parser m) =
- Parser $ \pos s -> case m pos s of
- Success pos' out s' _ -> Success pos' [] s' out
- Failure pos' msg -> Failure pos' msg
-
-fakeOutput :: Parser a -> String -> Parser a
-Parser m `fakeOutput` out =
- Parser $ \pos s -> case m pos s of
- Success pos' _ s' a -> Success pos' out s' a
- Failure pos' msg -> Failure pos' msg
-
-lookAhead :: Parser String
-lookAhead = Parser $ \pos s -> Success pos [] s s
-
-satisfy :: (Char -> Bool) -> Parser Char
-satisfy p =
- Parser $ \pos s -> case s of
- c:cs | p c -> Success (updatePos pos c) [c] cs c
- _ -> Failure pos "Bad character"
-
-satisfy_ :: (Char -> Bool) -> Parser ()
-satisfy_ p = satisfy p >> return ()
-
-char_ :: Char -> Parser ()
-char_ c = do
- satisfy_ (== c) `message` (show c++" expected")
-
-anyChar_ :: Parser ()
-anyChar_ = do
- satisfy_ (const True) `message` "Unexpected end of file"
-
-any2Chars_ :: Parser ()
-any2Chars_ = anyChar_ >> anyChar_
-
-many :: Parser a -> Parser [a]
-many p = many1 p `mplus` return []
-
-many1 :: Parser a -> Parser [a]
-many1 p = liftM2 (:) p (many p)
-
-many_ :: Parser a -> Parser ()
-many_ p = many1_ p `mplus` return ()
-
-many1_ :: Parser a -> Parser ()
-many1_ p = p >> many_ p
-
-manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
-manySatisfy = many . satisfy
-manySatisfy1 = many1 . satisfy
-
-manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
-manySatisfy_ = many_ . satisfy
-manySatisfy1_ = many1_ . satisfy
-
-------------------------------------------------------------------------
--- Parser of hsc syntax.
-
-data Token
- = Text SourcePos String
- | Special SourcePos String String
-
-parser :: Parser [Token]
-parser = do
- pos <- getPos
- t <- catchOutput_ text
- s <- lookAhead
- rest <- case s of
- [] -> return []
- _:_ -> liftM2 (:) (special `fakeOutput` []) parser
- return (if null t then rest else Text pos t : rest)
-
-text :: Parser ()
-text = do
- s <- lookAhead
- case s of
- [] -> return ()
- c:_ | isAlpha c || c == '_' -> do
- anyChar_
- manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
- text
- c:_ | isHsSymbol c -> do
- symb <- catchOutput_ (manySatisfy_ isHsSymbol)
- case symb of
- "#" -> return ()
- '-':'-':symb' | all (== '-') symb' -> do
- return () `fakeOutput` symb
- manySatisfy_ (/= '\n')
- text
- _ -> do
- return () `fakeOutput` unescapeHashes symb
- text
- '\"':_ -> do anyChar_; hsString '\"'; text
- '\'':_ -> do anyChar_; hsString '\''; text
- '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
- _:_ -> do anyChar_; text
-
-hsString :: Char -> Parser ()
-hsString quote = do
- s <- lookAhead
- case s of
- [] -> return ()
- c:_ | c == quote -> anyChar_
- '\\':c:_
- | isSpace c -> do
- anyChar_
- manySatisfy_ isSpace
- char_ '\\' `mplus` return ()
- hsString quote
- | otherwise -> do any2Chars_; hsString quote
- _:_ -> do anyChar_; hsString quote
-
-hsComment :: Parser ()
-hsComment = do
- s <- lookAhead
- case s of
- [] -> return ()
- '-':'}':_ -> any2Chars_
- '{':'-':_ -> do any2Chars_; hsComment; hsComment
- _:_ -> do anyChar_; hsComment
-
-linePragma :: Parser ()
-linePragma = do
- char_ '#'
- manySatisfy_ isSpace
- satisfy_ (\c -> c == 'L' || c == 'l')
- satisfy_ (\c -> c == 'I' || c == 'i')
- satisfy_ (\c -> c == 'N' || c == 'n')
- satisfy_ (\c -> c == 'E' || c == 'e')
- manySatisfy1_ isSpace
- line <- liftM read $ manySatisfy1 isDigit
- manySatisfy1_ isSpace
- char_ '\"'
- name <- manySatisfy (/= '\"')
- char_ '\"'
- manySatisfy_ isSpace
- char_ '#'
- char_ '-'
- char_ '}'
- setPos (SourcePos name (line - 1))
-
-isHsSymbol :: Char -> Bool
-isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
-isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
-isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
-isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
-isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
-isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
-isHsSymbol '~' = True
-isHsSymbol _ = False
-
-unescapeHashes :: String -> String
-unescapeHashes [] = []
-unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
-unescapeHashes (c:s) = c : unescapeHashes s
-
-lookAheadC :: Parser String
-lookAheadC = liftM joinLines lookAhead
- where
- joinLines [] = []
- joinLines ('\\':'\n':s) = joinLines s
- joinLines (c:s) = c : joinLines s
-
-satisfyC :: (Char -> Bool) -> Parser Char
-satisfyC p = do
- s <- lookAhead
- case s of
- '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
- _ -> satisfy p
-
-satisfyC_ :: (Char -> Bool) -> Parser ()
-satisfyC_ p = satisfyC p >> return ()
-
-charC_ :: Char -> Parser ()
-charC_ c = satisfyC_ (== c) `message` (show c++" expected")
-
-anyCharC_ :: Parser ()
-anyCharC_ = satisfyC_ (const True) `message` "Unexpected end of file"
-
-any2CharsC_ :: Parser ()
-any2CharsC_ = anyCharC_ >> anyCharC_
-
-manySatisfyC :: (Char -> Bool) -> Parser String
-manySatisfyC = many . satisfyC
-
-manySatisfyC_ :: (Char -> Bool) -> Parser ()
-manySatisfyC_ = many_ . satisfyC
-
-special :: Parser Token
-special = do
- manySatisfyC_ (\c -> isSpace c && c /= '\n')
- s <- lookAheadC
- case s of
- '{':_ -> do
- anyCharC_
- manySatisfyC_ isSpace
- sp <- keyArg (== '\n')
- charC_ '}'
- return sp
- _ -> keyArg (const False)
-
-keyArg :: (Char -> Bool) -> Parser Token
-keyArg eol = do
- pos <- getPos
- key <- keyword `message` "hsc keyword or '{' expected"
- manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
- arg <- catchOutput_ (argument eol)
- return (Special pos key arg)
-
-keyword :: Parser String
-keyword = do
- c <- satisfyC (\c' -> isAlpha c' || c' == '_')
- cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
- return (c:cs)
-
-argument :: (Char -> Bool) -> Parser ()
-argument eol = do
- s <- lookAheadC
- case s of
- [] -> return ()
- c:_ | eol c -> do anyCharC_; argument eol
- '\n':_ -> return ()
- '\"':_ -> do anyCharC_; cString '\"'; argument eol
- '\'':_ -> do anyCharC_; cString '\''; argument eol
- '(':_ -> do anyCharC_; nested ')'; argument eol
- ')':_ -> return ()
- '/':'*':_ -> do any2CharsC_; cComment; argument eol
- '/':'/':_ -> do
- any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
- '[':_ -> do anyCharC_; nested ']'; argument eol
- ']':_ -> return ()
- '{':_ -> do anyCharC_; nested '}'; argument eol
- '}':_ -> return ()
- _:_ -> do anyCharC_; argument eol
-
-nested :: Char -> Parser ()
-nested c = do argument (== '\n'); charC_ c
-
-cComment :: Parser ()
-cComment = do
- s <- lookAheadC
- case s of
- [] -> return ()
- '*':'/':_ -> do any2CharsC_
- _:_ -> do anyCharC_; cComment
-
-cString :: Char -> Parser ()
-cString quote = do
- s <- lookAheadC
- case s of
- [] -> return ()
- c:_ | c == quote -> anyCharC_
- '\\':_:_ -> do any2CharsC_; cString quote
- _:_ -> do anyCharC_; cString quote
-
-------------------------------------------------------------------------
--- Write the output files.
-
-splitName :: String -> (String, String)
-splitName name =
- case break (== '/') name of
- (file, []) -> ([], file)
- (dir, sep:rest) -> (dir++sep:restDir, restFile)
- where
- (restDir, restFile) = splitName rest
-
-splitExt :: String -> (String, String)
-splitExt name =
- case break (== '.') name of
- (base, []) -> (base, [])
- (base, sepRest@(sep:rest))
- | null restExt -> (base, sepRest)
- | otherwise -> (base++sep:restBase, restExt)
- where
- (restBase, restExt) = splitExt rest
-
-output :: Maybe String -> [Flag] -> String -> [Token] -> IO ()
-output mb_libdir flags name toks = do
-
- (outName, outDir, outBase) <- case [f | Output f <- flags] of
- [] -> if not (null ext) && last ext == 'c'
- then return (dir++base++init ext, dir, base)
- else
- if ext == ".hs"
- then return (dir++base++"_out.hs", dir, base)
- else return (dir++base++".hs", dir, base)
- where
- (dir, file) = splitName name
- (base, ext) = splitExt file
- [f] -> let
- (dir, file) = splitName f
- (base, _) = splitExt file
- in return (f, dir, base)
- _ -> onlyOne "output file"
-
- let cProgName = outDir++outBase++"_hsc_make.c"
- oProgName = outDir++outBase++"_hsc_make.o"
- progName = outDir++outBase++"_hsc_make"
-#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
--- This is a real hack, but the quoting mechanism used for calling the C
preprocesseor
--- via GHC has changed a few times, so this seems to be the only way... :-P *
* *
- ++ ".exe"
-#endif
- outHFile = outBase++"_hsc.h"
- outHName = outDir++outHFile
- outCName = outDir++outBase++"_hsc.c"
-
- beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False})
flags
-
- let execProgName
- | null outDir = dosifyPath ("./" ++ progName)
- | otherwise = progName
-
- let specials = [(pos, key, arg) | Special pos key arg <- toks]
-
- let needsC = any (\(_, key, _) -> key == "def") specials
- needsH = needsC
+ case mb_templ1 of
+ Just (templ1, incl) -> return (templ1 : flags ++ [incl])
+ Nothing -> do
+ templ2 <- getDataFileName "template-hsc.h"
+ exists2 <- doesFileExist templ2
+ if exists2 then return (Template templ2 : flags)
+ else die ("No template specified, and
template-hsc.h not located.\n\n" ++ usage)
- let includeGuard = map fixChar outHName
- where
- fixChar c | isAlphaNum c = toUpper c
- | otherwise = '_'
-
- compiler <- case [c | Compiler c <- flags] of
+ compiler <- case [c | Compiler c <- flags_w_tpl] of
[] -> do
-- if this hsc2hs is part of a GHC installation on
-- Windows, then we should use the mingw gcc that
@@ -596,333 +191,56 @@ output mb_libdir flags name toks = do
Just path -> return path
cs -> return (last cs)
- linker <- case [l | Linker l <- flags] of
- [] -> return compiler
- ls -> return (last ls)
-
- writeBinaryFile cProgName $
- concatMap outFlagHeaderCProg flags++
- concatMap outHeaderCProg specials++
- "\nint main (int argc, char *argv [])\n{\n"++
- outHeaderHs flags (if needsH then Just outHName else Nothing)
specials++
- outHsLine (SourcePos name 0)++
- concatMap outTokenHs toks++
- " return 0;\n}\n"
-
- -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
- -- so we use something slightly more complicated. :-P
- when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
- exitWith ExitSuccess
-
- rawSystemL ("compiling " ++ cProgName) beVerbose compiler
- ( ["-c"]
- ++ [cProgName]
- ++ ["-o", oProgName]
- ++ [f | CompFlag f <- flags]
- )
- finallyRemove cProgName $ do
-
- rawSystemL ("linking " ++ oProgName) beVerbose linker
- ( [oProgName]
- ++ ["-o", progName]
- ++ [f | LinkFlag f <- flags]
- )
- finallyRemove oProgName $ do
-
- rawSystemWithStdOutL ("running " ++ execProgName) beVerbose
execProgName [] outName
- finallyRemove progName $ do
-
- when needsH $ writeBinaryFile outHName $
- "#ifndef "++includeGuard++"\n" ++
- "#define "++includeGuard++"\n" ++
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
- "#include <Rts.h>\n" ++
- "#endif\n" ++
- "#include <HsFFI.h>\n" ++
- "#if __NHC__\n" ++
- "#undef HsChar\n" ++
- "#define HsChar int\n" ++
- "#endif\n" ++
- concatMap outFlagH flags++
- concatMap outTokenH specials++
- "#endif\n"
-
- when needsC $ writeBinaryFile outCName $
- "#include \""++outHFile++"\"\n"++
- concatMap outTokenC specials
- -- NB. outHFile not outHName; works better when processed
- -- by gcc or mkdependC.
-
-writeBinaryFile :: FilePath -> String -> IO ()
-writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
-
-rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
-rawSystemL action flg prog args = do
- let cmdLine = prog++" "++unwords args
- when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
- exitStatus <- rawSystem prog args
- case exitStatus of
- ExitFailure exitCode -> die $ action ++ " failed "
- ++ "(exit code " ++ show exitCode ++ ")\n"
- ++ "command was: " ++ cmdLine ++ "\n"
- _ -> return ()
-
-rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath ->
IO ()
-rawSystemWithStdOutL action flg prog args outFile = do
- let cmdLine = prog++" "++unwords args++" >"++outFile
- when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
-#ifndef HAVE_runProcess
- exitStatus <- system cmdLine
-#else
- hOut <- openFile outFile WriteMode
- process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
- exitStatus <- waitForProcess process
- hClose hOut
-#endif
- case exitStatus of
- ExitFailure exitCode -> die $ action ++ " failed "
- ++ "(exit code " ++ show exitCode ++ ")\n"
- ++ "command was: " ++ cmdLine ++ "\n"
- _ -> return ()
-
--- delay the cleanup of generated files until the end; attempts to
--- get around intermittent failure to delete files which has
--- just been exec'ed by a sub-process (Win32 only.)
-finallyRemove :: FilePath -> IO a -> IO a
-finallyRemove fp act =
- bracket_ (return fp)
- (noisyRemove fp)
- act
- where
- noisyRemove fpath =
- catchIO (removeFile fpath)
- (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ ";
error= " ++ show e))
+ let crossCompiling = not $ null [() | CrossCompile <- flags_w_tpl]
+ beVerbose = not $ null [() | Verbose <- flags_w_tpl]
+ keepFiles = not $ null [() | KeepFiles <- flags_w_tpl]
+
+ outputter <- if crossCompiling
+ then return (outputCross beVerbose keepFiles compiler flags_w_tpl)
+ else do linker <- case [l | Linker l <- flags_w_tpl] of
+ [] -> return compiler
+ ls -> return (last ls)
+ return (outputDirect beVerbose keepFiles compiler linker
flags_w_tpl)
+
+ forM_ files (\name -> do
+ (outName, outDir, outBase) <- case [f | Output f <- flags_w_tpl] of
+ [] -> if not (null ext) && last ext == 'c'
+ then return (dir++base++init ext, dir, base)
+ else
+ if ext == ".hs"
+ then return (dir++base++"_out.hs", dir, base)
+ else return (dir++base++".hs", dir, base)
+ where
+ (dir, file) = splitName name
+ (base, ext) = splitExt file
+ [f] -> let
+ (dir, file) = splitName f
+ (base, _) = splitExt file
+ in return (f, dir, base)
+ _ -> onlyOne "output file"
+ tokens <- parseFile name
+ outputter outName outDir outBase name tokens)
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-catchIO = Exception.catch
+parseFile :: String -> IO [Token]
+parseFile name
+ = do let file_name = dosifyPath name
+ h <- openBinaryFile file_name ReadMode
+ -- use binary mode so we pass through UTF-8, see GHC ticket #3837
+ -- But then on Windows we end up turning things like
+ -- #let alignment t = e^M
+ -- into
+ -- #define hsc_alignment(t ) printf ( e^M);
+ -- which gcc doesn't like, so strip out any ^M characters.
+ s <- hGetContents h
+ let s' = filter ('\r' /=) s
+ case runParser parser file_name s' of
+ Success _ _ _ toks -> return toks
+ Failure (SourcePos name' line) msg ->
+ die (name'++":"++show line++": "++msg++"\n")
onlyOne :: String -> IO a
onlyOne what = die ("Only one "++what++" may be specified\n")
-outFlagHeaderCProg :: Flag -> String
-outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
-outFlagHeaderCProg (Include f) = "#include "++f++"\n"
-outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
-outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
-outFlagHeaderCProg _ = ""
-
-outHeaderCProg :: (SourcePos, String, String) -> String
-outHeaderCProg (pos, key, arg) = case key of
- "include" -> outCLine pos++"#include "++arg++"\n"
- "define" -> outCLine pos++"#define "++arg++"\n"
- "undef" -> outCLine pos++"#undef "++arg++"\n"
- "def" -> case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
- _ -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- "let" -> case break (== '=') arg of
- (_, "") -> ""
- (header, _:body) -> case break isSpace header of
- (name, args) ->
- outCLine pos++
- "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
- "printf ("++joinLines body++");\n"
- _ -> ""
- where
- joinLines = concat . intersperse " \\\n" . lines
-
-outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] ->
String
-outHeaderHs flags inH toks =
- "#if " ++
- "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
- " printf (\"{-# OPTIONS -optc-D" ++
- "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
- "__GLASGOW_HASKELL__);\n" ++
- "#endif\n"++
- case inH of
- Nothing -> concatMap outFlag flags++concatMap outSpecial toks
- Just f -> outInclude ("\""++f++"\"")
- where
- outFlag (Include f) = outInclude f
- outFlag (Define n Nothing) = outOption ("-optc-D"++n)
- outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
- outFlag _ = ""
- outSpecial (pos, key, arg) = case key of
- "include" -> outInclude arg
- "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
- | otherwise -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
- goodForOptD arg = case arg of
- "" -> True
- c:_ | isSpace c -> True
- '(':_ -> False
- _:s -> goodForOptD s
- toOptD arg = case break isSpace arg of
- (name, "") -> name
- (name, _:value) -> name++'=':dropWhile isSpace value
- outOption s =
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
- " printf (\"{-# OPTIONS %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#else\n"++
- " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#endif\n"
- outInclude s =
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
- " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#elif __GLASGOW_HASKELL__ < 610\n"++
- " printf (\"{-# INCLUDE %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#endif\n"
-
-outTokenHs :: Token -> String
-outTokenHs (Text pos txt) =
- case break (== '\n') txt of
- (allTxt, []) -> outText allTxt
- (first, _:rest) ->
- outText (first++"\n")++
- outHsLine pos++
- outText rest
- where
- outText s = " fputs (\""++showCString s++"\", stdout);\n"
-outTokenHs (Special pos key arg) =
- case key of
- "include" -> ""
- "define" -> ""
- "undef" -> ""
- "def" -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- "let" -> ""
- "enum" -> outCLine pos++outEnum arg
- _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
-
-outEnum :: String -> String
-outEnum arg =
- case break (== ',') arg of
- (_, []) -> ""
- (t, _:afterT) -> case break (== ',') afterT of
- (f, afterF) -> let
- enums [] = ""
- enums (_:s) = case break (== ',') s of
- (enum, rest) -> let
- this = case break (== '=') $ dropWhile isSpace enum of
- (name, []) ->
- " hsc_enum ("++t++", "++f++", " ++
- "hsc_haskellize (\""++name++"\"), "++
- name++");\n"
- (hsName, _:cName) ->
- " hsc_enum ("++t++", "++f++", " ++
- "printf (\"%s\", \""++hsName++"\"), "++
- cName++");\n"
- in this++enums rest
- in enums afterF
-
-outFlagH :: Flag -> String
-outFlagH (Include f) = "#include "++f++"\n"
-outFlagH (Define n Nothing) = "#define "++n++" 1\n"
-outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
-outFlagH _ = ""
-
-outTokenH :: (SourcePos, String, String) -> String
-outTokenH (pos, key, arg) =
- case key of
- "include" -> outCLine pos++"#include "++arg++"\n"
- "define" -> outCLine pos++"#define " ++arg++"\n"
- "undef" -> outCLine pos++"#undef " ++arg++"\n"
- "def" -> outCLine pos++case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
- 'i':'n':'l':'i':'n':'e':' ':_ ->
- "#ifdef __GNUC__\n" ++
- "extern\n" ++
- "#endif\n"++
- arg++"\n"
- _ -> "extern "++header++";\n"
- where header = takeWhile (\c -> c /= '{' && c /= '=') arg
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
-
-outTokenC :: (SourcePos, String, String) -> String
-outTokenC (pos, key, arg) =
- case key of
- "def" -> case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> ""
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
- 'i':'n':'l':'i':'n':'e':' ':arg' ->
- case span (\c -> c /= '{' && c /= '=') arg' of
- (header, body) ->
- outCLine pos++
- "#ifndef __GNUC__\n" ++
- "extern inline\n" ++
- "#endif\n"++
- header++
- "\n#ifndef __GNUC__\n" ++
- ";\n" ++
- "#else\n"++
- body++
- "\n#endif\n"
- _ -> outCLine pos++arg++"\n"
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
-
-conditional :: String -> Bool
-conditional "if" = True
-conditional "ifdef" = True
-conditional "ifndef" = True
-conditional "elif" = True
-conditional "else" = True
-conditional "endif" = True
-conditional "error" = True
-conditional "warning" = True
-conditional _ = False
-
-outCLine :: SourcePos -> String
-outCLine (SourcePos name line) =
- "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
-
-outHsLine :: SourcePos -> String
-outHsLine (SourcePos name line) =
- " hsc_line ("++show (line + 1)++", \""++
- showCString name++"\");\n"
-
-showCString :: String -> String
-showCString = concatMap showCChar
- where
- showCChar '\"' = "\\\""
- showCChar '\'' = "\\\'"
- showCChar '?' = "\\?"
- showCChar '\\' = "\\\\"
- showCChar c | c >= ' ' && c <= '~' = [c]
- showCChar '\a' = "\\a"
- showCChar '\b' = "\\b"
- showCChar '\f' = "\\f"
- showCChar '\n' = "\\n\"\n \""
- showCChar '\r' = "\\r"
- showCChar '\t' = "\\t"
- showCChar '\v' = "\\v"
- showCChar c = ['\\',
- intToDigit (ord c `quot` 64),
- intToDigit (ord c `quot` 8 `mod` 8),
- intToDigit (ord c `mod` 8)]
-
------------------------------------------
--- Modified version from ghc/compiler/SysTools
--- Convert paths foo/baz to foo\baz on Windows
-
-subst :: Char -> Char -> String -> String
-#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
-subst a b = map (\x -> if x == a then b else x)
-#else
-subst _ _ = id
-#endif
-
-dosifyPath :: String -> String
-dosifyPath = subst '/' '\\'
-
getLibDir :: IO (Maybe String)
#if defined(NEW_GHC_LAYOUT)
getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe"
@@ -937,8 +255,7 @@ getLibDir = getExecDir "/bin/hsc2hs.exe"
getExecDir :: String -> IO (Maybe String)
getExecDir cmd =
getExecPath >>= maybe (return Nothing) removeCmdSuffix
- where unDosifyPath = subst '\\' '/'
- initN n = reverse . drop n . reverse
+ where initN n = reverse . drop n . reverse
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
diff -rN -Naup old-base/System/Event/Poll.hsc new-base/System/Event/Poll.hsc
--- old-base/System/Event/Poll.hsc 2010-12-22 22:35:34.486121001 -0800
+++ new-base/System/Event/Poll.hsc 2010-12-22 22:35:34.536121001 -0800
@@ -103,15 +103,22 @@ data PollFd = PollFd {
newtype Event = Event CShort
deriving (Eq, Show, Num, Storable, Bits)
-#{enum Event, Event
- , pollIn = POLLIN
- , pollOut = POLLOUT
+pollIn :: Event
+pollIn = Event #{const POLLIN}
+
+pollOut :: Event
+pollOut = Event #{const POLLOUT}
+
#ifdef POLLRDHUP
- , pollRdHup = POLLRDHUP
+pollRdHup :: Event
+pollRdHup = Event #{const POLLRDHUP}
#endif
- , pollErr = POLLERR
- , pollHup = POLLHUP
- }
+
+pollErr :: Event
+pollErr = Event #{const POLLERR}
+
+pollHup :: Event
+pollHup = Event #{const POLLHUP}
fromEvent :: E.Event -> Event
fromEvent e = remap E.evtRead pollIn .|.
diff -rN -Naup old-ghc/mk/config.mk.in new-ghc/mk/config.mk.in
--- old-ghc-crosshsc/mk/config.mk.in 2010-12-22 22:35:33.286121001 -0800
+++ new-ghc-crosshsc/mk/config.mk.in 2010-12-22 22:35:33.586121001 -0800
@@ -558,6 +558,7 @@ ifeq "$(TARGETPLATFORM)" "ia64-unknown-l
CONF_CC_OPTS += -G0
endif
+SRC_HSC2HS_OPTS += --cross-safe
SRC_HSC2HS_OPTS += $(addprefix --cflag=,$(filter-out -O,$(SRC_CC_OPTS)
$(CONF_CC_OPTS_STAGE0)))
SRC_HSC2HS_OPTS += $(foreach d,$(GMP_INCLUDE_DIRS),-I$(d))
diff -rN -Naup old-unix/System/Posix/Files.hsc new-unix/System/Posix/Files.hsc
--- old-unix/System/Posix/Files.hsc 2010-12-22 22:35:35.736121001 -0800
+++ new-unix/System/Posix/Files.hsc 2010-12-22 22:35:35.756121001 -0800
@@ -24,6 +24,8 @@
--
-----------------------------------------------------------------------------
+#include "HsUnix.h"
+
module System.Posix.Files (
-- * File modes
-- FileMode exported by System.Posix.Types
@@ -84,8 +86,6 @@ module System.Posix.Files (
PathVar(..), getPathVar, getFdPathVar,
) where
-#include "HsUnix.h"
-
import System.Posix.Error
import System.Posix.Types
import System.IO.Unsafe
_______________________________________________
Cvs-ghc mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/cvs-ghc
