Literal.hs 30.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1998

Sylvain Henry's avatar
Sylvain Henry committed
5
\section[Literal]{@Literal@: literals}
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

8
{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
9

10
module Literal
11
12
13
        (
        -- * Main data type
          Literal(..)           -- Exported to ParseIface
14
        , LitNumType(..)
15
16

        -- ** Creating Literals
Sylvain Henry's avatar
Sylvain Henry committed
17
18
19
20
21
22
        , mkLitInt, mkLitIntWrap, mkLitIntWrapC
        , mkLitWord, mkLitWordWrap, mkLitWordWrapC
        , mkLitInt64, mkLitInt64Wrap
        , mkLitWord64, mkLitWord64Wrap
        , mkLitFloat, mkLitDouble
        , mkLitChar, mkLitString
23
24
        , mkLitInteger, mkLitNatural
        , mkLitNumber, mkLitNumberWrap
25
26
27

        -- ** Operations on Literals
        , literalType
28
        , absentLiteralOf
29
        , pprLiteral
30
31
        , litNumIsSigned
        , litNumCheckRange
32

33
        -- ** Predicates on Literals and their contents
34
        , litIsDupable, litIsTrivial, litIsLifted
35
36
37
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
        , isZeroLit
        , litFitsInChar
Sylvain Henry's avatar
Sylvain Henry committed
38
        , litValue, isLitValue, isLitValue_maybe, mapLitValue
39

40
        -- ** Coercions
41
        , word2IntLit, int2WordLit
42
        , narrowLit
43
44
45
46
        , narrow8IntLit, narrow16IntLit, narrow32IntLit
        , narrow8WordLit, narrow16WordLit, narrow32WordLit
        , char2IntLit, int2CharLit
        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
47
        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit
48
        ) where
49

Ian Lynagh's avatar
Ian Lynagh committed
50
51
#include "HsVersions.h"

52
53
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
54
import TysPrim
55
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
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
67
import Util

68
import Data.ByteString (ByteString)
Simon Marlow's avatar
Simon Marlow committed
69
70
71
import Data.Int
import Data.Word
import Data.Char
Sylvain Henry's avatar
Sylvain Henry committed
72
import Data.Maybe ( isJust )
73
import Data.Data ( Data )
74
import Data.Proxy
75
import Numeric ( fromRat )
76

Austin Seipp's avatar
Austin Seipp committed
77
78
79
{-
************************************************************************
*                                                                      *
80
\subsection{Literals}
Austin Seipp's avatar
Austin Seipp committed
81
82
83
*                                                                      *
************************************************************************
-}
84

85
86
-- | So-called 'Literal's are one of:
--
Sylvain Henry's avatar
Sylvain Henry committed
87
88
89
-- * An unboxed numeric literal or floating-point literal which is presumed
--   to be surrounded by appropriate constructors (@Int#@, etc.), so that
--   the overall thing makes sense.
90
--
Sylvain Henry's avatar
Sylvain Henry committed
91
92
93
--   We maintain the invariant that the 'Integer' in the 'LitNumber'
--   constructor is actually in the (possibly target-dependent) range.
--   The mkLit{Int,Word}*Wrap smart constructors ensure this by applying
94
95
96
--   the target machine's wrapping semantics. Use these in situations
--   where you know the wrapping semantics are correct.
--
97
-- * The literal derived from the label mentioned in a \"foreign label\"
Sylvain Henry's avatar
Sylvain Henry committed
98
--   declaration ('LitLabel')
99
--
Sylvain Henry's avatar
Sylvain Henry committed
100
-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'
101
--   (i.e. 'MutVar#') when the the value is never used.
Sylvain Henry's avatar
Sylvain Henry committed
102
103
104
105
106
--
-- * A character
-- * A string
-- * The NULL pointer
--
107
data Literal
Sylvain Henry's avatar
Sylvain Henry committed
108
109
  = LitChar    Char             -- ^ @Char#@ - at least 31 bits. Create with
                                -- 'mkLitChar'
110

111
  | LitNumber !LitNumType !Integer Type
Sylvain Henry's avatar
Sylvain Henry committed
112
113
                                -- ^ Any numeric literal that can be
                                -- internally represented with an Integer
114

Sylvain Henry's avatar
Sylvain Henry committed
115
  | LitString  ByteString       -- ^ A string-literal: stored and emitted
116
117
                                -- UTF-8 encoded, we'll arrange to decode it
                                -- at runtime.  Also emitted with a @'\0'@
Sylvain Henry's avatar
Sylvain Henry committed
118
                                -- terminator. Create with 'mkLitString'
119

Sylvain Henry's avatar
Sylvain Henry committed
120
  | LitNullAddr                 -- ^ The @NULL@ pointer, the only pointer value
121
                                -- that can be represented as a Literal. Create
122
123
                                -- with 'nullAddrLit'

Sylvain Henry's avatar
Sylvain Henry committed
124
  | LitRubbish                  -- ^ A nonsense value, used when an unlifted
125
126
127
                                -- binding is absent and has type
                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.
                                -- May be lowered by code-gen to any possible
Sylvain Henry's avatar
Sylvain Henry committed
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
                                -- value. Also see Note [Rubbish literals]

  | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'
  | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'

  | LitLabel   FastString (Maybe Int) FunctionOrData
                                -- ^ A label literal. Parameters:
                                --
                                -- 1) The name of the symbol mentioned in the
                                --    declaration
                                --
                                -- 2) The size (in bytes) of the arguments
                                --    the label expects. Only applicable with
                                --    @stdcall@ labels. @Just x@ => @\<x\>@ will
                                --    be appended to label name when emitting
                                --    assembly.
                                --
                                -- 3) Flag indicating whether the symbol
                                --    references a function or a data
