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