Literal.hs 18.1 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

5
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
Austin Seipp's avatar
Austin Seipp committed
6
-}
7

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

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

        -- ** Creating Literals
        , mkMachInt, mkMachWord
        , mkMachInt64, mkMachWord64
        , mkMachFloat, mkMachDouble
        , mkMachChar, mkMachString
20
        , mkLitInteger
21 22 23

        -- ** Operations on Literals
        , literalType
24
        , absentLiteralOf
25
        , pprLiteral
26

27
        -- ** Predicates on Literals and their contents
28
        , litIsDupable, litIsTrivial, litIsLifted
29 30 31
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
        , isZeroLit
        , litFitsInChar
32
        , litValue
33

34
        -- ** Coercions
35 36 37 38 39 40 41
        , word2IntLit, int2WordLit
        , narrow8IntLit, narrow16IntLit, narrow32IntLit
        , narrow8WordLit, narrow16WordLit, narrow32WordLit
        , char2IntLit, int2CharLit
        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
        , nullAddrLit, float2DoubleLit, double2FloatLit
        ) where
42

Ian Lynagh's avatar
Ian Lynagh committed
43 44
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
45
import TysPrim
46
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
47
import Type
48
import TyCon
49
import Outputable
50
import FastString
51
import BasicTypes
52
import Binary
53
import Constants
54
import DynFlags
55
import UniqFM
56 57
import Util

58
import Data.ByteString (ByteString)
Simon Marlow's avatar
Simon Marlow committed
59 60 61
import Data.Int
import Data.Word
import Data.Char
62
import Data.Data ( Data )
63
import Numeric ( fromRat )
64

Austin Seipp's avatar
Austin Seipp committed
65 66 67
{-
************************************************************************
*                                                                      *
68
\subsection{Literals}
Austin Seipp's avatar
Austin Seipp committed
69 70 71
*                                                                      *
************************************************************************
-}
72