147
  deriving Data
148

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
-- | Numeric literal type
data LitNumType
  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
  | LitNumInt     -- ^ @Int#@ - according to target machine
  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits
  | LitNumWord    -- ^ @Word#@ - according to target machine
  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
  deriving (Data,Enum,Eq,Ord)

-- | Indicate if a numeric literal type supports negative numbers
litNumIsSigned :: LitNumType -> Bool
litNumIsSigned nt = case nt of
  LitNumInteger -> True
  LitNumNatural -> False
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> False
  LitNumWord64  -> False

Austin Seipp's avatar
Austin Seipp committed
169
{-
170
171
172
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
173
174
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.
175

176
177
178
179
They only get converted into real Core,
    mkInteger [c1, c2, .., cn]
during the CorePrep phase, although TidyPgm looks ahead at what the
core will be, so that it can see whether it involves CAFs.
180

181
182
183
184
185
When we initally build an Integer literal, notably when
deserialising it from an interface file (see the Binary instance
below), we don't have convenient access to the mkInteger Id.  So we
just use an error thunk, and fill in the real Id when we do tcIfaceLit
in TcIface.
186

187
188
189
Note [Natural literals]
~~~~~~~~~~~~~~~~~~~~~~~
Similar to Integer literals.
190

Austin Seipp's avatar
Austin Seipp committed
191
-}
192

193
194
195
196
197
198
instance Binary LitNumType where
   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
   get bh = do
      h <- getByte bh
      return (toEnum (fromIntegral h))

199
instance Binary Literal where
Sylvain Henry's avatar
Sylvain Henry committed
200
201
202
203
204
205
    put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa
    put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab
    put_ bh (LitNullAddr)    = do putByte bh 2
    put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah
    put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai
    put_ bh (LitLabel aj mb fod)
206
        = do putByte bh 5
207
208
209
             put_ bh aj
             put_ bh mb
             put_ bh fod
210
211
212
213
    put_ bh (LitNumber nt i _)
        = do putByte bh 6
             put_ bh nt
             put_ bh i
Sylvain Henry's avatar
Sylvain Henry committed
214
    put_ bh (LitRubbish)     = do putByte bh 7
215
    get bh = do
216
217
218
219
            h <- getByte bh
            case h of
              0 -> do
                    aa <- get bh
Sylvain Henry's avatar
Sylvain Henry committed
220
                    return (LitChar aa)
221
222
              1 -> do
                    ab <- get bh
Sylvain Henry's avatar
Sylvain Henry committed
223
                    return (LitString ab)
224
              2 -> do
Sylvain Henry's avatar
Sylvain Henry committed
225
                    return (LitNullAddr)
