Rename literal constructors
[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@: literals}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
9
10 module Literal
11 (
12 -- * Main data type
13 Literal(..) -- Exported to ParseIface
14 , LitNumType(..)
15
16 -- ** Creating Literals
17 , mkLitInt, mkLitIntWrap, mkLitIntWrapC
18 , mkLitWord, mkLitWordWrap, mkLitWordWrapC
19 , mkLitInt64, mkLitInt64Wrap
20 , mkLitWord64, mkLitWord64Wrap
21 , mkLitFloat, mkLitDouble
22 , mkLitChar, mkLitString
23 , mkLitInteger, mkLitNatural
24 , mkLitNumber, mkLitNumberWrap
25
26 -- ** Operations on Literals
27 , literalType
28 , absentLiteralOf
29 , pprLiteral
30 , litNumIsSigned
31 , litNumCheckRange
32
33 -- ** Predicates on Literals and their contents
34 , litIsDupable, litIsTrivial, litIsLifted
35 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
36 , isZeroLit
37 , litFitsInChar
38 , litValue, isLitValue, isLitValue_maybe, mapLitValue
39
40 -- ** Coercions
41 , word2IntLit, int2WordLit
42 , narrowLit
43 , narrow8IntLit, narrow16IntLit, narrow32IntLit
44 , narrow8WordLit, narrow16WordLit, narrow32WordLit
45 , char2IntLit, int2CharLit
46 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
47 , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit
48 ) where
49
50 #include "HsVersions.h"
51
52 import GhcPrelude
53
54 import TysPrim
55 import PrelNames
56 import Type
57 import TyCon
58 import Outputable
59 import FastString
60 import BasicTypes
61 import Binary
62 import Constants
63 import DynFlags
64 import Platform
65 import UniqFM
66 import Util
67
68 import Data.ByteString (ByteString)
69 import Data.Int
70 import Data.Word
71 import Data.Char
72 import Data.Maybe ( isJust )
73 import Data.Data ( Data )
74 import Data.Proxy
75 import Numeric ( fromRat )
76
77 {-
78 ************************************************************************
79 * *
80 \subsection{Literals}
81 * *
82 ************************************************************************
83 -}
84
85 -- | So-called 'Literal's are one of:
86 --
87 -- * An unboxed numeric literal or floating-point literal which is presumed
88 -- to be surrounded by appropriate constructors (@Int#@, etc.), so that
89 -- the overall thing makes sense.
90 --
91 -- We maintain the invariant that the 'Integer' in the 'LitNumber'
92 -- constructor is actually in the (possibly target-dependent) range.
93 -- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying
94 -- the target machine's wrapping semantics. Use these in situations
95 -- where you know the wrapping semantics are correct.
96 --
97 -- * The literal derived from the label mentioned in a \"foreign label\"
98 -- declaration ('LitLabel')
99 --
100 -- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'
101 -- (i.e. 'MutVar#') when the the value is never used.
102 --
103 -- * A character
104 -- * A string
105 -- * The NULL pointer
106 --
107 data Literal
108 = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with
109 -- 'mkLitChar'
110
111 | LitNumber !LitNumType !Integer Type
112 -- ^ Any numeric literal that can be
113 -- internally represented with an Integer
114
115 | LitString ByteString -- ^ A string-literal: stored and emitted
116 -- UTF-8 encoded, we'll arrange to decode it
117 -- at runtime. Also emitted with a @'\0'@
118 -- terminator. Create with 'mkLitString'
119
120 | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value
121 -- that can be represented as a Literal. Create
122 -- with 'nullAddrLit'
123
124 | LitRubbish -- ^ A nonsense value, used when an unlifted
125 -- binding is absent and has type
126 -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.
127 -- May be lowered by code-gen to any possible
128 -- value. Also see Note [Rubbish literals]
129
130 | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat'
131 | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble'
132
133 | LitLabel FastString (Maybe Int) FunctionOrData
134 -- ^ A label literal. Parameters:
135 --
136 -- 1) The name of the symbol mentioned in the
137 -- declaration
138 --
139 -- 2) The size (in bytes) of the arguments
140 -- the label expects. Only applicable with
141 -- @stdcall@ labels. @Just x@ => @\<x\>@ will
142 -- be appended to label name when emitting
143 -- assembly.
144 --
145 -- 3) Flag indicating whether the symbol
146 -- references a function or a data
147 deriving Data
148
149 -- | Numeric literal type
150 data LitNumType
151 = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
152 | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
153 | LitNumInt -- ^ @Int#@ - according to target machine
154 | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits
155 | LitNumWord -- ^ @Word#@ - according to target machine
156 | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits
157 deriving (Data,Enum,Eq,Ord)
158
159 -- | Indicate if a numeric literal type supports negative numbers
160 litNumIsSigned :: LitNumType -> Bool
161 litNumIsSigned nt = case nt of
162 LitNumInteger -> True
163 LitNumNatural -> False
164 LitNumInt -> True
165 LitNumInt64 -> True
166 LitNumWord -> False
167 LitNumWord64 -> False
168
169 {-
170 Note [Integer literals]
171 ~~~~~~~~~~~~~~~~~~~~~~~
172 An Integer literal is represented using, well, an Integer, to make it
173 easier to write RULEs for them. They also contain the Integer type, so
174 that e.g. literalType can return the right Type for them.
175
176 They only get converted into real Core,
177 mkInteger [c1, c2, .., cn]
178 during the CorePrep phase, although TidyPgm looks ahead at what the
179 core will be, so that it can see whether it involves CAFs.
180
181 When we initally build an Integer literal, notably when
182 deserialising it from an interface file (see the Binary instance
183 below), we don't have convenient access to the mkInteger Id. So we
184 just use an error thunk, and fill in the real Id when we do tcIfaceLit
185 in TcIface.
186
187 Note [Natural literals]
188 ~~~~~~~~~~~~~~~~~~~~~~~
189 Similar to Integer literals.
190
191 -}
192
193 instance Binary LitNumType where
194 put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
195 get bh = do
196 h <- getByte bh
197 return (toEnum (fromIntegral h))
198
199 instance Binary Literal where
200 put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
201 put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
202 put_ bh (LitNullAddr) = do putByte bh 2
203 put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah
204 put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai
205 put_ bh (LitLabel aj mb fod)
206 = do putByte bh 5
207 put_ bh aj
208 put_ bh mb
209 put_ bh fod
210 put_ bh (LitNumber nt i _)
211 = do putByte bh 6
212 put_ bh nt
213 put_ bh i
214 put_ bh (LitRubbish) = do putByte bh 7
215 get bh = do
216 h <- getByte bh
217 case h of
218 0 -> do
219 aa <- get bh
220 return (LitChar aa)
221 1 -> do
222 ab <- get bh
223 return (LitString ab)
224 2 -> do
225 return (LitNullAddr)
226 3 -> do
227 ah <- get bh
228 return (LitFloat ah)
229 4 -> do
230 ai <- get bh
231 return (LitDouble ai)
232 5 -> do
233 aj <- get bh
234 mb <- get bh
235 fod <- get bh
236 return (LitLabel aj mb fod)
237 6 -> do
238 nt <- get bh
239 i <- get bh
240 let t = case nt of
241 LitNumInt -> intPrimTy
242 LitNumInt64 -> int64PrimTy
243 LitNumWord -> wordPrimTy
244 LitNumWord64 -> word64PrimTy
245 -- See Note [Integer literals]
246 LitNumInteger ->
247 panic "Evaluated the place holder for mkInteger"
248 -- and Note [Natural literals]
249 LitNumNatural ->
250 panic "Evaluated the place holder for mkNatural"
251 return (LitNumber nt i t)
252 _ -> do
253 return (LitRubbish)
254
255 instance Outputable Literal where
256 ppr lit = pprLiteral (\d -> d) lit
257
258 instance Eq Literal where
259 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
260 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
261
262 -- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in
263 -- 'TrieMap.CoreMap'.
264 instance Ord Literal where
265 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
266 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
267 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
268 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
269 compare a b = cmpLit a b
270
271 {-
272 Construction
273 ~~~~~~~~~~~~
274 -}
275
276 {- Note [Word/Int underflow/overflow]
277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278 According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
279 unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
280 the number of bits in the type."
281
282 GHC stores Word# and Int# constant values as Integer. Core optimizations such
283 as constant folding must ensure that the Integer value remains in the valid
284 target Word/Int range (see #13172). The following functions are used to
285 ensure this.
286
287 Note that we *don't* warn the user about overflow. It's not done at runtime
288 either, and compilation of completely harmless things like
289 ((124076834 :: Word32) + (2147483647 :: Word32))
290 doesn't yield a warning. Instead we simply squash the value into the *target*
291 Int/Word range.
292 -}
293
294 -- | Wrap a literal number according to its type
295 wrapLitNumber :: DynFlags -> Literal -> Literal
296 wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
297 LitNumInt -> case platformWordSize (targetPlatform dflags) of
298 4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
299 8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
300 w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
301 LitNumWord -> case platformWordSize (targetPlatform dflags) of
302 4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
303 8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
304 w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
305 LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
306 LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
307 LitNumInteger -> v
308 LitNumNatural -> v
309 wrapLitNumber _ x = x
310
311 -- | Create a numeric 'Literal' of the given type
312 mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
313 mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)
314
315 -- | Check that a given number is in the range of a numeric literal
316 litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
317 litNumCheckRange dflags nt i = case nt of
318 LitNumInt -> inIntRange dflags i
319 LitNumWord -> inWordRange dflags i
320 LitNumInt64 -> inInt64Range i
321 LitNumWord64 -> inWord64Range i
322 LitNumNatural -> i >= 0
323 LitNumInteger -> True
324
325 -- | Create a numeric 'Literal' of the given type
326 mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
327 mkLitNumber dflags nt i t =
328 ASSERT2(litNumCheckRange dflags nt i, integer i)
329 (LitNumber nt i t)
330
331 -- | Creates a 'Literal' of type @Int#@
332 mkLitInt :: DynFlags -> Integer -> Literal
333 mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x )
334 (mkLitIntUnchecked x)
335
336 -- | Creates a 'Literal' of type @Int#@.
337 -- If the argument is out of the (target-dependent) range, it is wrapped.
338 -- See Note [Word/Int underflow/overflow]
339 mkLitIntWrap :: DynFlags -> Integer -> Literal
340 mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i
341
342 -- | Creates a 'Literal' of type @Int#@ without checking its range.
343 mkLitIntUnchecked :: Integer -> Literal
344 mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy
345
346 -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
347 -- overflow. That is, if the argument is out of the (target-dependent) range
348 -- the argument is wrapped and the overflow flag will be set.
349 -- See Note [Word/Int underflow/overflow]
350 mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
351 mkLitIntWrapC dflags i = (n, i /= i')
352 where
353 n@(LitNumber _ i' _) = mkLitIntWrap dflags i
354
355 -- | Creates a 'Literal' of type @Word#@
356 mkLitWord :: DynFlags -> Integer -> Literal
357 mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x )
358 (mkLitWordUnchecked x)
359
360 -- | Creates a 'Literal' of type @Word#@.
361 -- If the argument is out of the (target-dependent) range, it is wrapped.
362 -- See Note [Word/Int underflow/overflow]
363 mkLitWordWrap :: DynFlags -> Integer -> Literal
364 mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i
365
366 -- | Creates a 'Literal' of type @Word#@ without checking its range.
367 mkLitWordUnchecked :: Integer -> Literal
368 mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy
369
370 -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
371 -- carry. That is, if the argument is out of the (target-dependent) range
372 -- the argument is wrapped and the carry flag will be set.
373 -- See Note [Word/Int underflow/overflow]
374 mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
375 mkLitWordWrapC dflags i = (n, i /= i')
376 where
377 n@(LitNumber _ i' _) = mkLitWordWrap dflags i
378
379 -- | Creates a 'Literal' of type @Int64#@
380 mkLitInt64 :: Integer -> Literal
381 mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)
382
383 -- | Creates a 'Literal' of type @Int64#@.
384 -- If the argument is out of the range, it is wrapped.
385 mkLitInt64Wrap :: DynFlags -> Integer -> Literal
386 mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i
387
388 -- | Creates a 'Literal' of type @Int64#@ without checking its range.
389 mkLitInt64Unchecked :: Integer -> Literal
390 mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
391
392 -- | Creates a 'Literal' of type @Word64#@
393 mkLitWord64 :: Integer -> Literal
394 mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)
395
396 -- | Creates a 'Literal' of type @Word64#@.
397 -- If the argument is out of the range, it is wrapped.
398 mkLitWord64Wrap :: DynFlags -> Integer -> Literal
399 mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i
400
401 -- | Creates a 'Literal' of type @Word64#@ without checking its range.
402 mkLitWord64Unchecked :: Integer -> Literal
403 mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
404
405 -- | Creates a 'Literal' of type @Float#@
406 mkLitFloat :: Rational -> Literal
407 mkLitFloat = LitFloat
408
409 -- | Creates a 'Literal' of type @Double#@
410 mkLitDouble :: Rational -> Literal
411 mkLitDouble = LitDouble
412
413 -- | Creates a 'Literal' of type @Char#@
414 mkLitChar :: Char -> Literal
415 mkLitChar = LitChar
416
417 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
418 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
419 mkLitString :: String -> Literal
420 -- stored UTF-8 encoded
421 mkLitString s = LitString (fastStringToByteString $ mkFastString s)
422
423 mkLitInteger :: Integer -> Type -> Literal
424 mkLitInteger x ty = LitNumber LitNumInteger x ty
425
426 mkLitNatural :: Integer -> Type -> Literal
427 mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x )
428 (LitNumber LitNumNatural x ty)
429
430 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
431 inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
432 inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
433
434 inNaturalRange :: Integer -> Bool
435 inNaturalRange x = x >= 0
436
437 inInt64Range, inWord64Range :: Integer -> Bool
438 inInt64Range x = x >= toInteger (minBound :: Int64) &&
439 x <= toInteger (maxBound :: Int64)
440 inWord64Range x = x >= toInteger (minBound :: Word64) &&
441 x <= toInteger (maxBound :: Word64)
442
443 inCharRange :: Char -> Bool
444 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
445
446 -- | Tests whether the literal represents a zero of whatever type it is
447 isZeroLit :: Literal -> Bool
448 isZeroLit (LitNumber _ 0 _) = True
449 isZeroLit (LitFloat 0) = True
450 isZeroLit (LitDouble 0) = True
451 isZeroLit _ = False
452
453 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
454 -- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
455 litValue :: Literal -> Integer
456 litValue l = case isLitValue_maybe l of
457 Just x -> x
458 Nothing -> pprPanic "litValue" (ppr l)
459
460 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
461 -- sense, i.e. for 'Char' and numbers.
462 isLitValue_maybe :: Literal -> Maybe Integer
463 isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c
464 isLitValue_maybe (LitNumber _ i _) = Just i
465 isLitValue_maybe _ = Nothing
466
467 -- | Apply a function to the 'Integer' contained in the 'Literal', for when that
468 -- makes sense, e.g. for 'Char' and numbers.
469 -- For fixed-size integral literals, the result will be wrapped in accordance
470 -- with the semantics of the target type.
471 -- See Note [Word/Int underflow/overflow]
472 mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
473 mapLitValue _ f (LitChar c) = mkLitChar (fchar c)
474 where fchar = chr . fromInteger . f . toInteger . ord
475 mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
476 (LitNumber nt (f i) t)
477 mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
478
479 -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
480 -- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
481 isLitValue :: Literal -> Bool
482 isLitValue = isJust . isLitValue_maybe
483
484 {-
485 Coercions
486 ~~~~~~~~~
487 -}
488
489 narrow8IntLit, narrow16IntLit, narrow32IntLit,
490 narrow8WordLit, narrow16WordLit, narrow32WordLit,
491 char2IntLit, int2CharLit,
492 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
493 float2DoubleLit, double2FloatLit
494 :: Literal -> Literal
495
496 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
497 word2IntLit dflags (LitNumber LitNumWord w _)
498 -- Map Word range [max_int+1, max_word]
499 -- to Int range [min_int , -1]
500 -- Range [0,max_int] has the same representation with both Int and Word
501 | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1)
502 | otherwise = mkLitInt dflags w
503 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
504
505 int2WordLit dflags (LitNumber LitNumInt i _)
506 -- Map Int range [min_int , -1]
507 -- to Word range [max_int+1, max_word]
508 -- Range [0,max_int] has the same representation with both Int and Word
509 | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i)
510 | otherwise = mkLitWord dflags i
511 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
512
513 -- | Narrow a literal number (unchecked result range)
514 narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
515 narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
516 narrowLit _ l = pprPanic "narrowLit" (ppr l)
517
518 narrow8IntLit = narrowLit (Proxy :: Proxy Int8)
519 narrow16IntLit = narrowLit (Proxy :: Proxy Int16)
520 narrow32IntLit = narrowLit (Proxy :: Proxy Int32)
521 narrow8WordLit = narrowLit (Proxy :: Proxy Word8)
522 narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
523 narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
524
525 char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c))
526 char2IntLit l = pprPanic "char2IntLit" (ppr l)
527 int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))
528 int2CharLit l = pprPanic "int2CharLit" (ppr l)
529
530 float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f)
531 float2IntLit l = pprPanic "float2IntLit" (ppr l)
532 int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)
533 int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
534
535 double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f)
536 double2IntLit l = pprPanic "double2IntLit" (ppr l)
537 int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)
538 int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
539
540 float2DoubleLit (LitFloat f) = LitDouble f
541 float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
542 double2FloatLit (LitDouble d) = LitFloat d
543 double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
544
545 nullAddrLit :: Literal
546 nullAddrLit = LitNullAddr
547
548 -- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.
549 rubbishLit :: Literal
550 rubbishLit = LitRubbish
551
552 {-
553 Predicates
554 ~~~~~~~~~~
555 -}
556
557 -- | True if there is absolutely no penalty to duplicating the literal.
558 -- False principally of strings.
559 --
560 -- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would
561 -- blow up code sizes. Not only this, it's also unsafe.
562 --
563 -- Consider a program that wants to traverse a string. One way it might do this
564 -- is to first compute the Addr# pointing to the end of the string, and then,
565 -- starting from the beginning, bump a pointer using eqAddr# to determine the
566 -- end. For instance,
567 --
568 -- @
569 -- -- Given pointers to the start and end of a string, count how many zeros
570 -- -- the string contains.
571 -- countZeros :: Addr# -> Addr# -> -> Int
572 -- countZeros start end = go start 0
573 -- where
574 -- go off n
575 -- | off `addrEq#` end = n
576 -- | otherwise = go (off `plusAddr#` 1) n'
577 -- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1
578 -- | otherwise = n
579 -- @
580 --
581 -- Consider what happens if we considered strings to be trivial (and therefore
582 -- duplicable) and emitted a call like @countZeros "hello"# ("hello"#
583 -- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same
584 -- string, meaning that an iteration like the above would blow up terribly.
585 -- This is what happened in #12757.
586 --
587 -- Ultimately the solution here is to make primitive strings a bit more
588 -- structured, ensuring that the compiler can't inline in ways that will break
589 -- user code. One approach to this is described in #8472.
590 litIsTrivial :: Literal -> Bool
591 -- c.f. CoreUtils.exprIsTrivial
592 litIsTrivial (LitString _) = False
593 litIsTrivial (LitNumber nt _ _) = case nt of
594 LitNumInteger -> False
595 LitNumNatural -> False
596 LitNumInt -> True
597 LitNumInt64 -> True
598 LitNumWord -> True
599 LitNumWord64 -> True
600 litIsTrivial _ = True
601
602 -- | True if code space does not go bad if we duplicate this literal
603 litIsDupable :: DynFlags -> Literal -> Bool
604 -- c.f. CoreUtils.exprIsDupable
605 litIsDupable _ (LitString _) = False
606 litIsDupable dflags (LitNumber nt i _) = case nt of
607 LitNumInteger -> inIntRange dflags i
608 LitNumNatural -> inIntRange dflags i
609 LitNumInt -> True
610 LitNumInt64 -> True
611 LitNumWord -> True
612 LitNumWord64 -> True
613 litIsDupable _ _ = True
614
615 litFitsInChar :: Literal -> Bool
616 litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
617 && i <= toInteger (ord maxBound)
618 litFitsInChar _ = False
619
620 litIsLifted :: Literal -> Bool
621 litIsLifted (LitNumber nt _ _) = case nt of
622 LitNumInteger -> True
623 LitNumNatural -> True
624 LitNumInt -> False
625 LitNumInt64 -> False
626 LitNumWord -> False
627 LitNumWord64 -> False
628 litIsLifted _ = False
629
630 {-
631 Types
632 ~~~~~
633 -}
634
635 -- | Find the Haskell 'Type' the literal occupies
636 literalType :: Literal -> Type
637 literalType LitNullAddr = addrPrimTy
638 literalType (LitChar _) = charPrimTy
639 literalType (LitString _) = addrPrimTy
640 literalType (LitFloat _) = floatPrimTy
641 literalType (LitDouble _) = doublePrimTy
642 literalType (LitLabel _ _ _) = addrPrimTy
643 literalType (LitNumber _ _ t) = t
644 literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a)
645 where
646 a = alphaTyVarUnliftedRep
647
648 absentLiteralOf :: TyCon -> Maybe Literal
649 -- Return a literal of the appropriate primitive
650 -- TyCon, to use as a placeholder when it doesn't matter
651 -- Rubbish literals are handled in WwLib, because
652 -- 1. Looking at the TyCon is not enough, we need the actual type
653 -- 2. This would need to return a type application to a literal
654 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
655
656 absent_lits :: UniqFM Literal
657 absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr)
658 , (charPrimTyConKey, LitChar 'x')
659 , (intPrimTyConKey, mkLitIntUnchecked 0)
660 , (int64PrimTyConKey, mkLitInt64Unchecked 0)
661 , (wordPrimTyConKey, mkLitWordUnchecked 0)
662 , (word64PrimTyConKey, mkLitWord64Unchecked 0)
663 , (floatPrimTyConKey, LitFloat 0)
664 , (doublePrimTyConKey, LitDouble 0)
665 ]
666
667 {-
668 Comparison
669 ~~~~~~~~~~
670 -}
671
672 cmpLit :: Literal -> Literal -> Ordering
673 cmpLit (LitChar a) (LitChar b) = a `compare` b
674 cmpLit (LitString a) (LitString b) = a `compare` b
675 cmpLit (LitNullAddr) (LitNullAddr) = EQ
676 cmpLit (LitFloat a) (LitFloat b) = a `compare` b
677 cmpLit (LitDouble a) (LitDouble b) = a `compare` b
678 cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b
679 cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _)
680 | nt1 == nt2 = a `compare` b
681 | otherwise = nt1 `compare` nt2
682 cmpLit (LitRubbish) (LitRubbish) = EQ
683 cmpLit lit1 lit2
684 | litTag lit1 < litTag lit2 = LT
685 | otherwise = GT
686
687 litTag :: Literal -> Int
688 litTag (LitChar _) = 1
689 litTag (LitString _) = 2
690 litTag (LitNullAddr) = 3
691 litTag (LitFloat _) = 4
692 litTag (LitDouble _) = 5
693 litTag (LitLabel _ _ _) = 6
694 litTag (LitNumber {}) = 7
695 litTag (LitRubbish) = 8
696
697 {-
698 Printing
699 ~~~~~~~~
700 * See Note [Printing of literals in Core]
701 -}
702
703 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
704 pprLiteral _ (LitChar c) = pprPrimChar c
705 pprLiteral _ (LitString s) = pprHsBytes s
706 pprLiteral _ (LitNullAddr) = text "__NULL"
707 pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix
708 pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix
709 pprLiteral add_par (LitNumber nt i _)
710 = case nt of
711 LitNumInteger -> pprIntegerVal add_par i
712 LitNumNatural -> pprIntegerVal add_par i
713 LitNumInt -> pprPrimInt i
714 LitNumInt64 -> pprPrimInt64 i
715 LitNumWord -> pprPrimWord i
716 LitNumWord64 -> pprPrimWord64 i
717 pprLiteral add_par (LitLabel l mb fod) =
718 add_par (text "__label" <+> b <+> ppr fod)
719 where b = case mb of
720 Nothing -> pprHsString l
721 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
722 pprLiteral _ (LitRubbish) = text "__RUBBISH"
723
724 pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
725 -- See Note [Printing of literals in Core].
726 pprIntegerVal add_par i | i < 0 = add_par (integer i)
727 | otherwise = integer i
728
729 {-
730 Note [Printing of literals in Core]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
732 The function `add_par` is used to wrap parenthesis around negative integers
733 (`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring
734 an atomic thing (for example function application).
735
736 Although not all Core literals would be valid Haskell, we are trying to stay
737 as close as possible to Haskell syntax in the printing of Core, to make it
738 easier for a Haskell user to read Core.
739
740 To that end:
741 * We do print parenthesis around negative `LitInteger`, because we print
742 `LitInteger` using plain number literals (no prefix or suffix), and plain
743 number literals in Haskell require parenthesis in contexts like function
744 application (i.e. `1 - -1` is not valid Haskell).
745
746 * We don't print parenthesis around other (negative) literals, because they
747 aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
748 parser).
749
750 Literal Output Output if context requires
751 an atom (if different)
752 ------- ------- ----------------------
753 LitChar 'a'#
754 LitString "aaa"#
755 LitNullAddr "__NULL"
756 LitInt -1#
757 LitInt64 -1L#
758 LitWord 1##
759 LitWord64 1L##
760 LitFloat -1.0#
761 LitDouble -1.0##
762 LitInteger -1 (-1)
763 LitLabel "__label" ... ("__label" ...)
764 LitRubbish "__RUBBISH"
765
766 Note [Rubbish literals]
767 ~~~~~~~~~~~~~~~~~~~~~~~
768 During worker/wrapper after demand analysis, where an argument
769 is unused (absent) we do the following w/w split (supposing that
770 y is absent):
771
772 f x y z = e
773 ===>
774 f x y z = $wf x z
775 $wf x z = let y = <absent value>
776 in e
777
778 Usually the binding for y is ultimately optimised away, and
779 even if not it should never be evaluated -- but that's the
780 way the w/w split starts off.
781
782 What is <absent value>?
783 * For lifted values <absent value> can be a call to 'error'.
784 * For primitive types like Int# or Word# we can use any random
785 value of that type.
786 * But what about /unlifted/ but /boxed/ types like MutVar# or
787 Array#? We need a literal value of that type.
788
789 That is 'LitRubbish'. Since we need a rubbish literal for
790 many boxed, unlifted types, we say that LitRubbish has type
791 LitRubbish :: forall (a :: TYPE UnliftedRep). a
792
793 So we might see a w/w split like
794 $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)
795 in e
796
797 Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted
798 heap pointers.
799
800 Here are the moving parts:
801
802 * We define LitRubbish as a constructor in Literal.Literal
803
804 * It is given its polymoprhic type by Literal.literalType
805
806 * WwLib.mk_absent_let introduces a LitRubbish for absent
807 arguments of boxed, unlifted type.
808
809 * In CoreToSTG we convert (RubishLit @t) to just (). STG is
810 untyped, so it doesn't matter that it points to a lifted
811 value. The important thing is that it is a heap pointer,
812 which the garbage collector can follow if it encounters it.
813
814 We considered maintaining LitRubbish in STG, and lowering
815 it in the code genreators, but it seems simpler to do it
816 once and for all in CoreToSTG.
817
818 In ByteCodeAsm we just lower it as a 0 literal, because
819 it's all boxed and lifted to the host GC anyway.
820 -}