Add selectors for common fields (DataCon/PatSyn) to ConLike
[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, mkMachWord
17 , mkMachInt64, mkMachWord64
18 , mkMachFloat, mkMachDouble
19 , mkMachChar, mkMachString
20 , mkLitInteger
21
22 -- ** Operations on Literals
23 , literalType
24 , hashLiteral
25 , absentLiteralOf
26 , pprLiteral
27
28 -- ** Predicates on Literals and their contents
29 , litIsDupable, litIsTrivial, litIsLifted
30 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
31 , isZeroLit
32 , litFitsInChar
33 , litValue
34
35 -- ** Coercions
36 , word2IntLit, int2WordLit
37 , narrow8IntLit, narrow16IntLit, narrow32IntLit
38 , narrow8WordLit, narrow16WordLit, narrow32WordLit
39 , char2IntLit, int2CharLit
40 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
41 , nullAddrLit, float2DoubleLit, double2FloatLit
42 ) where
43
44 #include "HsVersions.h"
45
46 import TysPrim
47 import PrelNames
48 import Type
49 import TyCon
50 import Outputable
51 import FastTypes
52 import FastString
53 import BasicTypes
54 import Binary
55 import Constants
56 import DynFlags
57 import UniqFM
58 import Util
59
60 import Data.ByteString (ByteString)
61 import Data.Int
62 import Data.Ratio
63 import Data.Word
64 import Data.Char
65 import Data.Data ( Data, Typeable )
66 import Numeric ( fromRat )
67
68 {-
69 ************************************************************************
70 * *
71 \subsection{Literals}
72 * *
73 ************************************************************************
74 -}
75
76 -- | So-called 'Literal's are one of:
77 --
78 -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
79 -- which is presumed to be surrounded by appropriate constructors
80 -- (@Int#@, etc.), so that the overall thing makes sense.
81 --
82 -- * The literal derived from the label mentioned in a \"foreign label\"
83 -- declaration ('MachLabel')
84 data Literal
85 = ------------------
86 -- First the primitive guys
87 MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
88
89 | MachStr ByteString -- ^ A string-literal: stored and emitted
90 -- UTF-8 encoded, we'll arrange to decode it
91 -- at runtime. Also emitted with a @'\0'@
92 -- terminator. Create with 'mkMachString'
93
94 | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
95 -- that can be represented as a Literal. Create
96 -- with 'nullAddrLit'
97
98 | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
99 | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
100 | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
101 | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
102
103 | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
104 | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
105
106 | MachLabel FastString
107 (Maybe Int)
108 FunctionOrData
109 -- ^ A label literal. Parameters:
110 --
111 -- 1) The name of the symbol mentioned in the declaration
112 --
113 -- 2) The size (in bytes) of the arguments
114 -- the label expects. Only applicable with
115 -- @stdcall@ labels. @Just x@ => @\<x\>@ will
116 -- be appended to label name when emitting assembly.
117
118 | LitInteger Integer Type -- ^ Integer literals
119 -- See Note [Integer literals]
120 deriving (Data, Typeable)
121
122 {-
123 Note [Integer literals]
124 ~~~~~~~~~~~~~~~~~~~~~~~
125 An Integer literal is represented using, well, an Integer, to make it
126 easier to write RULEs for them. They also contain the Integer type, so
127 that e.g. literalType can return the right Type for them.
128
129 They only get converted into real Core,
130 mkInteger [c1, c2, .., cn]
131 during the CorePrep phase, although TidyPgm looks ahead at what the
132 core will be, so that it can see whether it involves CAFs.
133
134 When we initally build an Integer literal, notably when
135 deserialising it from an interface file (see the Binary instance
136 below), we don't have convenient access to the mkInteger Id. So we
137 just use an error thunk, and fill in the real Id when we do tcIfaceLit
138 in TcIface.
139
140
141 Binary instance
142 -}
143
144 instance Binary Literal where
145 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
146 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
147 put_ bh (MachNullAddr) = do putByte bh 2
148 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
149 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
150 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
151 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
152 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
153 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
154 put_ bh (MachLabel aj mb fod)
155 = do putByte bh 9
156 put_ bh aj
157 put_ bh mb
158 put_ bh fod
159 put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
160 get bh = do
161 h <- getByte bh
162 case h of
163 0 -> do
164 aa <- get bh
165 return (MachChar aa)
166 1 -> do
167 ab <- get bh
168 return (MachStr ab)
169 2 -> do
170 return (MachNullAddr)
171 3 -> do
172 ad <- get bh
173 return (MachInt ad)
174 4 -> do
175 ae <- get bh
176 return (MachInt64 ae)
177 5 -> do
178 af <- get bh
179 return (MachWord af)
180 6 -> do
181 ag <- get bh
182 return (MachWord64 ag)
183 7 -> do
184 ah <- get bh
185 return (MachFloat ah)
186 8 -> do
187 ai <- get bh
188 return (MachDouble ai)
189 9 -> do
190 aj <- get bh
191 mb <- get bh
192 fod <- get bh
193 return (MachLabel aj mb fod)
194 _ -> do
195 i <- get bh
196 -- See Note [Integer literals]
197 return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
198
199 instance Outputable Literal where
200 ppr lit = pprLiteral (\d -> d) lit
201
202 instance Eq Literal where
203 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
204 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
205
206 instance Ord Literal where
207 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
208 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
209 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
210 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
211 compare a b = cmpLit a b
212
213 {-
214 Construction
215 ~~~~~~~~~~~~
216 -}
217
218 -- | Creates a 'Literal' of type @Int#@
219 mkMachInt :: DynFlags -> Integer -> Literal
220 mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
221 MachInt x
222
223 -- | Creates a 'Literal' of type @Word#@
224 mkMachWord :: DynFlags -> Integer -> Literal
225 mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
226 MachWord x
227
228 -- | Creates a 'Literal' of type @Int64#@
229 mkMachInt64 :: Integer -> Literal
230 mkMachInt64 x = MachInt64 x
231
232 -- | Creates a 'Literal' of type @Word64#@
233 mkMachWord64 :: Integer -> Literal
234 mkMachWord64 x = MachWord64 x
235
236 -- | Creates a 'Literal' of type @Float#@
237 mkMachFloat :: Rational -> Literal
238 mkMachFloat = MachFloat
239
240 -- | Creates a 'Literal' of type @Double#@
241 mkMachDouble :: Rational -> Literal
242 mkMachDouble = MachDouble
243
244 -- | Creates a 'Literal' of type @Char#@
245 mkMachChar :: Char -> Literal
246 mkMachChar = MachChar
247
248 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
249 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
250 mkMachString :: String -> Literal
251 -- stored UTF-8 encoded
252 mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
253
254 mkLitInteger :: Integer -> Type -> Literal
255 mkLitInteger = LitInteger
256
257 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
258 inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
259 inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
260
261 inCharRange :: Char -> Bool
262 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
263
264 -- | Tests whether the literal represents a zero of whatever type it is
265 isZeroLit :: Literal -> Bool
266 isZeroLit (MachInt 0) = True
267 isZeroLit (MachInt64 0) = True
268 isZeroLit (MachWord 0) = True
269 isZeroLit (MachWord64 0) = True
270 isZeroLit (MachFloat 0) = True
271 isZeroLit (MachDouble 0) = True
272 isZeroLit _ = False
273
274 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
275 -- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
276 litValue :: Literal -> Integer
277 litValue (MachChar c) = toInteger $ ord c
278 litValue (MachInt i) = i
279 litValue (MachInt64 i) = i
280 litValue (MachWord i) = i
281 litValue (MachWord64 i) = i
282 litValue (LitInteger i _) = i
283 litValue l = pprPanic "litValue" (ppr l)
284
285 {-
286 Coercions
287 ~~~~~~~~~
288 -}
289
290 narrow8IntLit, narrow16IntLit, narrow32IntLit,
291 narrow8WordLit, narrow16WordLit, narrow32WordLit,
292 char2IntLit, int2CharLit,
293 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
294 float2DoubleLit, double2FloatLit
295 :: Literal -> Literal
296
297 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
298 word2IntLit dflags (MachWord w)
299 | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
300 | otherwise = MachInt w
301 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
302
303 int2WordLit dflags (MachInt i)
304 | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
305 | otherwise = MachWord i
306 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
307
308 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
309 narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
310 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
311 narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l)
312 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
313 narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l)
314 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
315 narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l)
316 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
317 narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l)
318 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
319 narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l)
320
321 char2IntLit (MachChar c) = MachInt (toInteger (ord c))
322 char2IntLit l = pprPanic "char2IntLit" (ppr l)
323 int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
324 int2CharLit l = pprPanic "int2CharLit" (ppr l)
325
326 float2IntLit (MachFloat f) = MachInt (truncate f)
327 float2IntLit l = pprPanic "float2IntLit" (ppr l)
328 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
329 int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
330
331 double2IntLit (MachDouble f) = MachInt (truncate f)
332 double2IntLit l = pprPanic "double2IntLit" (ppr l)
333 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
334 int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
335
336 float2DoubleLit (MachFloat f) = MachDouble f
337 float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
338 double2FloatLit (MachDouble d) = MachFloat d
339 double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
340
341 nullAddrLit :: Literal
342 nullAddrLit = MachNullAddr
343
344 {-
345 Predicates
346 ~~~~~~~~~~
347 -}
348
349 -- | True if there is absolutely no penalty to duplicating the literal.
350 -- False principally of strings
351 litIsTrivial :: Literal -> Bool
352 -- c.f. CoreUtils.exprIsTrivial
353 litIsTrivial (MachStr _) = False
354 litIsTrivial (LitInteger {}) = False
355 litIsTrivial _ = True
356
357 -- | True if code space does not go bad if we duplicate this literal
358 -- Currently we treat it just like 'litIsTrivial'
359 litIsDupable :: DynFlags -> Literal -> Bool
360 -- c.f. CoreUtils.exprIsDupable
361 litIsDupable _ (MachStr _) = False
362 litIsDupable dflags (LitInteger i _) = inIntRange dflags i
363 litIsDupable _ _ = True
364
365 litFitsInChar :: Literal -> Bool
366 litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
367 && i <= toInteger (ord maxBound)
368 litFitsInChar _ = False
369
370 litIsLifted :: Literal -> Bool
371 litIsLifted (LitInteger {}) = True
372 litIsLifted _ = False
373
374 {-
375 Types
376 ~~~~~
377 -}
378
379 -- | Find the Haskell 'Type' the literal occupies
380 literalType :: Literal -> Type
381 literalType MachNullAddr = addrPrimTy
382 literalType (MachChar _) = charPrimTy
383 literalType (MachStr _) = addrPrimTy
384 literalType (MachInt _) = intPrimTy
385 literalType (MachWord _) = wordPrimTy
386 literalType (MachInt64 _) = int64PrimTy
387 literalType (MachWord64 _) = word64PrimTy
388 literalType (MachFloat _) = floatPrimTy
389 literalType (MachDouble _) = doublePrimTy
390 literalType (MachLabel _ _ _) = addrPrimTy
391 literalType (LitInteger _ t) = t
392
393 absentLiteralOf :: TyCon -> Maybe Literal
394 -- Return a literal of the appropriate primtive
395 -- TyCon, to use as a placeholder when it doesn't matter
396 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
397
398 absent_lits :: UniqFM Literal
399 absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
400 , (charPrimTyConKey, MachChar 'x')
401 , (intPrimTyConKey, MachInt 0)
402 , (int64PrimTyConKey, MachInt64 0)
403 , (floatPrimTyConKey, MachFloat 0)
404 , (doublePrimTyConKey, MachDouble 0)
405 , (wordPrimTyConKey, MachWord 0)
406 , (word64PrimTyConKey, MachWord64 0) ]
407
408 {-
409 Comparison
410 ~~~~~~~~~~
411 -}
412
413 cmpLit :: Literal -> Literal -> Ordering
414 cmpLit (MachChar a) (MachChar b) = a `compare` b
415 cmpLit (MachStr a) (MachStr b) = a `compare` b
416 cmpLit (MachNullAddr) (MachNullAddr) = EQ
417 cmpLit (MachInt a) (MachInt b) = a `compare` b
418 cmpLit (MachWord a) (MachWord b) = a `compare` b
419 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
420 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
421 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
422 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
423 cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
424 cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
425 cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
426 | otherwise = GT
427
428 litTag :: Literal -> FastInt
429 litTag (MachChar _) = _ILIT(1)
430 litTag (MachStr _) = _ILIT(2)
431 litTag (MachNullAddr) = _ILIT(3)
432 litTag (MachInt _) = _ILIT(4)
433 litTag (MachWord _) = _ILIT(5)
434 litTag (MachInt64 _) = _ILIT(6)
435 litTag (MachWord64 _) = _ILIT(7)
436 litTag (MachFloat _) = _ILIT(8)
437 litTag (MachDouble _) = _ILIT(9)
438 litTag (MachLabel _ _ _) = _ILIT(10)
439 litTag (LitInteger {}) = _ILIT(11)
440
441 {-
442 Printing
443 ~~~~~~~~
444 * See Note [Printing of literals in Core]
445 -}
446
447 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
448 pprLiteral _ (MachChar c) = pprPrimChar c
449 pprLiteral _ (MachStr s) = pprHsBytes s
450 pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL")
451 pprLiteral _ (MachInt i) = pprPrimInt i
452 pprLiteral _ (MachInt64 i) = pprPrimInt64 i
453 pprLiteral _ (MachWord w) = pprPrimWord w
454 pprLiteral _ (MachWord64 w) = pprPrimWord64 w
455 pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix
456 pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix
457 pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
458 pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod)
459 where b = case mb of
460 Nothing -> pprHsString l
461 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
462
463 pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
464 -- See Note [Printing of literals in Core].
465 pprIntegerVal add_par i | i < 0 = add_par (integer i)
466 | otherwise = integer i
467
468 {-
469 Note [Printing of literals in Core]
470 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
471 The function `add_par` is used to wrap parenthesis around negative integers
472 (`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
473 an atomic thing (for example function application).
474
475 Although not all Core literals would be valid Haskell, we are trying to stay
476 as close as possible to Haskell syntax in the printing of Core, to make it
477 easier for a Haskell user to read Core.
478
479 To that end:
480 * We do print parenthesis around negative `LitInteger`, because we print
481 `LitInteger` using plain number literals (no prefix or suffix), and plain
482 number literals in Haskell require parenthesis in contexts like function
483 application (i.e. `1 - -1` is not valid Haskell).
484
485 * We don't print parenthesis around other (negative) literals, because they
486 aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
487 parser).
488
489 Literal Output Output if context requires
490 an atom (if different)
491 ------- ------- ----------------------
492 MachChar 'a'#
493 MachStr "aaa"#
494 MachNullAddr "__NULL"
495 MachInt -1#
496 MachInt64 -1L#
497 MachWord 1##
498 MachWord64 1L##
499 MachFloat -1.0#
500 MachDouble -1.0##
501 LitInteger -1 (-1)
502 MachLabel "__label" ... ("__label" ...)
503 -}
504
505 {-
506 ************************************************************************
507 * *
508 \subsection{Hashing}
509 * *
510 ************************************************************************
511
512 Hash values should be zero or a positive integer. No negatives please.
513 (They mess up the UniqFM for some reason.)
514 -}
515
516 hashLiteral :: Literal -> Int
517 hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
518 hashLiteral (MachStr s) = hashByteString s
519 hashLiteral (MachNullAddr) = 0
520 hashLiteral (MachInt i) = hashInteger i
521 hashLiteral (MachInt64 i) = hashInteger i
522 hashLiteral (MachWord i) = hashInteger i
523 hashLiteral (MachWord64 i) = hashInteger i
524 hashLiteral (MachFloat r) = hashRational r
525 hashLiteral (MachDouble r) = hashRational r
526 hashLiteral (MachLabel s _ _) = hashFS s
527 hashLiteral (LitInteger i _) = hashInteger i
528
529 hashRational :: Rational -> Int
530 hashRational r = hashInteger (numerator r)
531
532 hashInteger :: Integer -> Int
533 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
534 -- The 1+ is to avoid zero, which is a Bad Number
535 -- since we use * to combine hash values
536
537 hashFS :: FastString -> Int
538 hashFS s = iBox (uniqueOfFS s)