73 74 75 76 77 78
-- | So-called 'Literal's are one of:
--
-- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
--   which is presumed to be surrounded by appropriate constructors
--   (@Int#@, etc.), so that the overall thing makes sense.
--
79
-- * The literal derived from the label mentioned in a \"foreign label\"
80
--   declaration ('MachLabel')
81
data Literal
82 83 84
  =     ------------------
        -- First the primitive guys
    MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
85

86
  | MachStr     ByteString      -- ^ A string-literal: stored and emitted
87 88 89
                                -- UTF-8 encoded, we'll arrange to decode it
                                -- at runtime.  Also emitted with a @'\0'@
                                -- terminator. Create with 'mkMachString'
90 91

  | MachNullAddr                -- ^ The @NULL@ pointer, the only pointer value
92
                                -- that can be represented as a Literal. Create
93 94
                                -- with 'nullAddrLit'

95 96 97 98
  | MachInt     Integer         -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
  | MachInt64   Integer         -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
  | MachWord    Integer         -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
  | MachWord64  Integer         -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
99

100 101
  | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'
  | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'
102 103

  | MachLabel   FastString
104
                (Maybe Int)
105 106
        FunctionOrData
                -- ^ A label literal. Parameters:
107 108 109 110 111 112 113
                --
                -- 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.
114

115 116
  | LitInteger Integer Type --  ^ Integer literals
                            -- See Note [Integer literals]
117
  deriving Data
118

Austin Seipp's avatar
Austin Seipp committed
119
{-
120 121 122
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
123 124
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.
125

126 127 128 129
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.
130

131 132 133 134 135
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.
136 137


138
Binary instance
Austin Seipp's avatar
Austin Seipp committed
139
-}
140 141 142 143

instance Binary Literal where
    put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa
    put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab
sof's avatar
sof committed
144
    put_ bh (MachNullAddr)    = do putByte bh 2
145 146 147 148 149 150
    put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad
    put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae
    put_ bh (MachWord af)     = do putByte bh 5; put_ bh af
    put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag
    put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah
    put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai
151 152 153 154 155
    put_ bh (MachLabel aj mb fod)
        = do putByte bh 9
             put_ bh aj
             put_ bh mb
             put_ bh fod
156
    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
157
    get bh = do
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
            h <- getByte bh
            case h of
              0 -> do
                    aa <- get bh
                    return (MachChar aa)
              1 -> do
                    ab <- get bh
                    return (MachStr ab)
              2 -> do
                    return (MachNullAddr)
              3 -> do
                    ad <- get bh
                    return (MachInt ad)
              4 -> do
                    ae <- get bh
                    return (MachInt64 ae)
              5 -> do
                    af <- get bh
                    return (MachWord af)
              6 -> do
                    ag <- get bh
                    return (MachWord64 ag)
              7 -> do
                    ah <- get bh
                    return (MachFloat ah)
              8 -> do
                    ai <- get bh
                    return (MachDouble ai)
186
              9 -> do
187 188 189 190
                    aj <- get bh
                    mb <- get bh
                    fod <- get bh
                    return (MachLabel aj mb fod)
191 192
              _ -> do
                    i <- get bh
193
                    -- See Note [Integer literals]
194
                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
195

196
instance Outputable Literal where
197
    ppr lit = pprLiteral (\d -> d) lit
198 199 200 201 202 203 204

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

instance Ord Literal where
    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
205
    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
206
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
207
    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
208 209
    compare a b = cmpLit a b

Austin Seipp's avatar
Austin Seipp committed
210
{-
211 212
        Construction
        ~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
213 214
-}

215
-- | Creates a 'Literal' of type @Int#@
216 217 218
mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
                       MachInt x
219 220

-- | Creates a 'Literal' of type @Word#@
221 222 223
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
                        MachWord x
224 225 226

-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
227
mkMachInt64  x = MachInt64 x
228 229 230

-- | Creates a 'Literal' of type @Word64#@
mkMachWord64 :: Integer -> Literal
231
mkMachWord64 x = MachWord64 x
232

233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
-- | Creates a 'Literal' of type @Float#@
mkMachFloat :: Rational -> Literal
mkMachFloat = MachFloat

-- | Creates a 'Literal' of type @Double#@
mkMachDouble :: Rational -> Literal
mkMachDouble = MachDouble

-- | Creates a 'Literal' of type @Char#@
mkMachChar :: Char -> Literal
mkMachChar = MachChar

-- | 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@
mkMachString :: String -> Literal
248
-- stored UTF-8 encoded
249
mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
250

251
mkLitInteger :: Integer -> Type -> Literal
252 253
mkLitInteger = LitInteger

254 255 256
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
257

258 259
inCharRange :: Char -> Bool
inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
260

261
-- | Tests whether the literal represents a zero of whatever type it is
262 263 264 265 266 267 268
isZeroLit :: Literal -> Bool
isZeroLit (MachInt    0) = True
isZeroLit (MachInt64  0) = True
isZeroLit (MachWord   0) = True
isZeroLit (MachWord64 0) = True
isZeroLit (MachFloat  0) = True
isZeroLit (MachDouble 0) = True
269
isZeroLit _              = False
270

271 272 273 274 275 276 277 278 279 280 281
-- | Returns the 'Integer' contained in the 'Literal', for when that makes
-- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
litValue  :: Literal -> Integer
litValue (MachChar   c) = toInteger $ ord c
litValue (MachInt    i) = i
litValue (MachInt64  i) = i
litValue (MachWord   i) = i
litValue (MachWord64 i) = i
litValue (LitInteger i _) = i
litValue l = pprPanic "litValue" (ppr l)

Austin Seipp's avatar
Austin Seipp committed
282
{-
283 284
        Coercions
        ~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
285 286
-}

287
narrow8IntLit, narrow16IntLit, narrow32IntLit,
apt's avatar
apt committed
288
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
289 290
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
apt's avatar
apt committed
291
  float2DoubleLit, double2FloatLit
292
  :: Literal -> Literal
293

294 295 296 297 298
word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
word2IntLit dflags (MachWord w)
  | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
  | otherwise                 = MachInt w
word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
299

300 301
int2WordLit dflags (MachInt i)
  | i < 0     = MachWord (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
302
  | otherwise = MachWord i
303
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
304

apt's avatar
apt committed
305
narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
306
narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)
apt's avatar
apt committed
307
narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
308
narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)
apt's avatar
apt committed
309
narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
310
narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)
apt's avatar
apt committed
311
narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
312
narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)
apt's avatar
apt committed
313
narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
314
narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)
apt's avatar
apt committed
315
narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
316
narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)
317

318
char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
319
char2IntLit l            = pprPanic "char2IntLit" (ppr l)
320
int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
321
int2CharLit l            = pprPanic "int2CharLit" (ppr l)
322

323
float2IntLit (MachFloat f) = MachInt   (truncate    f)
324
float2IntLit l             = pprPanic "float2IntLit" (ppr l)
325
int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
326
int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)
327

apt's avatar
apt committed
328
double2IntLit (MachDouble f) = MachInt    (truncate    f)
329 330 331
double2IntLit l              = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)
int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)
332 333

float2DoubleLit (MachFloat  f) = MachDouble f
334
float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)
335
double2FloatLit (MachDouble d) = MachFloat  d
336
double2FloatLit l              = pprPanic "double2FloatLit" (ppr l)
apt's avatar
apt committed
337 338

nullAddrLit :: Literal
sof's avatar
sof committed
339
nullAddrLit = MachNullAddr
340

Austin Seipp's avatar
Austin Seipp committed
341
{-
342 343
        Predicates
        ~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
344 345
-}

346 347
-- | True if there is absolutely no penalty to duplicating the literal.
-- False principally of strings
348
litIsTrivial :: Literal -> Bool
349
--      c.f. CoreUtils.exprIsTrivial
350 351 352
litIsTrivial (MachStr _)      = False
litIsTrivial (LitInteger {})  = False
litIsTrivial _                = True
353

354 355
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
356
litIsDupable :: DynFlags -> Literal -> Bool
357
--      c.f. CoreUtils.exprIsDupable
358 359 360
litIsDupable _      (MachStr _)      = False
litIsDupable dflags (LitInteger i _) = inIntRange dflags i
litIsDupable _      _                = True
361

362
litFitsInChar :: Literal -> Bool
ian@well-typed.com's avatar
ian@well-typed.com committed
363 364 365
litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
                         && i <= toInteger (ord maxBound)
litFitsInChar _           = False
366 367 368 369

litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
litIsLifted _               = False
370

Austin Seipp's avatar
Austin Seipp committed
371
{-
372 373
        Types
        ~~~~~
Austin Seipp's avatar
Austin Seipp committed
374 375
-}

376
-- | Find the Haskell 'Type' the literal occupies
377
literalType :: Literal -> Type
378 379 380 381 382 383 384 385 386
literalType MachNullAddr    = addrPrimTy
literalType (MachChar _)    = charPrimTy
literalType (MachStr  _)    = addrPrimTy
literalType (MachInt  _)    = intPrimTy
literalType (MachWord  _)   = wordPrimTy
literalType (MachInt64  _)  = int64PrimTy
literalType (MachWord64  _) = word64PrimTy
literalType (MachFloat _)   = floatPrimTy
literalType (MachDouble _)  = doublePrimTy
387
literalType (MachLabel _ _ _) = addrPrimTy
388
literalType (LitInteger _ t) = t
389 390 391 392 393 394 395 396

absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
-- TyCon, to use as a placeholder when it doesn't matter
absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)

absent_lits :: UniqFM Literal
absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
397 398 399 400 401 402 403
                        , (charPrimTyConKey,    MachChar 'x')
                        , (intPrimTyConKey,     MachInt 0)
                        , (int64PrimTyConKey,   MachInt64 0)
                        , (floatPrimTyConKey,   MachFloat 0)
                        , (doublePrimTyConKey,  MachDouble 0)
                        , (wordPrimTyConKey,    MachWord 0)
                        , (word64PrimTyConKey,  MachWord64 0) ]
404

Austin Seipp's avatar
Austin Seipp committed
405
{-
406 407
        Comparison
        ~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
408 409
-}

410
cmpLit :: Literal -> Literal -> Ordering
411 412
cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
sof's avatar
sof committed
413
cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
414 415 416 417 418 419
cmpLit (MachInt       a)   (MachInt        b)   = a `compare` b
cmpLit (MachWord      a)   (MachWord       b)   = a `compare` b
cmpLit (MachInt64     a)   (MachInt64      b)   = a `compare` b
cmpLit (MachWord64    a)   (MachWord64     b)   = a `compare` b
cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b
cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b
420
cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
421
cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
cmpLit lit1                lit2                 | litTag lit1 < litTag lit2 = LT
                                                | otherwise                 = GT

litTag :: Literal -> Int
litTag (MachChar      _)   = 1
litTag (MachStr       _)   = 2
litTag (MachNullAddr)      = 3
litTag (MachInt       _)   = 4
litTag (MachWord      _)   = 5
litTag (MachInt64     _)   = 6
litTag (MachWord64    _)   = 7
litTag (MachFloat     _)   = 8
litTag (MachDouble    _)   = 9
litTag (MachLabel _ _ _)   = 10
litTag (LitInteger  {})    = 11
437

Austin Seipp's avatar
Austin Seipp committed
438
{-
439 440
        Printing
        ~~~~~~~~
441
* See Note [Printing of literals in Core]
Austin Seipp's avatar
Austin Seipp committed
442
-}
443

444
pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
445
pprLiteral _       (MachChar c)     = pprPrimChar c
446
pprLiteral _       (MachStr s)      = pprHsBytes s
447
pprLiteral _       (MachNullAddr)   = text "__NULL"
448 449 450 451 452 453 454
pprLiteral _       (MachInt i)      = pprPrimInt i
pprLiteral _       (MachInt64 i)    = pprPrimInt64 i
pprLiteral _       (MachWord w)     = pprPrimWord w
pprLiteral _       (MachWord64 w)   = pprPrimWord64 w
pprLiteral _       (MachFloat f)    = float (fromRat f) <> primFloatSuffix
pprLiteral _       (MachDouble d)   = double (fromRat d) <> primDoubleSuffix
pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
455
pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
456 457 458
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
459

460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500
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
(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
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)
-------         -------            ----------------------
MachChar        'a'#
MachStr         "aaa"#
MachNullAddr    "__NULL"
MachInt         -1#
MachInt64       -1L#
MachWord         1##
MachWord64       1L##
MachFloat       -1.0#
MachDouble      -1.0##
LitInteger      -1                 (-1)
MachLabel       "__label" ...      ("__label" ...)
-}