Add support for response files in wrapper script
[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, ap)
30 import Control.Applicative as AP (Applicative(..))
31 import Data.Foldable (concatMap)
32 import Data.Maybe (fromMaybe)
33 import qualified Data.Sequence as S
34 import Data.Sequence ((|>),ViewL(..))
35 import System.Exit ( ExitCode(..) )
36 import System.Process
37
38 import C
39 import Common
40 import Flags
41 import HSCParser
42
43 import 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))
48 newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) }
49
50 instance Functor TestMonad where
51 fmap = liftM
52
53 instance Applicative TestMonad where
54 pure a = TestMonad (\_ c -> pure (Right a, c))
55 (<*>) = ap
56
57 instance 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
64 data 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
74 testAsk :: TestMonad TestMonadEnv
75 testAsk = TestMonad (\e c -> return (Right e, c))
76
77 testIsVerbose :: TestMonad Bool
78 testIsVerbose = testIsVerbose_ `fmap` testAsk
79
80 testGetCompiler :: TestMonad FilePath
81 testGetCompiler = testGetCompiler_ `fmap` testAsk
82
83 testKeepFiles :: TestMonad Bool
84 testKeepFiles = testKeepFiles_ `fmap` testAsk
85
86 testGetFlags :: TestMonad [Flag]
87 testGetFlags = testGetFlags_ `fmap` testAsk
88
89 testGetConfig :: TestMonad Config
90 testGetConfig = testGetConfig_ `fmap` testAsk
91
92 testGetBaseName :: TestMonad FilePath
93 testGetBaseName = testGetBaseName_ `fmap` testAsk
94
95 testIncCount :: TestMonad Int
96 testIncCount = TestMonad (\_ c -> let next=succ c
97 in next `seq` return (Right c, next))
98 testFail' :: String -> TestMonad a
99 testFail' s = TestMonad (\_ c -> return (Left s, c))
100
101 testFail :: SourcePos -> String -> TestMonad a
102 testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)
103
104 -- liftIO for TestMonad
105 liftTestIO :: IO a -> TestMonad a
106 liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c))
107
108 -- finally for TestMonad
109 testFinally :: TestMonad a -> TestMonad b -> TestMonad a
110 testFinally 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.
117 testOnException :: TestMonad a -> TestMonad b -> TestMonad a
118 testOnException 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
132 testLog :: String -> TestMonad a -> TestMonad a
133 testLog 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
138 testLog' :: String -> TestMonad ()
139 testLog' s = testLog s (return ())
140
141 testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a
142 testLogAtPos (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)
147 makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a
148 makeTest 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)
159 makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a
160 makeTest2 (a,b) fn = makeTest [a,b] helper
161 where helper [a',b'] = fn (a',b')
162 helper _ = error "makeTest: internal error"
163 makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a
164 makeTest3 (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.
172 data Zipper a = End { zEnd :: S.Seq a }
173 | Zipper (ZCursor a)
174
175 data 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
181 zipFromList :: [a] -> Zipper a
182 zipFromList [] = End S.empty
183 zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls))
184
185 zNext :: ZCursor a -> Zipper a
186 zNext (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.
193 diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad ()
194 diagnose 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
218 outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool
219 outputSpecial 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)
240 outputSpecial _ _ = error "outputSpecial's argument isn't a Special"
241
242 outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String
243 -> TestMonad (Bool, Bool)
244 outputText 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.
269 checkValidity :: [Token] -> TestMonad ()
270 checkValidity 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
288 outValidityCheck :: Bool -> Token -> Int -> String
289 outValidityCheck 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
321 outValidityCheck _ (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.
327 skipFalseConditional :: Zipper Token -> Either String (Zipper Token)
328 skipFalseConditional (End _) = Left "unterminated endif"
329 skipFalseConditional (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)
338 skipFalseConditional (Zipper z) = skipFalseConditional (zNext z)
339
340 -- Skips over an #if all the way to the #endif
341 skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token)
342 skipFullConditional _ (End _) = Left "unterminated endif"
343 skipFullConditional 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)
351 skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z)
352
353 data IntegerConstant = Signed Integer |
354 Unsigned Integer deriving (Show)
355 -- Prints an syntatically valid integer in C
356 cShowInteger :: IntegerConstant -> String
357 cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)"
358 -- Trick to avoid overflowing large integer constants
359 -- http://www.hardtoc.com/archives/119
360 cShowInteger (Signed x) = show x
361 cShowInteger (Unsigned x) = show x ++ "u"
362
363 data IntegerComparison = GreaterOrEqual IntegerConstant |
364 LessOrEqual IntegerConstant
365 instance Show IntegerComparison where
366 showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c
367 showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c
368
369 cShowCmpTest :: IntegerComparison -> String
370 cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x
371 cShowCmpTest (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.
376 computeConst :: ZCursor Token -> String -> TestMonad Integer
377 computeConst 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"
394 computeConst _ _ = error "computeConst argument isn't a Special"
395
396 -- Binary search, once we've bracketed the integer.
397 binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer
398 binarySearch _ _ l u | l == u = return l
399 binarySearch 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.
414 bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer)
415 bracketBounds 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
441 haskellize :: String -> String
442 haskellize [] = []
443 haskellize (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.
451 stringify :: String -> String
452 -- Spec: stringify = unwords . words
453 stringify = 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
463 alignment :: String -> String
464 alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)"
465
466 computeEnum :: ZCursor Token -> TestMonad String
467 computeEnum 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
478 computeEnum _ = error "computeEnum argument isn't a Special"
479
480 -- Implementation of #{type}, using computeConst
481 computeType :: ZCursor Token -> TestMonad String
482 computeType 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
511 computeType _ = error "computeType argument isn't a Special"
512
513 outHeaderCProg' :: Token -> String
514 outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value)
515 outHeaderCProg' _ = ""
516
517 -- Checks if an #if/#ifdef etc. etc. is true by inserting a #error
518 -- and seeing if the compile fails.
519 checkConditional :: ZCursor Token -> TestMonad Bool
520 checkConditional (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
532 checkConditional _ = error "checkConditional argument isn't a Special"
533
534 -- Make sure the value we're trying to binary search isn't floating point.
535 checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool
536 checkValueIsIntegral 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
542 checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special"
543
544 compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool
545 compareConst 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
550 compareConst _ _ = 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.
558 runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
559 runCompileBooleanTest (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
575 runCompileAsmIntegerTest :: ZCursor Token -> TestMonad Integer
576 runCompileAsmIntegerTest (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
594 runCompileAsmIntegerTest _ = error "runCompileAsmIntegerTestargument isn't a Special"
595
596 runCompileExtract :: String -> String -> TestMonad Integer
597 runCompileExtract 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
608 runCompileTest :: String -> TestMonad Bool
609 runCompileTest 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
618 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
619 runCompiler 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
635 outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
636 outputCross 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 ()