Literal.lhs 18.9 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

Ian Lynagh's avatar
Ian Lynagh committed
10 11 12 13 14 15 16
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

17
module Literal
18 19 20 21 22 23 24 25 26
        (
        -- * Main data type
          Literal(..)           -- Exported to ParseIface

        -- ** Creating Literals
        , mkMachInt, mkMachWord
        , mkMachInt64, mkMachWord64
        , mkMachFloat, mkMachDouble
        , mkMachChar, mkMachString
27
        , mkLitInteger
28 29 30 31

        -- ** Operations on Literals
        , literalType
        , hashLiteral
32
        , absentLiteralOf
33
        , pprLiteral
34

35
        -- ** Predicates on Literals and their contents
36
        , litIsDupable, litIsTrivial, litIsLifted
37 38 39
        , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
        , isZeroLit
        , litFitsInChar
40

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

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

Simon Marlow's avatar
Simon Marlow committed
52
import TysPrim
53
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
54
import Type
55
import TypeRep
56
import TyCon
57
import Var
58
import Outputable
59
import FastTypes
60
import FastString
61
import BasicTypes
62
import Binary
63
import Constants
64
import UniqFM
65 66
import Util

Simon Marlow's avatar
Simon Marlow committed
67
import Data.Int
Ian Lynagh's avatar
Ian Lynagh committed
68
import Data.Ratio
Simon Marlow's avatar
Simon Marlow committed
69 70
import Data.Word
import Data.Char
71 72
import Data.Data ( Data, Typeable )
import Numeric ( fromRat )
73 74 75 76
\end{code}


%************************************************************************
77
%*                                                                      *
78
\subsection{Literals}
79
%*                                                                      *
80 81 82
%************************************************************************

\begin{code}
83 84 85 86 87 88
-- | 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.
--
89
-- * The literal derived from the label mentioned in a \"foreign label\"
90
--   declaration ('MachLabel')
91
data Literal
92 93 94
  =     ------------------
        -- First the primitive guys
    MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
95

96 97 98 99
  | MachStr     FastString      -- ^ A string-literal: stored and emitted
                                -- UTF-8 encoded, we'll arrange to decode it
                                -- at runtime.  Also emitted with a @'\0'@
                                -- terminator. Create with 'mkMachString'
100 101

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

105 106 107 108
  | 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'
109

110 111
  | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'
  | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'
112 113

  | MachLabel   FastString
114
                (Maybe Int)
115 116
        FunctionOrData
                -- ^ A label literal. Parameters:
117 118 119 120 121 122 123
                        --
                        -- 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.
124

125 126
  | LitInteger Integer Id	--  ^ Integer literals
    	       	       		-- See Note [Integer literals]
127
  deriving (Data, Typeable)
128 129
\end{code}

130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
easier to write RULEs for them. 

 * The Id is for mkInteger, which we use when finally creating the core.

 * They only get converted into real Core,
      mkInteger [c1, c2, .., cn]
   during the CorePrep phase.

 * 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.

 * When looking for CAF-hood (in TidyPgm), we must take account of the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
148 149 150
   CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL.
   Indeed this is the only reason we put the mk_integer field in the 
   literal -- otherwise we could just look it up in CorePrep.
151 152


153
Binary instance
154 155 156 157 158

\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
159
    put_ bh (MachNullAddr)    = do putByte bh 2
160 161 162 163 164 165
    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
166 167 168 169 170
    put_ bh (MachLabel aj mb fod)
        = do putByte bh 9
             put_ bh aj
             put_ bh mb
             put_ bh fod
171
    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
172
    get bh = do
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
            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)
201
              9 -> do
202 203 204 205
                    aj <- get bh
                    mb <- get bh
                    fod <- get bh
                    return (MachLabel aj mb fod)
206 207
              _ -> do
                    i <- get bh
208
                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
209
		    	   -- See Note [Integer literals] in Literal
210 211
\end{code}

212 213
\begin{code}
instance Outputable Literal where
214
    ppr lit = pprLiteral (\d -> d) lit
215 216 217 218 219 220 221 222 223 224