226
227
              3 -> do
                    ah <- get bh
Sylvain Henry's avatar
Sylvain Henry committed
228
                    return (LitFloat ah)
229
              4 -> do
230
                    ai <- get bh
Sylvain Henry's avatar
Sylvain Henry committed
231
                    return (LitDouble ai)
232
              5 -> do
233
234
235
                    aj <- get bh
                    mb <- get bh
                    fod <- get bh
Sylvain Henry's avatar
Sylvain Henry committed
236
                    return (LitLabel aj mb fod)
237
              6 -> do
238
239
240
241
242
243
244
245
246
247
248
249
250
251
                    nt <- get bh
                    i  <- get bh
                    let t = case nt of
                            LitNumInt     -> intPrimTy
                            LitNumInt64   -> int64PrimTy
                            LitNumWord    -> wordPrimTy
                            LitNumWord64  -> word64PrimTy
                            -- See Note [Integer literals]
                            LitNumInteger ->
                              panic "Evaluated the place holder for mkInteger"
                            -- and Note [Natural literals]
                            LitNumNatural ->
                              panic "Evaluated the place holder for mkNatural"
                    return (LitNumber nt i t)
252
              _ -> do
Sylvain Henry's avatar
Sylvain Henry committed
253
                    return (LitRubbish)
254

255
instance Outputable Literal where
256
    ppr lit = pprLiteral (\d -> d) lit
257
258
259
260
261

instance Eq Literal where
    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }

262
263
-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in
-- 'TrieMap.CoreMap'.
264
265
instance Ord Literal where
    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
270
    compare a b = cmpLit a b

Austin Seipp's avatar
Austin Seipp committed
271
{-
272
273
        Construction
        ~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
274
275
-}

276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
{- Note [Word/Int underflow/overflow]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
the number of bits in the type."

GHC stores Word# and Int# constant values as Integer. Core optimizations such
as constant folding must ensure that the Integer value remains in the valid
target Word/Int range (see #13172). The following functions are used to
ensure this.

Note that we *don't* warn the user about overflow. It's not done at runtime
either, and compilation of completely harmless things like
   ((124076834 :: Word32) + (2147483647 :: Word32))
doesn't yield a warning. Instead we simply squash the value into the *target*
Int/Word range.
-}

294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
-- | Wrap a literal number according to its type
wrapLitNumber :: DynFlags -> Literal -> Literal
wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
  LitNumInt -> case platformWordSize (targetPlatform dflags) of
    4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
    8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
  LitNumWord -> case platformWordSize (targetPlatform dflags) of
    4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
    8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
  LitNumInteger -> v
  LitNumNatural -> v
wrapLitNumber _ x = x

-- | Create a numeric 'Literal' of the given type
mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)

-- | Check that a given number is in the range of a numeric literal
litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
litNumCheckRange dflags nt i = case nt of
     LitNumInt     -> inIntRange dflags i
     LitNumWord    -> inWordRange dflags i
     LitNumInt64   -> inInt64Range i
     LitNumWord64  -> inWord64Range i
     LitNumNatural -> i >= 0
     LitNumInteger -> True

-- | Create a numeric 'Literal' of the given type
mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
mkLitNumber dflags nt i t =
  ASSERT2(litNumCheckRange dflags nt i, integer i)
  (LitNumber nt i t)

331
-- | Creates a 'Literal' of type @Int#@
Sylvain Henry's avatar
Sylvain Henry committed
332
333
334
mkLitInt :: DynFlags -> Integer -> Literal
mkLitInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
                       (mkLitIntUnchecked x)
335

336
337
-- | Creates a 'Literal' of type @Int#@.
--   If the argument is out of the (target-dependent) range, it is wrapped.
338
--   See Note [Word/Int underflow/overflow]
Sylvain Henry's avatar
Sylvain Henry committed
339
340
mkLitIntWrap :: DynFlags -> Integer -> Literal
mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i
341
342

-- | Creates a 'Literal' of type @Int#@ without checking its range.
Sylvain Henry's avatar
Sylvain Henry committed
343
344
mkLitIntUnchecked :: Integer -> Literal
mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy
345
346
347
348
349

