diff --git a/HSFFIG.cabal b/HSFFIG.cabal --- a/HSFFIG.cabal +++ b/HSFFIG.cabal @@ -1,5 +1,5 @@ Name: HSFFIG -Version: 1.1.2 +Version: 1.1.3 License: BSD3 License-file: License.txt Copyright: 2005 - 2009, Dimitry Golubovsky @@ -44,18 +44,21 @@ Executable: ffipkg Main-is: ffipkg.hs Hs-source-dirs: programs +Ghc-options: -threaded Other-modules: C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds, WriteHsc, Template, HsfUtils, HGmain, SPmain, Makefile Setupfile SetupfileNew Executable: hsffig Main-is: hsffig.hs +Ghc-options: -threaded Hs-source-dirs: programs Other-modules: HGmain, C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds, WriteHsc, Template, HsfUtils Executable: testparser Main-is: testparser.hs +Ghc-options: -threaded Hs-source-dirs: programs Other-modules: C_Lexer, ProcHdr, TokenOps, C_BNF, SplitBounds diff --git a/dist/build/ffipkg/ffipkg-tmp/C_Lexer.hs b/dist/build/ffipkg/ffipkg-tmp/C_Lexer.hs --- a/dist/build/ffipkg/ffipkg-tmp/C_Lexer.hs +++ b/dist/build/ffipkg/ffipkg-tmp/C_Lexer.hs @@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-} +{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 47 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -433,12 +433,12 @@ let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset + !(base) = alexIndexInt32OffAddr alex_base s + !((I# (ord_c))) = ord c + !(offset) = (base +# ord_c) + !(check) = alexIndexInt16OffAddr alex_check offset - new_s = if (offset >=# 0#) && (check ==# ord_c) + !(new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in diff --git a/dist/build/hsffig/hsffig-tmp/C_Lexer.hs b/dist/build/hsffig/hsffig-tmp/C_Lexer.hs --- a/dist/build/hsffig/hsffig-tmp/C_Lexer.hs +++ b/dist/build/hsffig/hsffig-tmp/C_Lexer.hs @@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-} +{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 47 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -433,12 +433,12 @@ let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset + !(base) = alexIndexInt32OffAddr alex_base s + !((I# (ord_c))) = ord c + !(offset) = (base +# ord_c) + !(check) = alexIndexInt16OffAddr alex_check offset - new_s = if (offset >=# 0#) && (check ==# ord_c) + !(new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in diff --git a/dist/build/testparser/testparser-tmp/C_Lexer.hs b/dist/build/testparser/testparser-tmp/C_Lexer.hs --- a/dist/build/testparser/testparser-tmp/C_Lexer.hs +++ b/dist/build/testparser/testparser-tmp/C_Lexer.hs @@ -317,9 +317,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-} +{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 47 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -433,12 +433,12 @@ let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset + !(base) = alexIndexInt32OffAddr alex_base s + !((I# (ord_c))) = ord c + !(offset) = (base +# ord_c) + !(check) = alexIndexInt16OffAddr alex_check offset - new_s = if (offset >=# 0#) && (check ==# ord_c) + !(new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in diff --git a/programs/HsfUtils.hs b/programs/HsfUtils.hs --- a/programs/HsfUtils.hs +++ b/programs/HsfUtils.hs @@ -2,10 +2,72 @@ module HsfUtils where +import C_Lexer +import C_BNF + +import System.IO import System.Cmd import System.Exit import Data.Char +import Data.Maybe +import Data.Either +import System.Process +import Control.Concurrent +import Text.ParserCombinators.Parsec +import qualified Data.Map as Map +-- Guessed type of a constant (via #define). + +data GuessType = + NoGuess -- type cannot be guessed, not a valid constant + |Vague -- most likely a constant, but cannot guess type, run via gcc + |GuessInt -- guessed an integer constant + |GuessFloat -- guessed a floating point constant + deriving (Ord, Eq, Show) + +-- Utility: pipe processes together. Two StdStream's must be supplied: for pipeline's +-- stdin and stdout. Stderr's of all processes are as set in the process creation +-- descriptors. List of process handles is returned as well as handles for pipe ends. + +runPipe :: StdStream -- stdin + -> StdStream -- stdout + -> [CreateProcess] -- processes (start at left, end at right) + -> IO (Maybe Handle -- pipe in + ,Maybe Handle -- pipe out + ,[ProcessHandle]) -- same order as in the input list of descriptors + +runPipe ins outs [] = return (Nothing, Nothing, []) + +runPipe ins outs [p] = do + let p' = p {std_in = ins, std_out = outs} + (pin, pout, _, ph) <- createProcess p' + return (pin, pout, [ph]) + +runPipe ins outs (pstart:ps) = do + let pstart' = pstart {std_in = ins} + prev@(pend:rps) = reverse (pstart':ps) + pend' = pend {std_out = outs} + piper (pend':rps) [] Nothing Nothing + +piper :: [CreateProcess] + -> [ProcessHandle] + -> Maybe Handle + -> Maybe Handle + -> IO (Maybe Handle, Maybe Handle, [ProcessHandle]) + +piper [] phs pin pend = return (pin, pend, phs) + +piper (p:ps) [] Nothing Nothing = do + let p' = p {std_in = CreatePipe} + (pin, pend, _, ph) <- createProcess p' + piper ps [ph] pin pend + +piper (p:ps) phs pin pend = do + let p' = p {std_in = CreatePipe, std_out = UseHandle (fromJust pin)} + (pin', _, _, ph) <- createProcess p' + piper ps (ph:phs) pin' pend + + -- A version of words, but works with any lists on any predicate. parts pred s = case dropWhile pred s of @@ -13,14 +75,63 @@ s' -> w : parts pred s'' where (w, s'') = break pred s' +-- Run a compiler over a stream of consts, resolving them via preprocessor, +-- try to guess their types. + +guessConsts fn gcc cnsts = do + let delimc = '%' + onestr s = concat [[delimc], s] + cnstrs = "#include " ++ fn ++ "\n" ++ (unlines $ map onestr cnsts) + gccproc = CreateProcess { + cmdspec = RawCommand gcc ["-E", "-"] + ,cwd = Nothing + ,env = Nothing + ,std_in = Inherit + ,std_out = Inherit + ,std_err = Inherit + ,close_fds = True + } + grepproc = CreateProcess { + cmdspec = RawCommand "grep" [[delimc]] + ,cwd = Nothing + ,env = Nothing + ,std_in = Inherit + ,std_out = Inherit + ,std_err = Inherit + ,close_fds = True + } + (mbin, mbout, ps) <- runPipe CreatePipe CreatePipe [gccproc, grepproc] + case (mbin, mbout) of + (Just i, Just h) -> do + forkIO (hPutStrLn i cnstrs >> return ()) + s <- hGetContents h >>= return . lines + let cprs = map (span (/= '%')) s + tryp = zip cnsts (map (tryparse . tail . snd) cprs) + mapM_ waitForProcess ps + return tryp + (_, _) -> return [("-- Error", tryparse "")] + +tryparse "" = (NoGuess, []) + +tryparse x = let t = scanHeader x + p = runParser constant_expression (PState 0 Map.empty) "" t + in case (t, p) of + (_, Left _) -> (NoGuess, []) + ([TKC_HEX _ _], Right _) -> (GuessInt, t) + ([TKC_OCT _ _], Right _) -> (GuessInt, t) + ([TKC_DEC _ _], Right _) -> (GuessInt, t) + ([TKC_EXP _ _], Right _) -> (GuessFloat, t) + (_, Right _) -> (Vague, t) + -- Run a compiler to check if a #define is good for inclusion into the -- produced .hsc code: a #define is a simple constant, w/o arguments. -testConst fn cnst gcc = system cmdline +testConst fn gcc cnst = rawSystem "sh" ["-c", cmdline] where cmdline = "echo '#include " ++ fn ++ "\nstatic int a = " ++ cnst ++ ";' | " ++ gcc ++ " -pipe -x c -fsyntax-only - 2>/dev/null" + -- Based on the include file name availability, produce either the file / module names -- themselves or placeholders for further sed'ing. diff --git a/programs/Makefile.hs b/programs/Makefile.hs --- a/programs/Makefile.hs +++ b/programs/Makefile.hs @@ -43,7 +43,7 @@ map chr [9,9,36,40,66,65,83,69,41,95,67,46,111,32,36,40,66,65,83,69,41,95,83,46,111,32,36,40,66,65,83,69,41,46,111], map chr [9,36,40,82,77,41,32,45,102,32,36,64], map chr [9,36,40,65,82,41,32,99,113,32,36,64,32,36,40,66,65,83,69,41,95,104,115,99,46,111,32,36,40,69,88,84,82,65,95,79,66,74,41], - map chr [9,36,40,70,73,78,68,41,32,46,32,45,110,97,109,101,32,39,36,40,66,65,83,69,41,42,46,111,39,32,124,32,36,40,71,82,69,80,41,32,39,115,112,108,105,116,47,39,32,124,32,36,40,109,97,107,101,45,108,105,98,114,97,114,121,41], + map chr [9,36,40,70,73,78,68,41,32,46,32,45,110,97,109,101,32,39,36,40,66,65,83,69,41,42,46,111,39,32,124,32,36,40,71,82,69,80,41,32,45,69,32,39,115,112,108,105,116,47,124,115,116,117,98,39,32,124,32,36,40,109,97,107,101,45,108,105,98,114,97,114,121,41], map chr [], map chr [], map chr [37,46,104,105,32,37,46,111,32,58,32,37,46,104,115], diff --git a/programs/WriteHsc.hs b/programs/WriteHsc.hs --- a/programs/WriteHsc.hs +++ b/programs/WriteHsc.hs @@ -14,6 +14,8 @@ import Data.List import Control.Monad import System.IO +import Control.Concurrent +import GHC.Conc -- Name for the HSFFIG field access class, and module to import @@ -109,27 +111,62 @@ -- This requires knowledge of the header file name. Therefore if it was impossible -- to determine it, constants will not be included. -writeConstAccess tus gcc Nothing = return () -writeConstAccess tus gcc (Just fn) = - do let cnsts = Map.keys $ Map.filterWithKey constonly tus +writeConstAccess _ _ Nothing = return () +writeConstAccess tus gcc mbfn@(Just fn) = do + let cnsts = Map.keys $ Map.filterWithKey constonly tus constonly _ DictDef = True constonly _ _ = False - fmfnc = (finalizeModuleName (Just fn)) ++ "_C" + nsect <- writeConstAccess' 0 cnsts gcc mbfn + let fmfnc = (finalizeModuleName (Just fn)) ++ "_C" + cmods = map (((fmfnc ++ "_") ++) . show) [0 .. (nsect - 1)] + putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n" + writeSplitHeaderX cmods cmods fmfnc + putStrLn $ "\n" ++ splitEnd ++ "\n" + return () + +writeConstAccess' n [] _ _ = return n +writeConstAccess' n tusd gcc Nothing = return 0 +writeConstAccess' n tusd gcc (Just fn) = + do let cnsts = take 100 tusd + trem = drop 100 tusd + fmfnc = (finalizeModuleName (Just fn)) ++ "_C_" ++ show n + finfn = finalizeFileName (Just fn) putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n" writeSplitHeader [] fmfnc - mapM (oneconst fn gcc) cnsts + guess <- guessConsts finfn gcc cnsts >>= return . filter ((/= NoGuess) . fst . snd) + let vagues = filter ((== Vague) . fst . snd) guess + ints = filter ((== GuessInt) . fst . snd) guess + floats = filter ((== GuessFloat) . fst . snd) guess + mapM (oneconst ExitSuccess) (map fst ints) + mapM (oneconst ExitSuccess) (map fst floats) + testsyn (testConst finfn gcc) (map fst vagues) putStrLn $ "\n" ++ splitEnd ++ "\n" - return () + writeConstAccess' (n + 1) trem gcc (Just fn) +testsyn fn [] = return () + +testsyn fn cs = do + let nproc = 4 + let h = take nproc cs + t = drop nproc cs + let nt = length h + mvs <- mapM (\_ -> newEmptyMVar) h + hx <- zipWithM (\c v -> forkOS (do + x <- fn c + putMVar v x)) h mvs + whx <- mapM takeMVar mvs + zipWithM oneconst whx h + testsyn fn t + + -- No import for #define alloca. -oneconst _ _ "alloca" = return () +oneconst _ "alloca" = return () -oneconst fn gcc cnst = - do rc <- testConst (finalizeFileName (Just fn)) cnst gcc - case rc of - ExitSuccess -> putStrLn $ "c_" ++ cnst ++ " = #const " ++ cnst - _ -> return () +oneconst rc cnst = + case rc of + ExitSuccess -> (putStrLn $ "c_" ++ cnst ++ " = #const " ++ cnst) >> hFlush stdout + _ -> return () --------------------------------------------------------------------------------------- @@ -820,11 +857,13 @@ mapc2hs (TString "short") = TString' "CShort" mapc2hs (TString "unsigned_short") = TString' "CUShort" mapc2hs (TString "short_int") = TString' "CShort" +mapc2hs (TString "signed_short") = TString' "CShort" mapc2hs (TString "signed_short_int") = TString' "CShort" mapc2hs (TString "unsigned_short_int") = TString' "CUShort" mapc2hs (TString "char") = TString' "CChar" mapc2hs (TString "signed_char") = TString' "CSChar" mapc2hs (TString "unsigned_char") = TString' "CUChar" +mapc2hs (TString "signed_long") = TString' "CLong" mapc2hs (TString "long") = TString' "CLong" mapc2hs (TString "unsigned_long") = TString' "CULong" mapc2hs (TString "long_int") = TString' "CLong" @@ -1007,6 +1046,7 @@ isdirstruct ts = checktsrec isd ts where isd (TString ('@':_)) = True isd (TString' ('@':_)) = True + isd (TString' "CJmpBuf") = True isd _ = False -- Output a FFI declaration of a function or a variable. diff --git a/programs/ffipkg.hs b/programs/ffipkg.hs --- a/programs/ffipkg.hs +++ b/programs/ffipkg.hs @@ -288,7 +288,7 @@ fileToFd :: FilePath -> IO Fd -fileToFd s = openFd s WriteOnly (Just 420) defaultFileFlags +fileToFd s = openFd s WriteOnly (Just 420) (defaultFileFlags {trunc = True}) -- Redirect a Fd in a forked process. -- Credits to Donn Cave for the tip how to redirect stdout. @@ -490,7 +490,7 @@ hPutStrLn cabfd $ "Name: " ++ pkgName dopt hPutStrLn cabfd $ "Version: " ++ pkgVersion dopt hPutStrLn cabfd $ "Build-type: Custom" - hPutStrLn cabfd $ "Build-depends: base, HSFFIG" + hPutStrLn cabfd $ "Build-depends: base >= 4.0 && < 5, HSFFIG" hPutStrLn cabfd $ "Exposed-modules: " ++ head modlist hPutStrLn cabfd $ "Other-modules:\n" ++ intlv (map (" " ++) (drop 1 modlist)) ",\n" when (length (libDirs dopt) > 0) $