instance Show Literal where
    showsPrec p lit = showsPrecSDoc p (ppr lit)

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 }
225
    a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
226
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
227
    a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
228 229 230 231
    compare a b = cmpLit a b
\end{code}


232 233
        Construction
        ~~~~~~~~~~~~
234
\begin{code}
235 236
-- | Creates a 'Literal' of type @Int#@
mkMachInt :: Integer -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
237
mkMachInt  x   = ASSERT2( inIntRange x,  integer x )
238
                 MachInt x
239 240 241

-- | Creates a 'Literal' of type @Word#@
mkMachWord :: Integer -> Literal
Ian Lynagh's avatar
Ian Lynagh committed
242
mkMachWord x   = ASSERT2( inWordRange x, integer x )
243
                 MachWord x
244 245 246

-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
247
mkMachInt64  x = MachInt64 x
248 249 250

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

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
-- | 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
mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
269

270 271 272
mkLitInteger :: Integer -> Id -> Literal
mkLitInteger = LitInteger

273 274
inIntRange, inWordRange :: Integer -> Bool
inIntRange  x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
275
inWordRange x = x >= 0              && x <= tARGET_MAX_WORD
276

277 278
inCharRange :: Char -> Bool
inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
279

280
-- | Tests whether the literal represents a zero of whatever type it is
281 282 283 284 285 286 287
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
288
isZeroLit _              = False
289 290
\end{code}

291 292
        Coercions
        ~~~~~~~~~
293
\begin{code}
294
word2IntLit, int2WordLit,
apt's avatar
apt committed
295 296
  narrow8IntLit, narrow16IntLit, narrow32IntLit,
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
297 298
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
apt's avatar
apt committed
299
  float2DoubleLit, double2FloatLit
300
  :: Literal -> Literal
301

302
word2IntLit (MachWord w)
303
  | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
304
  | otherwise          = MachInt w
305
word2IntLit l = pprPanic "word2IntLit" (ppr l)
306 307

int2WordLit (MachInt i)
308
  | i < 0     = MachWord (1 + tARGET_MAX_WORD + i)      -- (-1)  --->  tARGET_MAX_WORD
309
  | otherwise = MachWord i
310
int2WordLit l = pprPanic "int2WordLit" (ppr l)
311

apt's avatar
apt committed
312
narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
313
narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)
apt's avatar
apt committed
314
narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
315
narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)
apt's avatar
apt committed
316
narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
317
narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)
apt's avatar
apt committed
318
narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
319
narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)
apt's avatar
apt committed
320
narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
321
narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)
apt's avatar
apt committed
322
narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
323
narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)
324

325
char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
326
char2IntLit l            = pprPanic "char2IntLit" (ppr l)
327
int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
328
int2CharLit l            = pprPanic "int2CharLit" (ppr l)
329

330
float2IntLit (MachFloat f) = MachInt   (truncate    f)
331
float2IntLit l             = pprPanic "float2IntLit" (ppr l)
332
int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
333
int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)
334

apt's avatar
apt committed
335
double2IntLit (MachDouble f) = MachInt    (truncate    f)
336 337 338
double2IntLit l              = pprPanic "double2IntLit" (ppr l)
int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)
int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)
339 340

float2DoubleLit (MachFloat  f) = MachDouble f
341
float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)
342
double2FloatLit (MachDouble d) = MachFloat  d
343
double2FloatLit l              = pprPanic "double2FloatLit" (ppr l)
apt's avatar
apt committed
344 345

nullAddrLit :: Literal
sof's avatar
sof committed
346
nullAddrLit = MachNullAddr
347 348
\end{code}

349 350
        Predicates
        ~~~~~~~~~~
351
\begin{code}
352 353
-- | True if there is absolutely no penalty to duplicating the literal.
-- False principally of strings
354
litIsTrivial :: Literal -> Bool
355
--      c.f. CoreUtils.exprIsTrivial
356 357 358
litIsTrivial (MachStr _)      = False
litIsTrivial (LitInteger {})  = False
litIsTrivial _                = True
359

