Adds a crude at&t assembly parser to resolve constants

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.
parent 738f3666
-- 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
......@@ -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
......
......@@ -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 }
......
......@@ -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,
......
......@@ -45,6 +45,7 @@ Executable hsc2hs
DirectCodegen
Flags
HSCParser
ATTParser
UtilsCodegen
Paths_hsc2hs
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment