Literal.lhs 18.3 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3 4 5 6 7
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}

\begin{code}
8
{-# LANGUAGE 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 24

        -- ** Operations on Literals
        , literalType
        , hashLiteral
25
        , absentLiteralOf
26
        , pprLiteral
27

28
        -- ** Predicates on Literals and their contents
29
        , litIsDupable, litIsTrivial, litIsLifted
30 31 32
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
        , isZeroLit
        , litFitsInChar
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 FastTypes
51
import FastString
52
import BasicTypes
53
import Binary
54
import Constants
55
import DynFlags
56
import UniqFM
57 58
import Util

Simon Marlow's avatar
Simon Marlow committed
59
import Data.Int
Ian Lynagh's avatar
Ian Lynagh committed
60
import Data.Ratio
Simon Marlow's avatar
Simon Marlow committed
61 62
import Data.Word
import Data.Char
63 64
import Data.Data ( Data, Typeable )
import Numeric ( fromRat )
65 66 67 68
\end{code}


%************************************************************************
69
%*                                                                      *
70
\subsection{Literals}
71
%*                                                                      *
72 73 74
%************************************************************************

\begin{code}
75 76 77 78 79 80
-- | 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.
--
81
-- * The literal derived from the label mentioned in a \"foreign label\"
82
--   declaration ('MachLabel')
83
data Literal
84 85 86
  =     ------------------
        -- First the primitive guys
    MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
87

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

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

97 98 99 100
  | 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'
101

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

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

117 118
  | LitInteger Integer Type --  ^ Integer literals
                            -- See Note [Integer literals]
119
  deriving (Data, Typeable)
120 121
\end{code}

122 123 124
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
125 126
easier to write RULEs for them. They also contain the Integer type, so
that e.g. literalType can return the right Type for them.
127

128 129 130 131
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.
132

133 134 135 136 137
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.
138 139


140
Binary instance
141 142 143 144 145

\begin{code}
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
146
    put_ bh (MachNullAddr)    = do putByte bh 2
147 148 149 150 151 152
    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
153 154 155 156 157
    put_ bh (MachLabel aj mb fod)
        = do putByte bh 9
             put_ bh aj
             put_ bh mb
             put_ bh fod
158
    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
159
    get bh = do
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 186 187
            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)
188
              9 -> do
189 190 191 192
                    aj <- get bh
                    mb <- get bh
                    fod <- get bh
                    return (MachLabel aj mb fod)
193 194
              _ -> do
                    i <- get bh
195
                    -- See Note [Integer literals]
196
                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
197 198
\end{code}

199 200
\begin{code}
instance Outputable Literal where
201
    ppr lit = pprLiteral (\d -> d) lit
202 203 204 205 206 207 208

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 }
209
    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
210
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
211
    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
212 213 214 215
    compare a b = cmpLit a b
\end{code}


216 217
        Construction
        ~~~~~~~~~~~~
218
\begin{code}
219
-- | Creates a 'Literal' of type @Int#@
220 221 222
mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
                       MachInt x
223 224

-- | Creates a 'Literal' of type @Word#@
225 226 227
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
                        MachWord x
228 229 230

-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
231
mkMachInt64  x = MachInt64 x
232 233 234

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

237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
-- | 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
252 253
-- stored UTF-8 encoded
mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s)
254

255
mkLitInteger :: Integer -> Type -> Literal
256 257
mkLitInteger = LitInteger

258 259 260
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
261

262 263
inCharRange :: Char -> Bool
inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
264

265
-- | Tests whether the literal represents a zero of whatever type it is
266 267 268 269 270 271 272
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
273
isZeroLit _              = False
274 275
\end{code}

276 277
        Coercions
        ~~~~~~~~~
278
\begin{code}
279
narrow8IntLit, narrow16IntLit, narrow32IntLit,
apt's avatar
apt committed
280
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
281 282
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
apt's avatar
apt committed
283
  float2DoubleLit, double2FloatLit
284
  :: Literal -> Literal
285

286 287 288 289 290
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)
291

292 293
int2WordLit dflags (MachInt i)
  | i < 0     = MachWord (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
294
  | otherwise = MachWord i
295
int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
296

apt's avatar
apt committed
297
narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
298
narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)
apt's avatar
apt committed
299
narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
300
narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)
apt's avatar
apt committed
301
narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
302
narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)
apt's avatar
apt committed
303
narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
304
narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)
apt's avatar
apt committed
305
narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
306
narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)
apt's avatar
apt committed
307
narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
308
narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)
309

310
char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
311
char2IntLit l            = pprPanic "char2IntLit" (ppr l)
312
int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
313
int2CharLit l            = pprPanic "int2CharLit" (ppr l)
314

315
float2IntLit (MachFloat f) = MachInt   (truncate    f)
316
float2IntLit l             = pprPanic "float2IntLit" (ppr l)
317
int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
318
int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)
319

apt's avatar
apt committed
320
double2IntLit (MachDouble f) = MachInt    (truncate    f)
321 322 323
double2IntLit l              = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)
int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)
324 325

float2DoubleLit (MachFloat  f) = MachDouble f
326
float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)
327
double2FloatLit (MachDouble d) = MachFloat  d
328
double2FloatLit l              = pprPanic "double2FloatLit" (ppr l)
apt's avatar
apt committed
329 330

nullAddrLit :: Literal
sof's avatar
sof committed
331
nullAddrLit = MachNullAddr
332 333
\end{code}

334 335
        Predicates
        ~~~~~~~~~~
336
\begin{code}
337 338
-- | True if there is absolutely no penalty to duplicating the literal.
-- False principally of strings
339
litIsTrivial :: Literal -> Bool
340
--      c.f. CoreUtils.exprIsTrivial
341 342 343
litIsTrivial (MachStr _)      = False
litIsTrivial (LitInteger {})  = False
litIsTrivial _                = True
344

345 346
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
347
litIsDupable :: DynFlags -> Literal -> Bool
348
--      c.f. CoreUtils.exprIsDupable
349 350 351
litIsDupable _      (MachStr _)      = False
litIsDupable dflags (LitInteger i _) = inIntRange dflags i
litIsDupable _      _                = True
352

353
litFitsInChar :: Literal -> Bool
ian@well-typed.com's avatar
ian@well-typed.com committed
354 355 356
litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
                         && i <= toInteger (ord maxBound)
litFitsInChar _           = False
357 358 359 360

litIsLifted :: Literal -> Bool
litIsLifted (LitInteger {}) = True
litIsLifted _               = False
361 362
\end{code}

363 364
        Types
        ~~~~~
365
\begin{code}
366
-- | Find the Haskell 'Type' the literal occupies
367
literalType :: Literal -> Type
368 369 370 371 372 373 374 375 376
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
377
literalType (MachLabel _ _ _) = addrPrimTy
378
literalType (LitInteger _ t) = t
379 380 381 382 383 384 385 386

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)
387 388 389 390 391 392 393
                        , (charPrimTyConKey,    MachChar 'x')
                        , (intPrimTyConKey,     MachInt 0)
                        , (int64PrimTyConKey,   MachInt64 0)
                        , (floatPrimTyConKey,   MachFloat 0)
                        , (doublePrimTyConKey,  MachDouble 0)
                        , (wordPrimTyConKey,    MachWord 0)
                        , (word64PrimTyConKey,  MachWord64 0) ]
394 395 396
\end{code}


397 398
        Comparison
        ~~~~~~~~~~
399
\begin{code}
400
cmpLit :: Literal -> Literal -> Ordering
401 402
cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
sof's avatar
sof committed
403
cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
404 405 406 407 408 409
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
410
cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
411
cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b
412 413
cmpLit lit1                lit2                 | litTag lit1 <# litTag lit2 = LT
                                                | otherwise                  = GT