-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
--   overflow. That is, if the argument is out of the (target-dependent) range
--   the argument is wrapped and the overflow flag will be set.
--   See Note [Word/Int underflow/overflow]
Sylvain Henry's avatar
Sylvain Henry committed
350
351
mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
mkLitIntWrapC dflags i = (n, i /= i')
352
  where
Sylvain Henry's avatar
Sylvain Henry committed
353
    n@(LitNumber _ i' _) = mkLitIntWrap dflags i
354

355
-- | Creates a 'Literal' of type @Word#@
Sylvain Henry's avatar
Sylvain Henry committed
356
357
358
mkLitWord :: DynFlags -> Integer -> Literal
mkLitWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
                        (mkLitWordUnchecked x)
359

360
361
-- | Creates a 'Literal' of type @Word#@.
--   If the argument is out of the (target-dependent) range, it is wrapped.
362
--   See Note [Word/Int underflow/overflow]
Sylvain Henry's avatar
Sylvain Henry committed
363
364
mkLitWordWrap :: DynFlags -> Integer -> Literal
mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i
365
366

-- | Creates a 'Literal' of type @Word#@ without checking its range.
Sylvain Henry's avatar
Sylvain Henry committed
367
368
mkLitWordUnchecked :: Integer -> Literal
mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy
369
370
371
372
373

-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
--   carry. That is, if the argument is out of the (target-dependent) range
--   the argument is wrapped and the carry flag will be set.
--   See Note [Word/Int underflow/overflow]
Sylvain Henry's avatar
Sylvain Henry committed
374
375
mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
mkLitWordWrapC dflags i = (n, i /= i')
376
  where
Sylvain Henry's avatar
Sylvain Henry committed
377
    n@(LitNumber _ i' _) = mkLitWordWrap dflags i
378

379
-- | Creates a 'Literal' of type @Int64#@
Sylvain Henry's avatar
Sylvain Henry committed
380
381
mkLitInt64 :: Integer -> Literal
mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)
382
383
384

-- | Creates a 'Literal' of type @Int64#@.
--   If the argument is out of the range, it is wrapped.
Sylvain Henry's avatar
Sylvain Henry committed
385
386
mkLitInt64Wrap :: DynFlags -> Integer -> Literal
mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i
387
388

-- | Creates a 'Literal' of type @Int64#@ without checking its range.
Sylvain Henry's avatar
Sylvain Henry committed
389
390
mkLitInt64Unchecked :: Integer -> Literal
mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
391
392

-- | Creates a 'Literal' of type @Word64#@
Sylvain Henry's avatar
Sylvain Henry committed
393
394
mkLitWord64 :: Integer -> Literal
mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)
395
396
397

-- | Creates a 'Literal' of type @Word64#@.
--   If the argument is out of the range, it is wrapped.
Sylvain Henry's avatar
Sylvain Henry committed
398
399
mkLitWord64Wrap :: DynFlags -> Integer -> Literal
mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i
400
401

-- | Creates a 'Literal' of type @Word64#@ without checking its range.
Sylvain Henry's avatar
Sylvain Henry committed
402
403
mkLitWord64Unchecked :: Integer -> Literal
mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
404

405
-- | Creates a 'Literal' of type @Float#@
Sylvain Henry's avatar
Sylvain Henry committed
406
407
mkLitFloat :: Rational -> Literal
mkLitFloat = LitFloat
408
409

-- | Creates a 'Literal' of type @Double#@
Sylvain Henry's avatar
Sylvain Henry committed
410
411
mkLitDouble :: Rational -> Literal
mkLitDouble = LitDouble
412
413

-- | Creates a 'Literal' of type @Char#@
Sylvain Henry's avatar
Sylvain Henry committed
414
415
mkLitChar :: Char -> Literal
mkLitChar = LitChar
416
417
418

-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
Sylvain Henry's avatar
Sylvain Henry committed
419
mkLitString :: String -> Literal
420
-- stored UTF-8 encoded
Sylvain Henry's avatar
Sylvain Henry committed
421
mkLitString s = LitString (fastStringToByteString $ mkFastString s)
422

423
mkLitInteger :: Integer -> Type -> Literal
424
425
426
427
428
mkLitInteger x ty = LitNumber LitNumInteger x ty

mkLitNatural :: Integer -> Type -> Literal
mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
                    (LitNumber LitNumNatural x ty)
429

430
431
432
inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags
433

434
435
436
inNaturalRange :: Integer -> Bool
inNaturalRange x = x >= 0

437
438
439
440
441
442
inInt64Range, inWord64Range :: Integer -> Bool
inInt64Range x  = x >= toInteger (minBound :: Int64) &&
                  x <= toInteger (maxBound :: Int64)
inWord64Range x = x >= toInteger (minBound :: Word64) &&
                  x <= toInteger (maxBound :: Word64)

443
444
inCharRange :: Char -> Bool
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
Sylvain Henry's avatar
Sylvain Henry committed
449
450
isZeroLit (LitFloat  0)     = True
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
Sylvain Henry's avatar
Sylvain Henry committed
456
457
458
459
460
litValue l = case isLitValue_maybe l of
   Just x  -> x
   Nothing -> pprPanic "litValue" (ppr l)

-- | Returns the 'Integer' contained in the 'Literal', for when that makes
461
-- sense, i.e. for 'Char' and numbers.
Sylvain Henry's avatar
Sylvain Henry committed
462
isLitValue_maybe  :: Literal -> Maybe Integer
Sylvain Henry's avatar
Sylvain Henry committed
463
isLitValue_maybe (LitChar   c)     = Just $ toInteger $ ord c
464
465
isLitValue_maybe (LitNumber _ i _) = Just i
isLitValue_maybe _                 = Nothing
Sylvain Henry's avatar
Sylvain Henry committed
466
467

-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
468
469
470
-- makes sense, e.g. for 'Char' and numbers.
-- For fixed-size integral literals, the result will be wrapped in accordance
-- with the semantics of the target type.
471
-- See Note [Word/Int underflow/overflow]
472
mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
Sylvain Henry's avatar
Sylvain Henry committed
473
mapLitValue _      f (LitChar   c)      = mkLitChar (fchar c)
Sylvain Henry's avatar
Sylvain Henry committed
474
   where fchar = chr . fromInteger . f . toInteger . ord
475
476
477
mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
                                                        (LitNumber nt (f i) t)
mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)
Sylvain Henry's avatar
Sylvain Henry committed
478
479

-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
480
-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
Sylvain Henry's avatar
Sylvain Henry committed
481
482
isLitValue  :: Literal -> Bool
isLitValue = isJust . isLitValue_maybe
483

Austin Seipp's avatar
Austin Seipp committed
484
{-
485
486
        Coercions
        ~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
487
488
-}

489
narrow8IntLit, narrow16IntLit, narrow32IntLit,
apt's avatar
apt committed
490
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
491
492
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
apt's avatar
apt committed
493
  float2DoubleLit, double2FloatLit
494
  :: Literal -> Literal
495

496
word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
497
word2IntLit dflags (LitNumber LitNumWord w _)
Sylvain Henry's avatar
Sylvain Henry committed
498
499
500
501
502
  -- Map Word range [max_int+1, max_word]
  -- to Int range   [min_int  , -1]
  -- Range [0,max_int] has the same representation with both Int and Word
  | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1)
  | otherwise                 = mkLitInt dflags w
