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