414

415
litTag :: Literal -> FastInt
416 417
litTag (MachChar      _)   = _ILIT(1)
litTag (MachStr       _)   = _ILIT(2)
sof's avatar
sof committed
418
litTag (MachNullAddr)      = _ILIT(3)
419 420 421 422 423 424
litTag (MachInt       _)   = _ILIT(4)
litTag (MachWord      _)   = _ILIT(5)
litTag (MachInt64     _)   = _ILIT(6)
litTag (MachWord64    _)   = _ILIT(7)
litTag (MachFloat     _)   = _ILIT(8)
litTag (MachDouble    _)   = _ILIT(9)
425
litTag (MachLabel _ _ _)   = _ILIT(10)
426
litTag (LitInteger  {})    = _ILIT(11)
427 428
\end{code}

429 430
        Printing
        ~~~~~~~~
431
* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
sof's avatar
sof committed
432
  exceptions: MachFloat gets an initial keyword prefix.
433 434

\begin{code}
435 436 437 438 439
pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
-- The function is used on non-atomic literals
-- to wrap parens around literals that occur in
-- a context requiring an atomic thing
pprLiteral _       (MachChar ch)    = pprHsChar ch
440
pprLiteral _       (MachStr s)      = pprHsBytes s
441 442 443 444 445 446 447 448 449
pprLiteral _       (MachInt i)      = pprIntVal i
pprLiteral _       (MachDouble d)   = double (fromRat d)
pprLiteral _       (MachNullAddr)   = ptext (sLit "__NULL")
pprLiteral add_par (LitInteger i _) = add_par (ptext (sLit "__integer") <+> integer i)
pprLiteral add_par (MachInt64 i)    = add_par (ptext (sLit "__int64") <+> integer i)
pprLiteral add_par (MachWord w)     = add_par (ptext (sLit "__word") <+> integer w)
pprLiteral add_par (MachWord64 w)   = add_par (ptext (sLit "__word64") <+> integer w)
pprLiteral add_par (MachFloat f)    = add_par (ptext (sLit "__float") <+> float (fromRat f))
pprLiteral add_par (MachLabel l mb fod) = add_par (ptext (sLit "__label") <+> b <+> ppr fod)
450 451 452
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
453

454
pprIntVal :: Integer -> SDoc
455
-- ^ Print negative integers with parens to be sure it's unambiguous
456
pprIntVal i | i < 0     = parens (integer i)
457
            | otherwise = integer i
458 459 460 461
\end{code}


%************************************************************************
462
%*                                                                      *
463
\subsection{Hashing}
464
%*                                                                      *
465 466 467 468 469 470 471
%************************************************************************

Hash values should be zero or a positive integer.  No negatives please.
(They mess up the UniqFM for some reason.)

\begin{code}
hashLiteral :: Literal -> Int
472
hashLiteral (MachChar c)        = ord c + 1000  -- Keep it out of range of common ints
473
hashLiteral (MachStr s)         = hashByteString s
474 475 476 477 478 479 480
hashLiteral (MachNullAddr)      = 0
hashLiteral (MachInt i)         = hashInteger i
hashLiteral (MachInt64 i)       = hashInteger i
hashLiteral (MachWord i)        = hashInteger i
hashLiteral (MachWord64 i)      = hashInteger i
hashLiteral (MachFloat r)       = hashRational r
hashLiteral (MachDouble r)      = hashRational r
481
hashLiteral (MachLabel s _ _)     = hashFS s
482
hashLiteral (LitInteger i _)    = hashInteger i
483 484 485 486 487 488

hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)

hashInteger :: Integer -> Int
hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
489 490
                -- The 1+ is to avoid zero, which is a Bad Number
                -- since we use * to combine hash values
491

492
hashFS :: FastString -> Int
493
hashFS s = iBox (uniqueOfFS s)
494
\end{code}