503
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
504

505
int2WordLit dflags (LitNumber LitNumInt i _)
Sylvain Henry's avatar
Sylvain Henry committed
506
507
508
509
510
  -- Map Int range [min_int  , -1]
  -- to Word range [max_int+1, max_word]
  -- Range [0,max_int] has the same representation with both Int and Word
  | i < 0     = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i)
  | otherwise = mkLitWord dflags i
511
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
512

513
514
515
516
517
518
519
520
521
522
523
524
-- | Narrow a literal number (unchecked result range)
narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
narrowLit _ l                  = pprPanic "narrowLit" (ppr l)

narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)
narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)
narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)
narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)
narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
narrow32WordLit = narrowLit (Proxy :: Proxy Word32)

Sylvain Henry's avatar
Sylvain Henry committed
525
526
527
char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))
char2IntLit l                 = pprPanic "char2IntLit" (ppr l)
int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i))
528
int2CharLit l                 = pprPanic "int2CharLit" (ppr l)
529

Sylvain Henry's avatar
Sylvain Henry committed
530
531
532
float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)
float2IntLit l                 = pprPanic "float2IntLit" (ppr l)
int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i)
533
int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)
534

Sylvain Henry's avatar
Sylvain Henry committed
535
536
537
double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)
double2IntLit l                 = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i)
538
int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)
539

