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