1{-# LANGUAGE NoMonomorphismRestriction #-} 2 3module CrossCodegen where 4 5{- 6A special cross-compilation mode for hsc2hs, which generates a .hs 7file without needing to run the executables that the C compiler 8outputs. 9 10Instead, it uses the output of compilations only -- specifically, 11whether compilation fails. This is the same trick that autoconf uses 12when cross compiling; if you want to know if sizeof(int) <= 4, then try 13compiling: 14 15> int x() { 16> static int ary[1 - 2*(sizeof(int) <= 4)]; 17> } 18 19and see if it fails. If you want to know sizeof(int), then 20repeatedly apply this kind of test with differing values, using 21binary search. 22-} 23 24import Prelude hiding (concatMap) 25import System.IO (hPutStr, openFile, IOMode(..), hClose) 26import System.Directory (removeFile) 27import Data.Char (toLower,toUpper,isSpace) 28import Control.Exception (assert, onException) 29import Control.Monad (when, liftM, forM, ap) 30import Control.Applicative as AP (Applicative(..)) 31import Data.Foldable (concatMap) 32import Data.Maybe (fromMaybe) 33import qualified Data.Sequence as S 34import Data.Sequence ((|>),ViewL(..)) 35import System.Exit ( ExitCode(..) ) 36import System.Process 37 38import C 39import Common 40import Flags 41import HSCParser 42 43import qualified ATTParser as ATT 44 45-- A monad over IO for performing tests; keeps the commandline flags 46-- and a state counter for unique filename generation. 47-- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO)) 48newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) } 49 50instance Functor TestMonad where 51 fmap = liftM 52 53instance Applicative TestMonad where 54 pure a = TestMonad (\_ c -> pure (Right a, c)) 55 (<*>) = ap 56 57instance Monad TestMonad where 58 return = AP.pure 59 x >>= fn = TestMonad (\e c -> (runTest x e c) >>= 60 (\(a,c') -> either (\err -> return (Left err, c')) 61 (\result -> runTest (fn result) e c') 62 a)) 63 64data TestMonadEnv = TestMonadEnv { 65 testIsVerbose_ :: Bool, 66 testLogNestCount_ :: Int, 67 testKeepFiles_ :: Bool, 68 testGetBaseName_ :: FilePath, 69 testGetFlags_ :: [Flag], 70 testGetConfig_ :: Config, 71 testGetCompiler_ :: FilePath 72} 73 74testAsk :: TestMonad TestMonadEnv 75testAsk = TestMonad (\e c -> return (Right e, c)) 76 77testIsVerbose :: TestMonad Bool 78testIsVerbose = testIsVerbose_ `fmap` testAsk 79 80testGetCompiler :: TestMonad FilePath 81testGetCompiler = testGetCompiler_ `fmap` testAsk 82 83testKeepFiles :: TestMonad Bool 84testKeepFiles = testKeepFiles_ `fmap` testAsk 85 86testGetFlags :: TestMonad [Flag] 87testGetFlags = testGetFlags_ `fmap` testAsk 88 89testGetConfig :: TestMonad Config 90testGetConfig = testGetConfig_ `fmap` testAsk 91 92testGetBaseName :: TestMonad FilePath 93testGetBaseName = testGetBaseName_ `fmap` testAsk 94 95testIncCount :: TestMonad Int 96testIncCount = TestMonad (\_ c -> let next=succ c 97 in next `seq` return (Right c, next)) 98testFail' :: String -> TestMonad a 99testFail' s = TestMonad (\_ c -> return (Left s, c)) 100 101testFail :: SourcePos -> String -> TestMonad a 102testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s) 103 104-- liftIO for TestMonad 105liftTestIO :: IO a -> TestMonad a 106liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c)) 107 108-- finally for TestMonad 109testFinally :: TestMonad a -> TestMonad b -> TestMonad a 110testFinally action cleanup = do r <- action `testOnException` cleanup 111 _ <- cleanup 112 return r 113 114-- onException for TestMonad. This rolls back the state on an 115-- IO exception, which isn't great but shouldn't matter for now 116-- since only the test count is stored there. 117testOnException :: TestMonad a -> TestMonad b -> TestMonad a 118testOnException action cleanup = TestMonad (\e c -> runTest action e c 119 `onException` runTest cleanup e c >>= \(actionResult,c') -> 120 case actionResult of 121 Left _ -> do (_,c'') <- runTest cleanup e c' 122 return (actionResult,c'') 123 Right _ -> return (actionResult,c')) 124 125-- prints the string to stdout if verbose mode is enabled. 126-- Maintains a nesting count and pads with spaces so that: 127-- testLog "a" $ 128-- testLog "b" $ return () 129-- will print 130-- a 131-- b 132testLog :: String -> TestMonad a -> TestMonad a 133testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e 134 nestCount = testLogNestCount_ e 135 when verbose $ putStrLn $ (concat $ replicate nestCount " ") ++ s 136 runTest a (e { testLogNestCount_ = nestCount+1 }) c) 137 138testLog' :: String -> TestMonad () 139testLog' s = testLog s (return ()) 140 141testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a 142testLogAtPos (SourcePos file line _) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a 143 144-- Given a list of file suffixes, will generate a list of filenames 145-- which are all unique and have the given suffixes. On exit from this 146-- action, all those files will be removed (unless keepFiles is active) 147makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a 148makeTest fileSuffixes fn = do 149 c <- testIncCount 150 fileBase <- testGetBaseName 151 keepFiles <- testKeepFiles 152 let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes 153 testFinally (fn files) 154 (when (not keepFiles) 155 (mapM_ removeOrIgnore files)) 156 where 157 removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ())) 158-- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers) 159makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a 160makeTest2 (a,b) fn = makeTest [a,b] helper 161 where helper [a',b'] = fn (a',b') 162 helper _ = error "makeTest: internal error" 163makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a 164makeTest3 (a,b,c) fn = makeTest [a,b,c] helper 165 where helper [a',b',c'] = fn (a',b',c') 166 helper _ = error "makeTest: internal error" 167 168-- A Zipper over lists. Unlike ListZipper, this separates at the type level 169-- a list which may have a currently focused item (Zipper a) from 170-- a list which _definitely_ has a focused item (ZCursor a), so 171-- that zNext can be total. 172data Zipper a = End { zEnd :: S.Seq a } 173 | Zipper (ZCursor a) 174 175data ZCursor a = ZCursor { zCursor :: a, 176 zAbove :: S.Seq a, -- elements prior to the cursor 177 -- in regular order (not reversed!) 178 zBelow :: S.Seq a -- elements after the cursor 179 } 180 181zipFromList :: [a] -> Zipper a 182zipFromList [] = End S.empty 183zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls)) 184 185zNext :: ZCursor a -> Zipper a 186zNext (ZCursor c above below) = 187 case S.viewl below of 188 S.EmptyL -> End (above |> c) 189 c' :< below' -> Zipper (ZCursor c' (above |> c) below') 190 191-- Generates the .hs file from the .hsc file, by looping over each 192-- Special element and calling outputSpecial to find out what it needs. 193diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad () 194diagnose inputFilename output input = do 195 checkValidity input 196 output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n") 197 loop (True, True) (zipFromList input) 198 199 where 200 loop _ (End _) = return () 201 loop state@(lineSync, colSync) 202 (Zipper z@ZCursor {zCursor=Special _ key _}) = 203 case key of 204 _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do 205 condHolds <- checkConditional z 206 if condHolds 207 then loop state (zNext z) 208 else loop state =<< either testFail' return 209 (skipFalseConditional (zNext z)) 210 "endif" -> loop state (zNext z) 211 _ -> do 212 sync <- outputSpecial output z 213 loop (lineSync && sync, colSync && sync) (zNext z) 214 loop state (Zipper z@ZCursor {zCursor=Text pos txt}) = do 215 state' <- outputText state output pos txt 216 loop state' (zNext z) 217 218outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool 219outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _) key value}) = 220 case key of 221 "const" -> outputConst value show >> return False 222 "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False 223 "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False 224 "alignment" -> outputConst (alignment value) show >> return False 225 "peek" -> outputConst ("offsetof(" ++ value ++ ")") 226 (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False 227 "poke" -> outputConst ("offsetof(" ++ value ++ ")") 228 (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False 229 "ptr" -> outputConst ("offsetof(" ++ value ++ ")") 230 (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False 231 "type" -> computeType z >>= output >> return False 232 "enum" -> computeEnum z >>= output >> return False 233 "error" -> testFail pos ("#error " ++ value) 234 "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) >> return True 235 "include" -> return True 236 "define" -> return True 237 "undef" -> return True 238 _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode") 239 where outputConst value' formatter = computeConst z value' >>= (output . formatter) 240outputSpecial _ _ = error "outputSpecial's argument isn't a Special" 241 242outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String 243 -> TestMonad (Bool, Bool) 244outputText state output pos txt = do 245 enableCol <- fmap cColumn testGetConfig 246 let outCol col | enableCol = "{-# COLUMN " ++ show col ++ " #-}" 247 | otherwise = "" 248 let outLine (SourcePos file line _) = "{-# LINE " ++ show (line + 1) ++ 249 " \"" ++ file ++ "\" #-}\n" 250 let (s, state') = outTextHs state pos txt id outLine outCol 251 output s 252 return state' 253 254-- Bleh, messy. For each test we're compiling, we have a specific line of 255-- code that may cause compiler errors -- that's the test we want to perform. 256-- However, we *really* don't want any other kinds of compiler errors sneaking 257-- in (which might be e.g. due to the user's syntax errors) or we'll make the 258-- wrong conclusions on our tests. 259-- 260-- So before we compile any of the tests, take a pass over the whole file and 261-- generate a .c file which should fail if there are any syntax errors in what 262-- the user gaves us. Hopefully, then the only reason our later compilations 263-- might fail is the particular reason we want. 264-- 265-- Another approach would be to try to parse the stdout of GCC and diagnose 266-- whether the error is the one we want. That's tricky because of localization 267-- etc. etc., though it would be less nerve-wracking. FYI it's not the approach 268-- that autoconf went with. 269checkValidity :: [Token] -> TestMonad () 270checkValidity input = do 271 config <- testGetConfig 272 flags <- testGetFlags 273 let test = outTemplateHeaderCProg (cTemplate config) ++ 274 concatMap outFlagHeaderCProg flags ++ 275 concatMap (uncurry (outValidityCheck (cViaAsm config))) (zip input [0..]) 276 testLog ("checking for compilation errors") $ do 277 success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do 278 liftTestIO $ writeBinaryFile cFile test 279 compiler <- testGetCompiler 280 runCompiler compiler 281 (["-S" | cViaAsm config ]++ 282 ["-c",cFile,"-o",oFile]++ 283 [f | CompFlag f <- flags]) 284 Nothing 285 when (not success) $ testFail' "compilation failed" 286 testLog' "compilation is error-free" 287 288outValidityCheck :: Bool -> Token -> Int -> String 289outValidityCheck viaAsm s@(Special pos key value) uniq = 290 case key of 291 "const" -> checkValidConst value 292 "offset" -> checkValidConst ("offsetof(" ++ value ++ ")") 293 "size" -> checkValidConst ("sizeof(" ++ value ++ ")") 294 "alignment" -> checkValidConst (alignment value) 295 "peek" -> checkValidConst ("offsetof(" ++ value ++ ")") 296 "poke" -> checkValidConst ("offsetof(" ++ value ++ ")") 297 "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")") 298 "type" -> checkValidType 299 "enum" -> checkValidEnum 300 _ -> outHeaderCProg' s 301 where 302 checkValidConst value' = if viaAsm 303 then validConstTestViaAsm (show uniq) value' ++ "\n" 304 else "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n" 305 checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n"; 306 checkValidEnum = 307 case parseEnum value of 308 Nothing -> "" 309 Just (_,_,enums) | viaAsm -> 310 concatMap (\(hName,cName) -> validConstTestViaAsm (fromMaybe "noKey" (ATT.trim `fmap` hName) ++ show uniq) cName) enums 311 Just (_,_,enums) -> 312 "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ 313 concatMap (\(_,cName) -> validConstTest cName) enums ++ 314 "}\n" 315 316 -- we want this to fail if the value is syntactically invalid or isn't a constant 317 validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n" 318 validConstTestViaAsm name value' = outCLine pos ++ "\nextern long long _hsc2hs_test_" ++ name ++";\n" 319 ++ "long long _hsc2hs_test_" ++ name ++ " = (" ++ value' ++ ");\n" 320 321outValidityCheck _ (Text _ _) _ = "" 322 323-- Skips over some #if or other conditional that we found to be false. 324-- I.e. the argument should be a zipper whose cursor is one past the #if, 325-- and returns a zipper whose cursor points at the next item which 326-- could possibly be compiled. 327skipFalseConditional :: Zipper Token -> Either String (Zipper Token) 328skipFalseConditional (End _) = Left "unterminated endif" 329skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) = 330 case key of 331 "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 332 "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 333 "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 334 "elif" -> Right $ Zipper z 335 "else" -> Right $ Zipper z 336 "endif" -> Right $ zNext z 337 _ -> skipFalseConditional (zNext z) 338skipFalseConditional (Zipper z) = skipFalseConditional (zNext z) 339 340-- Skips over an #if all the way to the #endif 341skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token) 342skipFullConditional _ (End _) = Left "unterminated endif" 343skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) = 344 case key of 345 "if" -> skipFullConditional (nest+1) (zNext z) 346 "ifdef" -> skipFullConditional (nest+1) (zNext z) 347 "ifndef" -> skipFullConditional (nest+1) (zNext z) 348 "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z) 349 "endif" | otherwise -> Right $ zNext z 350 _ -> skipFullConditional nest (zNext z) 351skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z) 352 353data IntegerConstant = Signed Integer | 354 Unsigned Integer deriving (Show) 355-- Prints an syntatically valid integer in C 356cShowInteger :: IntegerConstant -> String 357cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)" 358 -- Trick to avoid overflowing large integer constants 359 -- http://www.hardtoc.com/archives/119 360cShowInteger (Signed x) = show x 361cShowInteger (Unsigned x) = show x ++ "u" 362 363data IntegerComparison = GreaterOrEqual IntegerConstant | 364 LessOrEqual IntegerConstant 365instance Show IntegerComparison where 366 showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c 367 showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c 368 369cShowCmpTest :: IntegerComparison -> String 370cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x 371cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x 372 373-- The cursor should point at #{const SOME_VALUE} or something like that. 374-- Determines the value of SOME_VALUE using binary search; this 375-- is a trick which is cribbed from autoconf's AC_COMPUTE_INT. 376computeConst :: ZCursor Token -> String -> TestMonad Integer 377computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = 378 testLogAtPos pos ("computing " ++ value) $ do 379 config <- testGetConfig 380 int <- case cViaAsm config of 381 True -> runCompileAsmIntegerTest z 382 False -> do nonNegative <- compareConst z (GreaterOrEqual (Signed 0)) 383 integral <- checkValueIsIntegral z nonNegative 384 when (not integral) $ testFail pos $ value ++ " is not an integer" 385 (lower,upper) <- bracketBounds z nonNegative 386 binarySearch z nonNegative lower upper 387 testLog' $ "result: " ++ show int 388 return int 389 where -- replace the Special's value with the provided value; e.g. the special 390 -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)". 391 z = zOrig {zCursor=specialSetValue value (zCursor zOrig)} 392 specialSetValue v (Special p k _) = Special p k v 393 specialSetValue _ _ = error "computeConst argument isn't a Special" 394computeConst _ _ = error "computeConst argument isn't a Special" 395 396-- Binary search, once we've bracketed the integer. 397binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer 398binarySearch _ _ l u | l == u = return l 399binarySearch z nonNegative l u = do 400 let mid :: Integer 401 mid = (l+u+1) `div` 2 402 inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid) 403 let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1)) 404 assert (l < mid && mid <= u && -- @l < mid <= u@ 405 l <= l' && l' <= u' && u' <= u && -- @l <= l' <= u' <= u@ 406 u'-l' < u-l) -- @|u' - l'| < |u - l|@ 407 (binarySearch z nonNegative l' u') 408 409-- Establishes bounds on the unknown integer. By searching increasingly 410-- large powers of 2, it'll bracket an integer x by lower & upper 411-- such that lower <= x <= upper. 412-- 413-- Assumes 2's complement integers. 414bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer) 415bracketBounds z nonNegative = do 416 let -- test against integers 2**x-1 when positive, and 2**x when negative, 417 -- to avoid generating constants that'd overflow the machine's integers. 418 -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1). 419 -- If we're comparing against all 2**x-1, we'll stop our search 420 -- before we ever overflow int. 421 powersOfTwo = iterate (\a -> 2*a) 1 422 positiveBounds = map pred powersOfTwo 423 negativeBounds = map negate powersOfTwo 424 425 -- Test each element of the bounds list until we find one that exceeds 426 -- the integer. 427 loop cmp inner (maybeOuter:bounds') = do 428 outerBounded <- compareConst z (cmp maybeOuter) 429 if outerBounded 430 then return (inner,maybeOuter) 431 else loop cmp maybeOuter bounds' 432 loop _ _ _ = error "bracketBounds: infinite list exhausted" 433 434 if nonNegative 435 then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds 436 return (inner+1,outer) 437 else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds 438 return (outer,inner-1) 439 440-- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize 441haskellize :: String -> String 442haskellize [] = [] 443haskellize (firstLetter:next) = toLower firstLetter : loop False next 444 where loop _ [] = [] 445 loop _ ('_':as) = loop True as 446 loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as 447 448-- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types & 449-- constructors will be mangled by the C preprocessor. This mimics the same 450-- mangling. 451stringify :: String -> String 452-- Spec: stringify = unwords . words 453stringify = go False . dropWhile isSpace 454 where 455 go _haveSpace [] = [] 456 go haveSpace (x:xs) 457 | isSpace x = go True xs 458 | otherwise = if haveSpace 459 then ' ' : x : go False xs 460 else x : go False xs 461 462-- For #{alignment} codegen; mimic's template-hsc.h's hsc_alignment 463alignment :: String -> String 464alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)" 465 466computeEnum :: ZCursor Token -> TestMonad String 467computeEnum z@(ZCursor (Special _ _ enumText) _ _) = 468 case parseEnum enumText of 469 Nothing -> return "" 470 Just (enumType,constructor,enums) -> 471 concatM enums $ \(maybeHsName, cName) -> do 472 constValue <- computeConst z cName 473 let hsName = fromMaybe (haskellize cName) maybeHsName 474 return $ 475 hsName ++ " :: " ++ stringify enumType ++ "\n" ++ 476 hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n" 477 where concatM l = liftM concat . forM l 478computeEnum _ = error "computeEnum argument isn't a Special" 479 480-- Implementation of #{type}, using computeConst 481computeType :: ZCursor Token -> TestMonad String 482computeType z@(ZCursor (Special pos _ value) _ _) = do 483 testLogAtPos pos ("computing type of " ++ value) $ do 484 integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do 485 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4" 486 testLog' $ "result: " ++ (if success then "integer" else "floating") 487 return success 488 typeRet <- if integral 489 then do 490 signed <- testLog ("checking if type " ++ value ++ " is signed") $ do 491 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0" 492 testLog' $ "result: " ++ (if success then "signed" else "unsigned") 493 return success 494 size <- computeConst z ("sizeof(" ++ value ++ ")") 495 return $ (if signed then "Int" else "Word") ++ (show (size * 8)) 496 else do 497 let checkSize test = testLog ("checking if " ++ test) $ do 498 success <- runCompileBooleanTest z test 499 testLog' $ "result: " ++ show success 500 return success 501 ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)") 502 if ldouble 503 then return "LDouble" 504 else do 505 double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)") 506 if double 507 then return "Double" 508 else return "Float" 509 testLog' $ "result: " ++ typeRet 510 return typeRet 511computeType _ = error "computeType argument isn't a Special" 512 513outHeaderCProg' :: Token -> String 514outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value) 515outHeaderCProg' _ = "" 516 517-- Checks if an #if/#ifdef etc. etc. is true by inserting a #error 518-- and seeing if the compile fails. 519checkConditional :: ZCursor Token -> TestMonad Bool 520checkConditional (ZCursor s@(Special pos key value) above below) = do 521 config <- testGetConfig 522 flags <- testGetFlags 523 let test = outTemplateHeaderCProg (cTemplate config) ++ 524 (concatMap outFlagHeaderCProg flags) ++ 525 (concatMap outHeaderCProg' above) ++ 526 outHeaderCProg' s ++ "#error T\n" ++ 527 (concatMap outHeaderCProg' below) 528 testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do 529 condTrue <- not `fmap` runCompileTest test 530 testLog' $ "result: " ++ show condTrue 531 return condTrue 532checkConditional _ = error "checkConditional argument isn't a Special" 533 534-- Make sure the value we're trying to binary search isn't floating point. 535checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool 536checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do 537 let intType = if nonNegative then "unsigned long long" else "long long" 538 testLog ("checking if " ++ value ++ " is an integer") $ do 539 success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")" 540 testLog' $ "result: " ++ (if success then "integer" else "floating") 541 return success 542checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special" 543 544compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool 545compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do 546 testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do 547 success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest 548 testLog' $ "result: " ++ show success 549 return success 550compareConst _ _ = error "compareConst argument isn't a Special" 551 552-- Given a compile-time constant with boolean type, this extracts the 553-- value of the constant by compiling a .c file only. 554-- 555-- The trick comes from autoconf: use the fact that the compiler must 556-- perform constant arithmetic for computation of array dimensions, and 557-- will generate an error if the array has negative size. 558runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool 559runCompileBooleanTest (ZCursor s above below) booleanTest = do 560 config <- testGetConfig 561 flags <- testGetFlags 562 let test = -- all the surrounding code 563 outTemplateHeaderCProg (cTemplate config) ++ 564 (concatMap outFlagHeaderCProg flags) ++ 565 (concatMap outHeaderCProg' above) ++ 566 outHeaderCProg' s ++ 567 -- the test 568 "int _hsc2hs_test() {\n" ++ 569 " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++ 570 " return test_array[0];\n" ++ 571 "}\n" ++ 572 (concatMap outHeaderCProg' below) 573 runCompileTest test 574 575runCompileAsmIntegerTest :: ZCursor Token -> TestMonad Integer 576runCompileAsmIntegerTest (ZCursor s@(Special _ _ value) above below) = do 577 config <- testGetConfig 578 flags <- testGetFlags 579 let key = "___hsc2hs_int_test" 580 let test = -- all the surrounding code 581 outTemplateHeaderCProg (cTemplate config) ++ 582 (concatMap outFlagHeaderCProg flags) ++ 583 (concatMap outHeaderCProg' above) ++ 584 outHeaderCProg' s ++ 585 -- the test 586 "extern unsigned long long ___hsc2hs_BOM___;\n" ++ 587 "unsigned long long ___hsc2hs_BOM___ = 0x100000000;\n" ++ 588 "extern unsigned long long " ++ key ++ "___hsc2hs_sign___;\n" ++ 589 "unsigned long long " ++ key ++ "___hsc2hs_sign___ = (" ++ value ++ ") < 0;\n" ++ 590 "extern unsigned long long " ++ key ++ ";\n" ++ 591 "unsigned long long " ++ key ++ " = (" ++ value ++ ");\n"++ 592 (concatMap outHeaderCProg' below) 593 runCompileExtract key test 594runCompileAsmIntegerTest _ = error "runCompileAsmIntegerTestargument isn't a Special" 595 596runCompileExtract :: String -> String -> TestMonad Integer 597runCompileExtract k testStr = do 598 makeTest3 (".c", ".s", ".txt") $ \(cFile, sFile, stdout) -> do 599 liftTestIO $ writeBinaryFile cFile testStr 600 flags <- testGetFlags 601 compiler <- testGetCompiler 602 _ <- runCompiler compiler 603 (["-S", "-c", cFile, "-o", sFile] ++ [f | CompFlag f <- flags]) 604 (Just stdout) 605 asm <- liftTestIO $ ATT.parse sFile 606 return $ fromMaybe (error "Failed to extract integer") (ATT.lookupInteger k asm) 607 608runCompileTest :: String -> TestMonad Bool 609runCompileTest testStr = do 610 makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do 611 liftTestIO $ writeBinaryFile cFile testStr 612 flags <- testGetFlags 613 compiler <- testGetCompiler 614 runCompiler compiler 615 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags]) 616 (Just stdout) 617 618runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool 619runCompiler prog args mStdoutFile = do 620 let cmdLine = showCommandForUser prog args 621 testLog ("executing: " ++ cmdLine) $ liftTestIO $ do 622 mHOut <- case mStdoutFile of 623 Nothing -> return Nothing 624 Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode 625 process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut 626 case mHOut of 627 Just hOut -> hClose hOut 628 Nothing -> return () 629 exitStatus <- waitForProcess process 630 return $ case exitStatus of 631 ExitSuccess -> True 632 ExitFailure _ -> False 633 634-- The main driver for cross-compilation mode 635outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO () 636outputCross config outName outDir outBase inName toks = 637 runTestMonad $ do 638 file <- liftTestIO $ openFile outName WriteMode 639 (diagnose inName (liftTestIO . hPutStr file) toks 640 `testFinally` (liftTestIO $ hClose file)) 641 `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors 642 where 643 tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config) 644 runTestMonad x = runTest x tmenv 0 >>= (handleError . fst) 645 646 handleError (Left e) = die (e++"\n") 647 handleError (Right ()) = return () 648