Sylvain Henry's avatar
Sylvain Henry committed
540
541
542
543
float2DoubleLit (LitFloat  f) = LitDouble f
float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)
double2FloatLit (LitDouble d) = LitFloat  d
double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)
apt's avatar
apt committed
544
545

nullAddrLit :: Literal
Sylvain Henry's avatar
Sylvain Henry committed
546
nullAddrLit = LitNullAddr
547

548
549
-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.
rubbishLit :: Literal
Sylvain Henry's avatar
Sylvain Henry committed
550
rubbishLit = LitRubbish
551

Austin Seipp's avatar
Austin Seipp committed
552
{-
553
554
        Predicates
        ~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
555
556
-}

557
-- | True if there is absolutely no penalty to duplicating the literal.
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
-- False principally of strings.
--
-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would
-- blow up code sizes. Not only this, it's also unsafe.
--
-- Consider a program that wants to traverse a string. One way it might do this
-- is to first compute the Addr# pointing to the end of the string, and then,
-- starting from the beginning, bump a pointer using eqAddr# to determine the
-- end. For instance,
--
-- @
-- -- Given pointers to the start and end of a string, count how many zeros
-- -- the string contains.
-- countZeros :: Addr# -> Addr# -> -> Int
-- countZeros start end = go start 0
--   where
--     go off n
--       | off `addrEq#` end = n
--       | otherwise         = go (off `plusAddr#` 1) n'
--       where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1
--                | otherwise                                 = n
-- @
--
-- Consider what happens if we considered strings to be trivial (and therefore
-- duplicable) and emitted a call like @countZeros "hello"# ("hello"#
-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same
-- string, meaning that an iteration like the above would blow up terribly.
-- This is what happened in #12757.
--
-- Ultimately the solution here is to make primitive strings a bit more
-- structured, ensuring that the compiler can't inline in ways that will break
-- user code. One approach to this is described in #8472.
590
litIsTrivial :: Literal -> Bool
591
--      c.f. CoreUtils.exprIsTrivial
Sylvain Henry's avatar
Sylvain Henry committed
592
litIsTrivial (LitString _)      = False
593
594
595
596
597
598
599
litIsTrivial (LitNumber nt _ _) = case nt of
  LitNumInteger -> False
  LitNumNatural -> False
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> True
  LitNumWord64  -> True
Sylvain Henry's avatar
Sylvain Henry committed
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
Sylvain Henry's avatar
Sylvain Henry committed
605
litIsDupable _      (LitString _)      = False
606
607
608
609
610
611
612
litIsDupable dflags (LitNumber nt i _) = case nt of
  LitNumInteger -> inIntRange dflags i
  LitNumNatural -> inIntRange dflags i
  LitNumInt     -> True
  LitNumInt64   -> True
  LitNumWord    -> True
  LitNumWord64  -> True
Sylvain Henry's avatar
Sylvain Henry committed
613
litIsDupable _      _                  = True
614

615
litFitsInChar :: Literal -> Bool
616
617
618
litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
                               && i <= toInteger (ord maxBound)
litFitsInChar _                 = False
619
620

litIsLifted :: Literal -> Bool
621
622
623
624
625
626
627
litIsLifted (LitNumber nt _ _) = case nt of
  LitNumInteger -> True
  LitNumNatural -> True
  LitNumInt     -> False
  LitNumInt64   -> False
  LitNumWord    -> False
  LitNumWord64  -> False
Sylvain Henry's avatar
Sylvain Henry committed
628
litIsLifted _                  = False
629

Austin Seipp's avatar
Austin Seipp committed
630
{-
631
632
        Types
        ~~~~~
Austin Seipp's avatar
Austin Seipp committed
633
634
-}

