Adds a crude at&t assembly parser to resolve constants
authorMoritz Angermann <moritz.angermann@gmail.com>
Wed, 21 Feb 2018 02:33:59 +0000 (10:33 +0800)
committerMoritz Angermann <moritz.angermann@gmail.com>
Wed, 21 Feb 2018 10:03:34 +0000 (18:03 +0800)
Our current approach is taken from autoconf, and requires a binary search to
find constants.  This is not only very time consuming but also breaks when the
compiler fails to recognize an expression as constant.  As such we ask the
compiler to produce assembly, crudely parse that assembly and try to extract the
constant directly from the generated assembly.

ATTParser.hs [new file with mode: 0644]
CrossCodegen.hs
Flags.hs
Main.hs
hsc2hs.cabal

diff --git a/ATTParser.hs b/ATTParser.hs
new file mode 100644 (file)
index 0000000..427364f
--- /dev/null
@@ -0,0 +1,57 @@
+-- A rather crude asm parser.
+--
+--
+-- we only handle a subset of AT&T assembly
+-- right now.  This is what gcc and clang can
+-- emit.  For clang using llvm-ir might be
+-- even better.  For gcc gimple if that can
+-- be consumed reliably somehow.
+--
+-- For now we'll rely on the at&t assembly
+-- to be sufficient for constants.
+--
+
+
+module ATTParser where
+
+import Control.Applicative ((<|>))
+
+type ASM = [(String, [(String, String)])]
+
+parse :: FilePath -> IO ASM
+parse f = do
+  lns <- lines <$> readFile f
+  return $ foldl parseLine [] lns
+
+  where parseLine :: ASM -> String -> ASM
+        parseLine [] ('\t':_) = []
+        parseLine ((ident,attr):xs) ('\t':line) = let (key, val) = span (`notElem` " \t") line
+                                                  in (ident,(key,trim val):attr):xs
+        parseLine xs line = let ident = takeWhile (/= ':') line in (ident,[]):xs
+
+trim :: String -> String
+trim = reverse . dropWhile (`elem` " \t") . reverse . dropWhile (`elem` " \t")
+
+-- | lookup a constant numeric value. Drop any comments indicated by ';', '#' or '@'.
+-- We assume the value is either in the `.long` or `.quad` attribute.
+lookupConst :: String -> ASM -> Maybe String
+lookupConst key asm = lookup key asm >>= \x -> (trim . takeWhile (`notElem` ";#@") <$> (lookup ".long" x <|> lookup ".quad" x))
+                                               -- the compiler may emit something like `.space 4` to indicate 0000.
+                                               <|> (const "0" <$> lookup ".space" x)
+
+-- | extract a C String in the most basic sense we can.
+-- the .asciz directive doesn't contain the \0 terminator.
+lookupASCII :: String -> ASM -> Maybe String
+lookupASCII key asm = lookup key asm >>= \x -> read <$> lookup ".ascii" x <|> ((++ "\0") . read <$> lookup ".asciz" x)
+
+lookupInt :: String -> ASM -> Maybe Int
+lookupInt key = fmap read . lookupConst key
+
+lookupInteger :: String -> ASM -> Maybe Integer
+lookupInteger key = fmap read . lookupConst key
+
+lookupUInteger :: String -> ASM -> Maybe Integer
+lookupUInteger key = fmap (fromIntegral . (read :: String -> Word)) . lookupConst key
+
+lookupCString :: String -> ASM -> Maybe String
+lookupCString key asm = lookupConst key asm >>= flip lookupASCII asm
index 1312b91..ede874f 100644 (file)
@@ -40,6 +40,8 @@ import Common
 import Flags
 import HSCParser
 
+import qualified ATTParser as ATT
+
 -- A monad over IO for performing tests; keeps the commandline flags
 -- and a state counter for unique filename generation.
 -- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO))
@@ -219,8 +221,7 @@ outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _)  ke
        "const" -> outputConst value show >> return False
        "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
        "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
-       "alignment" -> outputConst (alignment value)
-                                  (\i -> "(" ++ show i ++ ")") >> return False
+       "alignment" -> outputConst (alignment value) show >> return False
        "peek" -> outputConst ("offsetof(" ++ value ++ ")")
                              (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False
        "poke" -> outputConst ("offsetof(" ++ value ++ ")")
@@ -271,19 +272,21 @@ checkValidity input = do
     flags <- testGetFlags
     let test = outTemplateHeaderCProg (cTemplate config) ++
                concatMap outFlagHeaderCProg flags ++
-               concatMap (uncurry outValidityCheck) (zip input [0..])
+               concatMap (uncurry (outValidityCheck (cViaAsm config))) (zip input [0..])
     testLog ("checking for compilation errors") $ do
         success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
             liftTestIO $ writeBinaryFile cFile test
             compiler <- testGetCompiler
             runCompiler compiler
-                        (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
+                        (["-S" | cViaAsm config ]++
+                         ["-c",cFile,"-o",oFile]++
+                         [f | CompFlag f <- flags])
                         Nothing
         when (not success) $ testFail' "compilation failed"
     testLog' "compilation is error-free"
 
-outValidityCheck :: Token -> Int -> String
-outValidityCheck s@(Special pos key value) uniq =
+outValidityCheck :: Bool -> Token -> Int -> String
+outValidityCheck viaAsm s@(Special pos key value) uniq =
     case key of
        "const" -> checkValidConst value
        "offset" -> checkValidConst ("offsetof(" ++ value ++ ")")
@@ -296,20 +299,26 @@ outValidityCheck s@(Special pos key value) uniq =
        "enum" -> checkValidEnum
        _ -> outHeaderCProg' s
     where
-    checkValidConst value' = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n";
+    checkValidConst value' = if viaAsm
+                             then validConstTestViaAsm (show uniq) value' ++ "\n"
+                             else "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n"
     checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ "    (void)(" ++ value ++ ")1;\n}\n";
     checkValidEnum =
         case parseEnum value of
             Nothing -> ""
+            Just (_,_,enums) | viaAsm ->
+                concatMap (\(hName,cName) -> validConstTestViaAsm (fromMaybe "noKey" (ATT.trim <$> hName) ++ show uniq) cName) enums
             Just (_,_,enums) ->
                 "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++
                 concatMap (\(_,cName) -> validConstTest cName) enums ++
                 "}\n"
 
     -- we want this to fail if the value is syntactically invalid or isn't a constant
-    validConstTest value' = outCLine pos ++ "    {\n        static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n        (void)test_array;\n    }\n";
+    validConstTest value' = outCLine pos ++ "    {\n        static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n        (void)test_array;\n    }\n"
+    validConstTestViaAsm name value' = outCLine pos ++ "\nextern long long _hsc2hs_test_" ++ name ++";\n"
+                                                    ++ "long long _hsc2hs_test_" ++ name ++ " = (" ++ value' ++ ");\n"
 
-outValidityCheck (Text _ _) _ = ""
+outValidityCheck (Text _ _) _ = ""
 
 -- Skips over some #if or other conditional that we found to be false.
 -- I.e. the argument should be a zipper whose cursor is one past the #if,
@@ -365,13 +374,16 @@ cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x
 -- Determines the value of SOME_VALUE using binary search; this
 -- is a trick which is cribbed from autoconf's AC_COMPUTE_INT.
 computeConst :: ZCursor Token -> String -> TestMonad Integer
-computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = do
+computeConst zOrig@(ZCursor (Special pos _ _) _ _) value =
     testLogAtPos pos ("computing " ++ value) $ do
-        nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
-        integral <- checkValueIsIntegral z nonNegative
-        when (not integral) $ testFail pos $ value ++ " is not an integer"
-        (lower,upper) <- bracketBounds z nonNegative
-        int <- binarySearch z nonNegative lower upper
+        config <- testGetConfig
+        int <- case cViaAsm config of
+                 True -> runCompileAsmIntegerTest z
+                 False -> do nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
+                             integral <- checkValueIsIntegral z nonNegative
+                             when (not integral) $ testFail pos $ value ++ " is not an integer"
+                             (lower,upper) <- bracketBounds z nonNegative
+                             binarySearch z nonNegative lower upper
         testLog' $ "result: " ++ show int
         return int
     where -- replace the Special's value with the provided value; e.g. the special
@@ -560,6 +572,40 @@ runCompileBooleanTest (ZCursor s above below) booleanTest = do
                (concatMap outHeaderCProg' below)
     runCompileTest test
 
+runCompileAsmIntegerTest :: ZCursor Token -> TestMonad Integer
+runCompileAsmIntegerTest (ZCursor s@(Special _ _ value) above below) = do
+    config <- testGetConfig
+    flags <- testGetFlags
+    let key = "___hsc2hs_int_test"
+    let test = -- all the surrounding code
+               outTemplateHeaderCProg (cTemplate config) ++
+               (concatMap outFlagHeaderCProg flags) ++
+               (concatMap outHeaderCProg' above) ++
+               outHeaderCProg' s ++
+               -- the test
+               "extern int " ++ key ++ "___signed___;\n" ++
+               "int " ++ key ++ "___signed___ = (" ++ value ++ ") < 0;\n" ++
+               "extern long long " ++ key ++ ";\n" ++
+               "long long " ++ key ++ " = (" ++ value ++ ");\n"++
+               (concatMap outHeaderCProg' below)
+    runCompileExtract key test
+runCompileAsmIntegerTest _ = error "runCompileAsmIntegerTestargument isn't a Special"
+
+runCompileExtract :: String -> String -> TestMonad Integer
+runCompileExtract k testStr = do
+    makeTest3 (".c", ".s", ".txt") $ \(cFile, sFile, stdout) -> do
+      liftTestIO $ writeBinaryFile cFile testStr
+      flags <- testGetFlags
+      compiler <- testGetCompiler
+      _ <- runCompiler compiler
+                  (["-S", "-c", cFile, "-o", sFile] ++ [f | CompFlag f <- flags])
+                  (Just stdout)
+      asm <- liftTestIO $ ATT.parse sFile
+      case (== 1) <$> ATT.lookupInteger (k ++ "___signed___") asm of
+        Just False -> return $ fromMaybe (error "Failed to extract unsigned integer") (ATT.lookupUInteger k asm)
+        Just True  -> return $ fromMaybe (error "Failed to extract integer") (ATT.lookupInteger k asm)
+        Nothing    -> error "Failed to extract integer sign information"
+
 runCompileTest :: String -> TestMonad Bool
 runCompileTest testStr = do
     makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do
index b436672..d621fd1 100644 (file)
--- a/Flags.hs
+++ b/Flags.hs
@@ -18,6 +18,7 @@ data ConfigM m = Config {
                      cKeepFiles :: Bool,
                      cNoCompile :: Bool,
                      cCrossCompile :: Bool,
+                     cViaAsm :: Bool,
                      cCrossSafe :: Bool,
                      cColumn :: Bool,
                      cVerbose :: Bool,
@@ -41,6 +42,7 @@ emptyMode = UseConfig $ Config {
                             cKeepFiles    = False,
                             cNoCompile    = False,
                             cCrossCompile = False,
+                            cViaAsm       = False,
                             cCrossSafe    = False,
                             cColumn       = False,
                             cVerbose      = False,
@@ -79,6 +81,8 @@ options = [
         "stop after writing *_hsc_make.c",
     Option ['x'] ["cross-compile"] (NoArg (withConfig $ setCrossCompile True))
         "activate cross-compilation mode",
+    Option [] ["via-asm"] (NoArg (withConfig $ setViaAsm True))
+        "use a crude asm parser to compute constants when cross compiling",
     Option [] ["cross-safe"] (NoArg (withConfig $ setCrossSafe True))
         "restrict .hsc directives to those supported by --cross-compile",
     Option ['k'] ["keep-files"] (NoArg (withConfig $ setKeepFiles True))
@@ -124,6 +128,9 @@ setNoCompile b c = c { cNoCompile = b }
 setCrossCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setCrossCompile b c = c { cCrossCompile = b }
 
+setViaAsm :: Bool -> ConfigM Maybe -> ConfigM Maybe
+setViaAsm b c = c { cViaAsm = b }
+
 setCrossSafe :: Bool -> ConfigM Maybe -> ConfigM Maybe
 setCrossSafe b c = c { cCrossSafe = b }
 
diff --git a/Main.hs b/Main.hs
index fad7aac..7f4eade 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -109,6 +109,7 @@ processFiles configM files usage = do
                      cKeepFiles    = cKeepFiles configM,
                      cNoCompile    = cNoCompile configM,
                      cCrossCompile = cCrossCompile configM,
+                     cViaAsm       = cViaAsm configM,
                      cCrossSafe    = cCrossSafe configM,
                      cColumn       = cColumn configM,
                      cVerbose      = cVerbose configM,
index 99d5072..1c334f0 100644 (file)
@@ -45,6 +45,7 @@ Executable hsc2hs
         DirectCodegen
         Flags
         HSCParser
+        ATTParser
         UtilsCodegen
         Paths_hsc2hs