0392a98274596ad038504da9b9a793620a5e004c
[ghc.git] / compiler / basicTypes / Literal.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module Literal
11 (
12 -- * Main data type
13 Literal(..) -- Exported to ParseIface
14
15 -- ** Creating Literals
16 , mkMachInt, mkMachIntWrap, mkMachIntWrapC
17 , mkMachWord, mkMachWordWrap, mkMachWordWrapC
18 , mkMachInt64, mkMachInt64Wrap
19 , mkMachWord64, mkMachWord64Wrap
20 , mkMachFloat, mkMachDouble
21 , mkMachChar, mkMachString
22 , mkLitInteger
23
24 -- ** Operations on Literals
25 , literalType
26 , absentLiteralOf
27 , pprLiteral
28
29 -- ** Predicates on Literals and their contents
30 , litIsDupable, litIsTrivial, litIsLifted
31 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
32 , isZeroLit
33 , litFitsInChar
34 , litValue, isLitValue, isLitValue_maybe, mapLitValue
35
36 -- ** Coercions
37 , word2IntLit, int2WordLit
38 , narrow8IntLit, narrow16IntLit, narrow32IntLit
39 , narrow8WordLit, narrow16WordLit, narrow32WordLit
40 , char2IntLit, int2CharLit
41 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
42 , nullAddrLit, float2DoubleLit, double2FloatLit
43 ) where
44
45 #include "HsVersions.h"
46
47 import GhcPrelude
48
49 import TysPrim
50 import PrelNames
51 import Type
52 import TyCon
53 import Outputable
54 import FastString
55 import BasicTypes
56 import Binary
57 import Constants
58 import DynFlags
59 import Platform
60 import UniqFM
61 import Util
62
63 import Data.ByteString (ByteString)
64 import Data.Int
65 import Data.Word
66 import Data.Char
67 import Data.Maybe ( isJust )
68 import Data.Data ( Data )
69 import Numeric ( fromRat )
70
71 {-
72 ************************************************************************
73 * *
74 \subsection{Literals}
75 * *
76 ************************************************************************
77 -}
78
79 -- | So-called 'Literal's are one of:
80 --
81 -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
82 -- which is presumed to be surrounded by appropriate constructors
83 -- (@Int#@, etc.), so that the overall thing makes sense.
84 --
85 -- We maintain the invariant that the 'Integer' the Mach{Int,Word}*
86 -- constructors are actually in the (possibly target-dependent) range.
87 -- The mkMach{Int,Word}*Wrap smart constructors ensure this by applying
88 -- the target machine's wrapping semantics. Use these in situations
89 -- where you know the wrapping semantics are correct.
90 --
91 -- * The literal derived from the label mentioned in a \"foreign label\"
92 -- declaration ('MachLabel')
93 data Literal
94 = ------------------
95 -- First the primitive guys
96 MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
97
98 | MachStr ByteString -- ^ A string-literal: stored and emitted
99 -- UTF-8 encoded, we'll arrange to decode it
100 -- at runtime. Also emitted with a @'\0'@
101 -- terminator. Create with 'mkMachString'
102
103 | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
104 -- that can be represented as a Literal. Create
105 -- with 'nullAddrLit'
106
107 | MachInt Integer -- ^ @Int#@ - according to target machine
108 | MachInt64 Integer -- ^ @Int64#@ - exactly 64 bits
109 | MachWord Integer -- ^ @Word#@ - according to target machine
110 | MachWord64 Integer -- ^ @Word64#@ - exactly 64 bits
111
112 | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
113 | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
114
115 | MachLabel FastString
116 (Maybe Int)
117 FunctionOrData
118 -- ^ A label literal. Parameters:
119 --
120 -- 1) The name of the symbol mentioned in the declaration
121 --
122 -- 2) The size (in bytes) of the arguments
123 -- the label expects. Only applicable with
124 -- @stdcall@ labels. @Just x@ => @\<x\>@ will
125 -- be appended to label name when emitting assembly.
126
127 | LitInteger Integer Type -- ^ Integer literals
128 -- See Note [Integer literals]
129 deriving Data
130
131 {-
132 Note [Integer literals]
133 ~~~~~~~~~~~~~~~~~~~~~~~
134 An Integer literal is represented using, well, an Integer, to make it
135 easier to write RULEs for them. They also contain the Integer type, so
136 that e.g. literalType can return the right Type for them.
137
138 They only get converted into real Core,
139 mkInteger [c1, c2, .., cn]
140 during the CorePrep phase, although TidyPgm looks ahead at what the
141 core will be, so that it can see whether it involves CAFs.
142
143 When we initally build an Integer literal, notably when
144 deserialising it from an interface file (see the Binary instance
145 below), we don't have convenient access to the mkInteger Id. So we
146 just use an error thunk, and fill in the real Id when we do tcIfaceLit
147 in TcIface.
148
149
150 Binary instance
151 -}
152
153 instance Binary Literal where
154 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
155 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
156 put_ bh (MachNullAddr) = do putByte bh 2
157 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
158 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
159 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
160 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
161 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
162 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
163 put_ bh (MachLabel aj mb fod)
164 = do putByte bh 9
165 put_ bh aj
166 put_ bh mb
167 put_ bh fod
168 put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
169 get bh = do
170 h <- getByte bh
171 case h of
172 0 -> do
173 aa <- get bh
174 return (MachChar aa)
175 1 -> do
176 ab <- get bh
177 return (MachStr ab)
178 2 -> do
179 return (MachNullAddr)
180 3 -> do
181 ad <- get bh
182 return (MachInt ad)
183 4 -> do
184 ae <- get bh
185 return (MachInt64 ae)
186 5 -> do
187 af <- get bh
188 return (MachWord af)
189 6 -> do
190 ag <- get bh
191 return (MachWord64 ag)
192 7 -> do
193 ah <- get bh
194 return (MachFloat ah)
195 8 -> do
196 ai <- get bh
197 return (MachDouble ai)
198 9 -> do
199 aj <- get bh
200 mb <- get bh
201 fod <- get bh
202 return (MachLabel aj mb fod)
203 _ -> do
204 i <- get bh
205 -- See Note [Integer literals]
206 return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
207
208 instance Outputable Literal where
209 ppr lit = pprLiteral (\d -> d) lit
210
211 instance Eq Literal where
212 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
213 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
214
215 instance Ord Literal where
216 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
217 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
218 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
219 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
220 compare a b = cmpLit a b
221
222 {-
223 Construction
224 ~~~~~~~~~~~~
225 -}
226
227 {- Note [Word/Int underflow/overflow]
228 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
229 According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
230 unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
231 the number of bits in the type."
232
233 GHC stores Word# and Int# constant values as Integer. Core optimizations such
234 as constant folding must ensure that the Integer value remains in the valid
235 target Word/Int range (see #13172). The following functions are used to
236 ensure this.
237
238 Note that we *don't* warn the user about overflow. It's not done at runtime
239 either, and compilation of completely harmless things like
240 ((124076834 :: Word32) + (2147483647 :: Word32))
241 doesn't yield a warning. Instead we simply squash the value into the *target*
242 Int/Word range.
243 -}
244
245 -- | Creates a 'Literal' of type @Int#@
246 mkMachInt :: DynFlags -> Integer -> Literal
247 mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
248 MachInt x
249
250 wrapInt :: DynFlags -> Integer -> Integer
251 wrapInt dflags i
252 = case platformWordSize (targetPlatform dflags) of
253 4 -> toInteger (fromIntegral i :: Int32)
254 8 -> toInteger (fromIntegral i :: Int64)
255 w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
256
257 -- | Creates a 'Literal' of type @Int#@.
258 -- If the argument is out of the (target-dependent) range, it is wrapped.
259 -- See Note [Word/Int underflow/overflow]
260 mkMachIntWrap :: DynFlags -> Integer -> Literal
261 mkMachIntWrap dflags i = MachInt (wrapInt dflags i)
262
263 -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
264 -- overflow. That is, if the argument is out of the (target-dependent) range
265 -- the argument is wrapped and the overflow flag will be set.
266 -- See Note [Word/Int underflow/overflow]
267 mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
268 mkMachIntWrapC dflags i = (MachInt i', i /= i')
269 where
270 i' = wrapInt dflags i
271
272 -- | Creates a 'Literal' of type @Word#@
273 mkMachWord :: DynFlags -> Integer -> Literal
274 mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
275 MachWord x
276
277 wrapWord :: DynFlags -> Integer -> Integer
278 wrapWord dflags i
279 = case platformWordSize (targetPlatform dflags) of
280 4 -> toInteger (fromIntegral i :: Word32)
281 8 -> toInteger (fromIntegral i :: Word64)
282 w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
283
284 -- | Creates a 'Literal' of type @Word#@.
285 -- If the argument is out of the (target-dependent) range, it is wrapped.
286 -- See Note [Word/Int underflow/overflow]
287 mkMachWordWrap :: DynFlags -> Integer -> Literal
288 mkMachWordWrap dflags i = MachWord (wrapWord dflags i)
289
290 -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
291 -- carry. That is, if the argument is out of the (target-dependent) range
292 -- the argument is wrapped and the carry flag will be set.
293 -- See Note [Word/Int underflow/overflow]
294 mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
295 mkMachWordWrapC dflags i = (MachWord i', i /= i')
296 where
297 i' = wrapWord dflags i
298
299 -- | Creates a 'Literal' of type @Int64#@
300 mkMachInt64 :: Integer -> Literal
301 mkMachInt64 x = ASSERT2( inInt64Range x, integer x )
302 MachInt64 x
303
304 -- | Creates a 'Literal' of type @Int64#@.
305 -- If the argument is out of the range, it is wrapped.
306 mkMachInt64Wrap :: Integer -> Literal
307 mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64))
308
309 -- | Creates a 'Literal' of type @Word64#@
310 mkMachWord64 :: Integer -> Literal
311 mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
312 MachWord64 x
313
314 -- | Creates a 'Literal' of type @Word64#@.
315 -- If the argument is out of the range, it is wrapped.
316 mkMachWord64Wrap :: Integer -> Literal
317 mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
318
319 -- | Creates a 'Literal' of type @Float#@
320 mkMachFloat :: Rational -> Literal
321 mkMachFloat = MachFloat
322
323 -- | Creates a 'Literal' of type @Double#@
324 mkMachDouble :: Rational -> Literal
325 mkMachDouble = MachDouble
326
327 -- | Creates a 'Literal' of type @Char#@
328 mkMachChar :: Char -> Literal
329 mkMachChar = MachChar
330
331 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
332 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
333 mkMachString :: String -> Literal
334 -- stored UTF-8 encoded
335 mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
336
337 mkLitInteger :: Integer -> Type -> Literal
338 mkLitInteger = LitInteger
339
340 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
341 inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
342 inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
343
344 inInt64Range, inWord64Range :: Integer -> Bool
345 inInt64Range x = x >= toInteger (minBound :: Int64) &&
346 x <= toInteger (maxBound :: Int64)
347 inWord64Range x = x >= toInteger (minBound :: Word64) &&
348 x <= toInteger (maxBound :: Word64)
349
350 inCharRange :: Char -> Bool
351 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
352
353 -- | Tests whether the literal represents a zero of whatever type it is
354 isZeroLit :: Literal -> Bool
355 isZeroLit (MachInt 0) = True
356 isZeroLit (MachInt64 0) = True
357 isZeroLit (MachWord 0) = True
358 isZeroLit (MachWord64 0) = True
359 isZeroLit (MachFloat 0) = True
360 isZeroLit (MachDouble 0) = True
361 isZeroLit _ = False
362
363 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
364 -- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
365 litValue :: Literal -> Integer
366 litValue l = case isLitValue_maybe l of
367 Just x -> x
368 Nothing -> pprPanic "litValue" (ppr l)
369
370 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
371 -- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
372 isLitValue_maybe :: Literal -> Maybe Integer
373 isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c
374 isLitValue_maybe (MachInt i) = Just i
375 isLitValue_maybe (MachInt64 i) = Just i
376 isLitValue_maybe (MachWord i) = Just i
377 isLitValue_maybe (MachWord64 i) = Just i
378 isLitValue_maybe (LitInteger i _) = Just i
379 isLitValue_maybe _ = Nothing
380
381 -- | Apply a function to the 'Integer' contained in the 'Literal', for when that
382 -- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
383 -- fixed-size integral literals, the result will be wrapped in
384 -- accordance with the semantics of the target type.
385 -- See Note [Word/Int underflow/overflow]
386 mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
387 mapLitValue _ f (MachChar c) = mkMachChar (fchar c)
388 where fchar = chr . fromInteger . f . toInteger . ord
389 mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i)
390 mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i)
391 mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i)
392 mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i)
393 mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t
394 mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
395
396 -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
397 -- 'Int', 'Word' and 'LitInteger'.
398 isLitValue :: Literal -> Bool
399 isLitValue = isJust . isLitValue_maybe
400
401 {-
402 Coercions
403 ~~~~~~~~~
404 -}
405
406 narrow8IntLit, narrow16IntLit, narrow32IntLit,
407 narrow8WordLit, narrow16WordLit, narrow32WordLit,
408 char2IntLit, int2CharLit,
409 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
410 float2DoubleLit, double2FloatLit
411 :: Literal -> Literal
412
413 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
414 word2IntLit dflags (MachWord w)
415 | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
416 | otherwise = MachInt w
417 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
418
419 int2WordLit dflags (MachInt i)
420 | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
421 | otherwise = MachWord i
422 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
423
424 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
425 narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
426 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
427 narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l)
428 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
429 narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l)
430 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
431 narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l)
432 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
433 narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l)
434 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
435 narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l)
436
437 char2IntLit (MachChar c) = MachInt (toInteger (ord c))
438 char2IntLit l = pprPanic "char2IntLit" (ppr l)
439 int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
440 int2CharLit l = pprPanic "int2CharLit" (ppr l)
441
442 float2IntLit (MachFloat f) = MachInt (truncate f)
443 float2IntLit l = pprPanic "float2IntLit" (ppr l)
444 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
445 int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
446
447 double2IntLit (MachDouble f) = MachInt (truncate f)
448 double2IntLit l = pprPanic "double2IntLit" (ppr l)
449 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
450 int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
451
452 float2DoubleLit (MachFloat f) = MachDouble f
453 float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
454 double2FloatLit (MachDouble d) = MachFloat d
455 double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
456
457 nullAddrLit :: Literal
458 nullAddrLit = MachNullAddr
459
460 {-
461 Predicates
462 ~~~~~~~~~~
463 -}
464
465 -- | True if there is absolutely no penalty to duplicating the literal.
466 -- False principally of strings.
467 --
468 -- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would
469 -- blow up code sizes. Not only this, it's also unsafe.
470 --
471 -- Consider a program that wants to traverse a string. One way it might do this
472 -- is to first compute the Addr# pointing to the end of the string, and then,
473 -- starting from the beginning, bump a pointer using eqAddr# to determine the
474 -- end. For instance,
475 --
476 -- @
477 -- -- Given pointers to the start and end of a string, count how many zeros
478 -- -- the string contains.
479 -- countZeros :: Addr# -> Addr# -> -> Int
480 -- countZeros start end = go start 0
481 -- where
482 -- go off n
483 -- | off `addrEq#` end = n
484 -- | otherwise = go (off `plusAddr#` 1) n'
485 -- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1
486 -- | otherwise = n
487 -- @
488 --
489 -- Consider what happens if we considered strings to be trivial (and therefore
490 -- duplicable) and emitted a call like @countZeros "hello"# ("hello"#
491 -- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same
492 -- string, meaning that an iteration like the above would blow up terribly.
493 -- This is what happened in #12757.
494 --
495 -- Ultimately the solution here is to make primitive strings a bit more
496 -- structured, ensuring that the compiler can't inline in ways that will break
497 -- user code. One approach to this is described in #8472.
498 litIsTrivial :: Literal -> Bool
499 -- c.f. CoreUtils.exprIsTrivial
500 litIsTrivial (MachStr _) = False
501 litIsTrivial (LitInteger {}) = False
502 litIsTrivial _ = True
503
504 -- | True if code space does not go bad if we duplicate this literal
505 -- Currently we treat it just like 'litIsTrivial'
506 litIsDupable :: DynFlags -> Literal -> Bool
507 -- c.f. CoreUtils.exprIsDupable
508 litIsDupable _ (MachStr _) = False
509 litIsDupable dflags (LitInteger i _) = inIntRange dflags i
510 litIsDupable _ _ = True
511
512 litFitsInChar :: Literal -> Bool
513 litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
514 && i <= toInteger (ord maxBound)
515 litFitsInChar _ = False
516
517 litIsLifted :: Literal -> Bool
518 litIsLifted (LitInteger {}) = True
519 litIsLifted _ = False
520
521 {-
522 Types
523 ~~~~~
524 -}
525
526 -- | Find the Haskell 'Type' the literal occupies
527 literalType :: Literal -> Type
528 literalType MachNullAddr = addrPrimTy
529 literalType (MachChar _) = charPrimTy
530 literalType (MachStr _) = addrPrimTy
531 literalType (MachInt _) = intPrimTy
532 literalType (MachWord _) = wordPrimTy
533 literalType (MachInt64 _) = int64PrimTy
534 literalType (MachWord64 _) = word64PrimTy
535 literalType (MachFloat _) = floatPrimTy
536 literalType (MachDouble _) = doublePrimTy
537 literalType (MachLabel _ _ _) = addrPrimTy
538 literalType (LitInteger _ t) = t
539
540 absentLiteralOf :: TyCon -> Maybe Literal
541 -- Return a literal of the appropriate primitive
542 -- TyCon, to use as a placeholder when it doesn't matter
543 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
544
545 absent_lits :: UniqFM Literal
546 absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
547 , (charPrimTyConKey, MachChar 'x')
548 , (intPrimTyConKey, MachInt 0)
549 , (int64PrimTyConKey, MachInt64 0)
550 , (floatPrimTyConKey, MachFloat 0)
551 , (doublePrimTyConKey, MachDouble 0)
552 , (wordPrimTyConKey, MachWord 0)
553 , (word64PrimTyConKey, MachWord64 0) ]
554
555 {-
556 Comparison
557 ~~~~~~~~~~
558 -}
559
560 cmpLit :: Literal -> Literal -> Ordering
561 cmpLit (MachChar a) (MachChar b) = a `compare` b
562 cmpLit (MachStr a) (MachStr b) = a `compare` b
563 cmpLit (MachNullAddr) (MachNullAddr) = EQ
564 cmpLit (MachInt a) (MachInt b) = a `compare` b
565 cmpLit (MachWord a) (MachWord b) = a `compare` b
566 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
567 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
568 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
569 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
570 cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
571 cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
572 cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT
573 | otherwise = GT
574
575 litTag :: Literal -> Int
576 litTag (MachChar _) = 1
577 litTag (MachStr _) = 2
578 litTag (MachNullAddr) = 3
579 litTag (MachInt _) = 4
580 litTag (MachWord _) = 5
581 litTag (MachInt64 _) = 6
582 litTag (MachWord64 _) = 7
583 litTag (MachFloat _) = 8
584 litTag (MachDouble _) = 9
585 litTag (MachLabel _ _ _) = 10
586 litTag (LitInteger {}) = 11
587
588 {-
589 Printing
590 ~~~~~~~~
591 * See Note [Printing of literals in Core]
592 -}
593
594 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
595 pprLiteral _ (MachChar c) = pprPrimChar c
596 pprLiteral _ (MachStr s) = pprHsBytes s
597 pprLiteral _ (MachNullAddr) = text "__NULL"
598 pprLiteral _ (MachInt i) = pprPrimInt i
599 pprLiteral _ (MachInt64 i) = pprPrimInt64 i
600 pprLiteral _ (MachWord w) = pprPrimWord w
601 pprLiteral _ (MachWord64 w) = pprPrimWord64 w
602 pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix
603 pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix
604 pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
605 pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
606 where b = case mb of
607 Nothing -> pprHsString l
608 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
609
610 pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
611 -- See Note [Printing of literals in Core].
612 pprIntegerVal add_par i | i < 0 = add_par (integer i)
613 | otherwise = integer i
614
615 {-
616 Note [Printing of literals in Core]
617 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
618 The function `add_par` is used to wrap parenthesis around negative integers
619 (`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
620 an atomic thing (for example function application).
621
622 Although not all Core literals would be valid Haskell, we are trying to stay
623 as close as possible to Haskell syntax in the printing of Core, to make it
624 easier for a Haskell user to read Core.
625
626 To that end:
627 * We do print parenthesis around negative `LitInteger`, because we print
628 `LitInteger` using plain number literals (no prefix or suffix), and plain
629 number literals in Haskell require parenthesis in contexts like function
630 application (i.e. `1 - -1` is not valid Haskell).
631
632 * We don't print parenthesis around other (negative) literals, because they
633 aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
634 parser).
635
636 Literal Output Output if context requires
637 an atom (if different)
638 ------- ------- ----------------------
639 MachChar 'a'#
640 MachStr "aaa"#
641 MachNullAddr "__NULL"
642 MachInt -1#
643 MachInt64 -1L#
644 MachWord 1##
645 MachWord64 1L##
646 MachFloat -1.0#
647 MachDouble -1.0##
648 LitInteger -1 (-1)
649 MachLabel "__label" ... ("__label" ...)
650 -}