635
-- | Find the Haskell 'Type' the literal occupies
636
literalType :: Literal -> Type
Sylvain Henry's avatar
Sylvain Henry committed
637
638
639
640
641
642
literalType LitNullAddr       = addrPrimTy
literalType (LitChar _)       = charPrimTy
literalType (LitString  _)    = addrPrimTy
literalType (LitFloat _)      = floatPrimTy
literalType (LitDouble _)     = doublePrimTy
literalType (LitLabel _ _ _)  = addrPrimTy
643
literalType (LitNumber _ _ t) = t
Sylvain Henry's avatar
Sylvain Henry committed
644
literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)
645
646
  where
    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
Sylvain Henry's avatar
Sylvain Henry committed
651
-- Rubbish literals are handled in WwLib, because
652
653
--  1. Looking at the TyCon is not enough, we need the actual type
--  2. This would need to return a type application to a literal
654
655
656
absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)

absent_lits :: UniqFM Literal
Sylvain Henry's avatar
Sylvain Henry committed
657
658
659
660
661
662
663
664
absent_lits = listToUFM [ (addrPrimTyConKey,    LitNullAddr)
                        , (charPrimTyConKey,    LitChar 'x')
                        , (intPrimTyConKey,     mkLitIntUnchecked 0)
                        , (int64PrimTyConKey,   mkLitInt64Unchecked 0)
                        , (wordPrimTyConKey,    mkLitWordUnchecked 0)
                        , (word64PrimTyConKey,  mkLitWord64Unchecked 0)
                        , (floatPrimTyConKey,   LitFloat 0)
                        , (doublePrimTyConKey,  LitDouble 0)
665
                        ]
666

Austin Seipp's avatar
Austin Seipp committed
667
{-
668
669
        Comparison
        ~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
670
671
-}

672
cmpLit :: Literal -> Literal -> Ordering
Sylvain Henry's avatar
Sylvain Henry committed
673
674
675
676
677
678
679
cmpLit (LitChar      a)     (LitChar       b)     = a `compare` b
cmpLit (LitString    a)     (LitString     b)     = a `compare` b
cmpLit (LitNullAddr)        (LitNullAddr)         = EQ
cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b
cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b
cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b
cmpLit (LitNumber nt1 a _)  (LitNumber nt2  b _)
680
681
  | nt1 == nt2 = a   `compare` b
  | otherwise  = nt1 `compare` nt2
Sylvain Henry's avatar
Sylvain Henry committed
682
cmpLit (LitRubbish)         (LitRubbish)          = EQ
683
684
685
cmpLit lit1 lit2
  | litTag lit1 < litTag lit2 = LT
  | otherwise                 = GT
686
687

litTag :: Literal -> Int
Sylvain Henry's avatar
Sylvain Henry committed
688
689
690
691
692
693
694
695
litTag (LitChar      _)   = 1
litTag (LitString    _)   = 2
litTag (LitNullAddr)      = 3
litTag (LitFloat     _)   = 4
litTag (LitDouble    _)   = 5
litTag (LitLabel _ _ _)   = 6
litTag (LitNumber  {})    = 7
litTag (LitRubbish)       = 8
696

Austin Seipp's avatar
Austin Seipp committed
697
{-
698
699
        Printing
        ~~~~~~~~
700
* See Note [Printing of literals in Core]
Austin Seipp's avatar
Austin Seipp committed
701
-}
702

703
pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
Sylvain Henry's avatar
Sylvain Henry committed
704
705
706
707
708
pprLiteral _       (LitChar c)     = pprPrimChar c
pprLiteral _       (LitString s)   = pprHsBytes s
pprLiteral _       (LitNullAddr)   = text "__NULL"
pprLiteral _       (LitFloat f)    = float (fromRat f) <> primFloatSuffix
pprLiteral _       (LitDouble d)   = double (fromRat d) <> primDoubleSuffix
709
710
711
712
713
714
715
716
pprLiteral add_par (LitNumber nt i _)
   = case nt of
       LitNumInteger -> pprIntegerVal add_par i
       LitNumNatural -> pprIntegerVal add_par i
       LitNumInt     -> pprPrimInt i
       LitNumInt64   -> pprPrimInt64 i
       LitNumWord    -> pprPrimWord i
       LitNumWord64  -> pprPrimWord64 i