360 361
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
362
litIsDupable :: Literal -> Bool
363
--      c.f. CoreUtils.exprIsDupable
364 365 366
litIsDupable (MachStr _)      = False
litIsDupable (LitInteger i _) = inIntRange i
litIsDupable _                = True
367

368 369
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
370 371
                         = fromInteger i <= ord minBound
                        && fromInteger i >= ord maxBound
372
litFitsInChar _         = False
373 374 375 376

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

379 380
        Types
        ~~~~~
381
\begin{code}
382
-- | Find the Haskell 'Type' the literal occupies
383
literalType :: Literal -> Type
384 385 386 387 388 389 390 391 392
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
393
literalType (MachLabel _ _ _) = addrPrimTy
Simon Peyton Jones's avatar
Simon Peyton Jones committed
394
literalType (LitInteger _ mk_integer_id)
395 396
      -- We really mean idType, rather than varType, but importing Id
      -- causes a module import loop
Simon Peyton Jones's avatar
Simon Peyton Jones committed
397 398 399
    = case varType mk_integer_id of
        FunTy _ (FunTy _ integerTy) -> integerTy
        _ -> panic "literalType: mkIntegerId has the wrong type"
400 401 402 403 404 405 406 407

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)
408 409 410 411 412 413 414
                        , (charPrimTyConKey,    MachChar 'x')
                        , (intPrimTyConKey,     MachInt 0)
                        , (int64PrimTyConKey,   MachInt64 0)
                        , (floatPrimTyConKey,   MachFloat 0)
                        , (doublePrimTyConKey,  MachDouble 0)
                        , (wordPrimTyConKey,    MachWord 0)
                        , (word64PrimTyConKey,  MachWord64 0) ]
415 416 417
\end{code}


418 419
        Comparison
        ~~~~~~~~~~
420
\begin{code}
421
cmpLit :: Literal -> Literal -> Ordering
422 423
cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
sof's avatar
sof committed
424
cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
425 426 427 428 429 430
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
431
cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
432
cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b
433 434
cmpLit lit1                lit2                 | litTag lit1 <# litTag lit2 = LT
                                                | otherwise                  = GT
435

436
litTag :: Literal -> FastInt
437 438
litTag (MachChar      _)   = _ILIT(1)
litTag (MachStr       _)   = _ILIT(2)
sof's avatar
sof committed
439
litTag (MachNullAddr)      = _ILIT(3)
440 441 442 443 444 445
litTag (MachInt       _)   = _ILIT(4)
litTag (MachWord      _)   = _ILIT(5)
litTag (MachInt64     _)   = _ILIT(6)
litTag (MachWord64    _)   = _ILIT(7)
litTag (MachFloat     _)   = _ILIT(8)
litTag (MachDouble    _)   = _ILIT(9)
446
litTag (MachLabel _ _ _)   = _ILIT(10)
447
litTag (LitInteger  {})    = _ILIT(11)
448 449
\end{code}

450 451
        Printing
        ~~~~~~~~
452
* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
sof's avatar
sof committed
453
  exceptions: MachFloat gets an initial keyword prefix.
454 455

\begin{code}
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470
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
pprLiteral _       (MachStr s)      = pprHsString s
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)
471 472 473
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
474

475
pprIntVal :: Integer -> SDoc
476
-- ^ Print negative integers with parens to be sure it's unambiguous
477
pprIntVal i | i < 0     = parens (integer i)
478
            | otherwise = integer i
479 480 481 482
\end{code}


%************************************************************************
483
%*                                                                      *
484
\subsection{Hashing}
485
%*                                                                      *
486 487 488 489 490 491 492
%************************************************************************

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
493 494 495 496 497 498 499 500 501
hashLiteral (MachChar c)        = ord c + 1000  -- Keep it out of range of common ints
hashLiteral (MachStr s)         = hashFS s
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
502
hashLiteral (MachLabel s _ _)     = hashFS s
503
hashLiteral (LitInteger i _)    = hashInteger i
504 505 506 507 508 509

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

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

513
hashFS :: FastString -> Int
514
hashFS s = iBox (uniqueOfFS s)
515
\end{code}