Sylvain Henry's avatar
Sylvain Henry committed
717
718
pprLiteral add_par (LitLabel l mb fod) =
    add_par (text "__label" <+> b <+> ppr fod)
719
720
721
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
Sylvain Henry's avatar
Sylvain Henry committed
722
pprLiteral _       (LitRubbish)     = text "__RUBBISH"
723

724
725
726
727
728
729
730
731
732
pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
-- See Note [Printing of literals in Core].
pprIntegerVal add_par i | i < 0     = add_par (integer i)
                        | otherwise = integer i

{-
Note [Printing of literals in Core]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The function `add_par` is used to wrap parenthesis around negative integers
Sylvain Henry's avatar
Sylvain Henry committed
733
(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
an atomic thing (for example function application).

Although not all Core literals would be valid Haskell, we are trying to stay
as close as possible to Haskell syntax in the printing of Core, to make it
easier for a Haskell user to read Core.

To that end:
  * We do print parenthesis around negative `LitInteger`, because we print
  `LitInteger` using plain number literals (no prefix or suffix), and plain
  number literals in Haskell require parenthesis in contexts like function
  application (i.e. `1 - -1` is not valid Haskell).

  * We don't print parenthesis around other (negative) literals, because they
  aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
  parser).

Literal         Output             Output if context requires
                                   an atom (if different)
-------         -------            ----------------------
Sylvain Henry's avatar
Sylvain Henry committed
753
754
755
756
757
758
759
760
761
LitChar         'a'#
LitString       "aaa"#
LitNullAddr     "__NULL"
LitInt          -1#
LitInt64        -1L#
LitWord          1##
LitWord64        1L##
LitFloat        -1.0#
LitDouble       -1.0##
762
LitInteger      -1                 (-1)
Sylvain Henry's avatar
Sylvain Henry committed
763
764
LitLabel        "__label" ...      ("__label" ...)
LitRubbish      "__RUBBISH"
765

Sylvain Henry's avatar
Sylvain Henry committed
766
767
Note [Rubbish literals]
~~~~~~~~~~~~~~~~~~~~~~~
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
During worker/wrapper after demand analysis, where an argument
is unused (absent) we do the following w/w split (supposing that
y is absent):

  f x y z = e
===>
  f x y z = $wf x z
  $wf x z = let y = <absent value>
            in e

Usually the binding for y is ultimately optimised away, and
even if not it should never be evaluated -- but that's the
way the w/w split starts off.

What is <absent value>?
* For lifted values <absent value> can be a call to 'error'.
* For primitive types like Int# or Word# we can use any random
  value of that type.
* But what about /unlifted/ but /boxed/ types like MutVar# or
  Array#?   We need a literal value of that type.

Sylvain Henry's avatar
Sylvain Henry committed
789
790
791
That is 'LitRubbish'.  Since we need a rubbish literal for
many boxed, unlifted types, we say that LitRubbish has type
  LitRubbish :: forall (a :: TYPE UnliftedRep). a
792
793

So we might see a w/w split like
Sylvain Henry's avatar
Sylvain Henry committed
794
  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)
795
796
797
798
799
800
801
            in e

Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted
heap pointers.

Here are the moving parts:

Sylvain Henry's avatar
Sylvain Henry committed
802
* We define LitRubbish as a constructor in Literal.Literal
803
804
805

* It is given its polymoprhic type by Literal.literalType

Sylvain Henry's avatar
Sylvain Henry committed
806
807
* WwLib.mk_absent_let introduces a LitRubbish for absent
  arguments of boxed, unlifted type.
808
809
810
811
812
813

* In CoreToSTG we convert (RubishLit @t) to just ().  STG is
  untyped, so it doesn't matter that it points to a lifted
  value. The important thing is that it is a heap pointer,
  which the garbage collector can follow if it encounters it.

Sylvain Henry's avatar
Sylvain Henry committed
814
  We considered maintaining LitRubbish in STG, and lowering
815
816
817
818
819
  it in the code genreators, but it seems simpler to do it
  once and for all in CoreToSTG.

  In ByteCodeAsm we just lower it as a 0 literal, because
  it's all boxed and lifted to the host GC anyway.
820
-}