ghc/compiler/basicTypes/Const.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
   3 %
   4 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
   5
   6 \begin{code}
   7 module Const (
   8         Con(..),
   9         conType, conPrimRep,
  10         conOkForApp, conOkForAlt, isWHNFCon, isDataCon, isBoxedDataCon,
  11         conIsTrivial, conIsCheap, conIsDupable, conStrictness,
  12         conOkForSpeculation, hashCon,
  13
  14         DataCon, PrimOp,        -- For completeness
  15
  16         -- Defined here
  17         Literal(..),            -- Exported to ParseIface
  18         mkMachInt, mkMachWord,
  19         mkMachInt_safe, mkMachInt64, mkMachWord64,
  20         mkStrLit,                       -- ToDo: rm (not used anywhere)
  21         isNoRepLit, isLitLitLit,
  22         literalType, literalPrimRep
  23     ) where
  24
  25 #include "HsVersions.h"
  26
  27 import TysPrim          ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
  28                           intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
  29                         )
  30 import Name             ( hashName )
  31 import PrimOp           ( PrimOp, primOpType, primOpIsDupable, primOpTag,
  32                           primOpIsCheap, primOpStrictness, primOpOkForSpeculation )
  33 import PrimRep          ( PrimRep(..) )
  34 import DataCon          ( DataCon, dataConName, dataConType, dataConTyCon,
  35                           isNullaryDataCon, dataConRepStrictness, isUnboxedTupleCon
  36                         )
  37 import TyCon            ( isNewTyCon )
  38 import Type             ( Type, typePrimRep )
  39 import PprType          ( pprParendType )
  40 import Demand           ( Demand )
  41 import CStrings         ( stringToC, charToC, charToEasyHaskell )
  42
  43 import Outputable
  44 import Util             ( thenCmp )
  45
  46 import Ratio            ( numerator, denominator )
  47 import FastString       ( uniqueOfFS )
  48 import Char             ( ord )
  49
  50 #if __GLASGOW_HASKELL__ >= 404
  51 import GlaExts          ( fromInt )
  52 #endif
  53 \end{code}
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{The main data type}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 \begin{code}
  63 data Con
  64   = DataCon  DataCon
  65   | Literal  Literal
  66   | PrimOp   PrimOp
  67   | DEFAULT                     -- Used in case clauses
  68   deriving (Eq, Ord)
  69
  70 -- The Ord is needed for the FiniteMap used in the lookForConstructor
  71 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
  72 -- constructor-applications with LitArg args, then you could get
  73 -- rid of this Ord.
  74
  75 instance Outputable Con where
  76   ppr (DataCon dc)  = ppr dc
  77   ppr (Literal lit) = ppr lit
  78   ppr (PrimOp op)   = ppr op
  79   ppr DEFAULT       = ptext SLIT("__DEFAULT")
  80
  81 instance Show Con where
  82   showsPrec p con = showsPrecSDoc p (ppr con)
  83
  84 conType :: Con -> Type
  85 conType (DataCon dc)  = dataConType dc
  86 conType (Literal lit) = literalType lit
  87 conType (PrimOp op)   = primOpType op
  88
  89 conStrictness :: Con -> ([Demand], Bool)
  90 conStrictness (DataCon dc)  = (dataConRepStrictness dc, False)
  91 conStrictness (PrimOp op)   = primOpStrictness op
  92 conStrictness (Literal lit) = ([], False)
  93
  94 conPrimRep :: Con -> PrimRep    -- Only data valued constants
  95 conPrimRep (DataCon dc)  = ASSERT( isNullaryDataCon dc) PtrRep
  96 conPrimRep (Literal lit) = literalPrimRep lit
  97
  98 conOkForApp, conOkForAlt :: Con -> Bool
  99
 100 -- OK for appliation site
 101 conOkForApp (DataCon dc) = not (isNewTyCon (dataConTyCon dc))
 102 conOkForApp (Literal _)  = True
 103 conOkForApp (PrimOp op)  = True
 104 conOkForApp DEFAULT      = False
 105
 106 -- OK for case alternative pattern
 107 conOkForAlt (DataCon dc)  = not (isNewTyCon (dataConTyCon dc))
 108 conOkForAlt (Literal lit) = not (isNoRepLit lit)
 109 conOkForAlt (PrimOp _)    = False
 110 conOkForAlt DEFAULT       = True
 111
 112         -- isWHNFCon is false for PrimOps, which contain work
 113         -- Ditto for newtype constructors, which can occur in the output
 114         -- of the desugarer, but which will be inlined right away thereafter
 115 isWHNFCon (DataCon dc) = not (isNewTyCon (dataConTyCon dc))
 116 isWHNFCon (Literal _)  = True
 117 isWHNFCon (PrimOp _)   = False
 118
 119 isDataCon (DataCon dc) = True
 120 isDataCon other        = False
 121
 122 isBoxedDataCon (DataCon dc) = not (isUnboxedTupleCon dc)
 123 isBoxedDataCon other        = False
 124
 125 -- conIsTrivial is true for constants we are unconditionally happy to duplicate
 126 -- cf CoreUtils.exprIsTrivial
 127 conIsTrivial (Literal lit) = not (isNoRepLit lit)
 128 conIsTrivial (PrimOp _)    = False
 129 conIsTrivial con           = True
 130
 131 -- conIsCheap is true for constants whose *work* we are willing
 132 -- to duplicate in exchange for some modest gain.  cf CoreUtils.exprIsCheap
 133 conIsCheap (Literal lit) = True         -- Even no-rep lits are cheap; we don't end
 134                                         -- up duplicating their work if we push them inside
 135                                         -- a lambda, because we float them to the top in the end
 136 conIsCheap (DataCon con) = True
 137 conIsCheap (PrimOp op)   = primOpIsCheap op
 138
 139 -- conIsDupable is true for constants whose applications we are willing
 140 -- to duplicate in different case branches; i.e no issue about loss of
 141 -- work, just space
 142 conIsDupable (Literal lit) = not (isNoRepLit lit)
 143 conIsDupable (DataCon con) = True
 144 conIsDupable (PrimOp op)   = primOpIsDupable op
 145
 146 -- Similarly conOkForSpeculation
 147 conOkForSpeculation (Literal lit) = True
 148 conOkForSpeculation (DataCon con) = True
 149 conOkForSpeculation (PrimOp op)   = primOpOkForSpeculation op
 150 \end{code}
 151
 152
 153 %************************************************************************
 154 %*                                                                      *
 155 \subsection{Literals}
 156 %*                                                                      *
 157 %************************************************************************
 158
 159 So-called @Literals@ are {\em either}:
 160 \begin{itemize}
 161 \item
 162 An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
 163 which is presumed to be surrounded by appropriate constructors
 164 (@mKINT@, etc.), so that the overall thing makes sense.
 165 \item
 166 An Integer, Rational, or String literal whose representation we are
 167 {\em uncommitted} about; i.e., the surrounding with constructors,
 168 function applications, etc., etc., has not yet been done.
 169 \end{itemize}
 170
 171 \begin{code}
 172 data Literal
 173   =     ------------------
 174         -- First the primitive guys
 175     MachChar    Char
 176   | MachStr     FAST_STRING
 177
 178   | MachAddr    Integer -- Whatever this machine thinks is a "pointer"
 179
 180   | MachInt     Integer -- For the numeric types, these are
 181                 Bool    -- True <=> signed (Int#); False <=> unsigned (Word#)
 182
 183   | MachInt64   Integer -- guaranteed 64-bit versions of the above.
 184                 Bool    -- True <=> signed (Int#); False <=> unsigned (Word#)
 185
 186
 187   | MachFloat   Rational
 188   | MachDouble  Rational
 189
 190   | MachLitLit  FAST_STRING Type        -- Type might be Add# or Int# etc
 191
 192         ------------------
 193         -- The no-rep guys
 194   | NoRepStr        FAST_STRING Type    -- This Type is always String
 195   | NoRepInteger    Integer     Type    -- This Type is always Integer
 196   | NoRepRational   Rational    Type    -- This Type is always Rational
 197                         -- We keep these Types in the literal because Rational isn't
 198                         -- (currently) wired in, so we can't conjure up its type out of
 199                         -- thin air.    Integer is, so the type here is really redundant.
 200 \end{code}
 201
 202 \begin{code}
 203 instance Outputable Literal where
 204     ppr lit = pprLit lit
 205
 206 instance Show Literal where
 207     showsPrec p lit = showsPrecSDoc p (ppr lit)
 208
 209 instance Eq Literal where
 210     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
 211     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
 212
 213 instance Ord Literal where
 214     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
 215     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
 216     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
 217     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
 218     compare a b = cmpLit a b
 219 \end{code}
 220
 221
 222         Construction
 223         ~~~~~~~~~~~~
 224 \begin{code}
 225 mkMachInt, mkMachWord :: Integer -> Literal
 226
 227 mkMachInt  x = MachInt x True{-signed-}
 228 mkMachWord x = MachInt x False{-unsigned-}
 229
 230 -- check if the int is within range
 231 mkMachInt_safe :: Integer -> Literal
 232 mkMachInt_safe i
 233  | out_of_range =
 234    pprPanic "mkMachInt_safe"
 235             (hsep [text "ERROR: Int ", text (show i), text "out of range",
 236                    brackets (int minInt <+> text ".." <+> int maxInt)])
 237  | otherwise = MachInt i True{-signed-}
 238  where
 239   out_of_range =
 240 --    i < fromInt minBound ||
 241     i > fromInt maxInt
 242
 243 mkMachInt64  x = MachInt64 x True{-signed-}
 244 mkMachWord64 x = MachInt64 x False{-unsigned-}
 245
 246 mkStrLit :: String -> Type -> Literal
 247 mkStrLit s ty = NoRepStr (_PK_ s) ty
 248 \end{code}
 249
 250
 251         Predicates
 252         ~~~~~~~~~~
 253 \begin{code}
 254 isNoRepLit (NoRepStr _ _)       = True -- these are not primitive typed!
 255 isNoRepLit (NoRepInteger  _ _)  = True
 256 isNoRepLit (NoRepRational _ _)  = True
 257 isNoRepLit _                    = False
 258
 259 isLitLitLit (MachLitLit _ _) = True
 260 isLitLitLit _                = False
 261 \end{code}
 262
 263         Types
 264         ~~~~~
 265 \begin{code}
 266 literalType :: Literal -> Type
 267 literalType (MachChar _)          = charPrimTy
 268 literalType (MachStr  _)          = addrPrimTy
 269 literalType (MachAddr _)          = addrPrimTy
 270 literalType (MachInt  _ signed)   = if signed then intPrimTy else wordPrimTy
 271 literalType (MachInt64  _ signed) = if signed then int64PrimTy else word64PrimTy
 272 literalType (MachFloat _)         = floatPrimTy
 273 literalType (MachDouble _)        = doublePrimTy
 274 literalType (MachLitLit _ ty)     = ty
 275 literalType (NoRepInteger  _ ty)  = ty
 276 literalType (NoRepRational _ ty)  = ty
 277 literalType (NoRepStr _ ty)       = ty
 278 \end{code}
 279
 280 \begin{code}
 281 literalPrimRep :: Literal -> PrimRep
 282
 283 literalPrimRep (MachChar _)       = CharRep
 284 literalPrimRep (MachStr _)        = AddrRep  -- specifically: "char *"
 285 literalPrimRep (MachAddr  _)      = AddrRep
 286 literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
 287 literalPrimRep (MachInt64 _ signed) = if signed then Int64Rep else Word64Rep
 288 literalPrimRep (MachFloat _)      = FloatRep
 289 literalPrimRep (MachDouble _)     = DoubleRep
 290 literalPrimRep (MachLitLit _ ty)  = typePrimRep ty
 291 #ifdef DEBUG
 292 literalPrimRep (NoRepInteger  _ _) = panic "literalPrimRep:NoRepInteger"
 293 literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
 294 literalPrimRep (NoRepStr _ _)      = panic "literalPrimRep:NoRepString"
 295 #endif
 296 \end{code}
 297
 298
 299         Comparison
 300         ~~~~~~~~~~
 301 \begin{code}
 302 cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
 303 cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
 304 cmpLit (MachAddr      a)   (MachAddr       b)   = a `compare` b
 305 cmpLit (MachInt       a b) (MachInt        c d) = (a `compare` c) `thenCmp` (b `compare` d)
 306 cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b
 307 cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b
 308 cmpLit (MachLitLit    a b) (MachLitLit    c d)  = (a `compare` c) `thenCmp` (b `compare` d)
 309 cmpLit (NoRepStr      a _) (NoRepStr      b _)  = a `compare` b
 310 cmpLit (NoRepInteger  a _) (NoRepInteger  b _)  = a `compare` b
 311 cmpLit (NoRepRational a _) (NoRepRational b _)  = a `compare` b
 312 cmpLit lit1                lit2                 | litTag lit1 _LT_ litTag lit2 = LT
 313                                                 | otherwise                    = GT
 314
 315 litTag (MachChar      _)   = ILIT(1)
 316 litTag (MachStr       _)   = ILIT(2)
 317 litTag (MachAddr      _)   = ILIT(3)
 318 litTag (MachInt       _ _) = ILIT(4)
 319 litTag (MachFloat     _)   = ILIT(5)
 320 litTag (MachDouble    _)   = ILIT(6)
 321 litTag (MachLitLit    _ _) = ILIT(7)
 322 litTag (NoRepStr      _ _) = ILIT(8)
 323 litTag (NoRepInteger  _ _) = ILIT(9)
 324 litTag (NoRepRational _ _) = ILIT(10)
 325 \end{code}
 326
 327         Printing
 328         ~~~~~~~~
 329 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
 330   exceptions: MachFloat and MachAddr get an initial keyword prefix
 331
 332 * NoRep things get an initial keyword prefix (e.g. _integer_ 3)
 333
 334 \begin{code}
 335 pprLit lit
 336   = getPprStyle $ \ sty ->
 337     let
 338       code_style = codeStyle sty
 339     in
 340     case lit of
 341       MachChar ch | code_style     -> hcat [ptext SLIT("(C_)"), char '\'',
 342                                             text (charToC ch), char '\'']
 343                   | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\''
 344                   | otherwise      -> text ['\'', ch, '\'']
 345
 346       MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s)))
 347                 | otherwise  -> pprFSAsString s
 348
 349
 350       NoRepStr s ty | code_style -> pprPanic "NoRep in code style" (ppr lit)
 351                     | otherwise  -> ptext SLIT("__string") <+> pprFSAsString s
 352
 353       MachInt i signed | code_style && out_of_range
 354                        -> pprPanic "" (hsep [text "ERROR: Int ", text (show i),
 355                                              text "out of range",
 356                                              brackets (ppr range_min <+> text ".."
 357                                                         <+> ppr range_max)])
 358                         -- in interface files, parenthesize raw negative ints.
 359                         -- this avoids problems like {-1} being interpreted
 360                         -- as a comment starter. -}
 361                        | ifaceStyle sty && i < 0 -> parens (integer i)
 362                         -- avoid a problem whereby gcc interprets the constant
 363                         -- minInt as unsigned.
 364                        | code_style && i == (toInteger (minBound :: Int))
 365                                 -> parens (hcat [integer (i+1), text "-1"])
 366                        | otherwise -> integer i
 367
 368                        where
 369                         range_min = if signed then minInt else 0
 370                         range_max = maxInt
 371                         out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
 372
 373       MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f
 374                   | otherwise  -> ptext SLIT("__float") <+> rational f
 375
 376       MachDouble d | ifaceStyle sty && d < 0 -> parens (rational d)
 377                    | otherwise -> rational d
 378
 379       MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
 380                  | otherwise  -> ptext SLIT("__addr") <+> integer p
 381
 382       NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
 383                        | otherwise  -> ptext SLIT("__integer") <+> integer i
 384
 385       NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
 386                         | otherwise  -> hsep [ptext SLIT("__rational"), integer (numerator r),
 387                                                                         integer (denominator r)]
 388
 389       MachLitLit s ty | code_style -> ptext s
 390                       | otherwise  -> parens (hsep [ptext SLIT("__litlit"),
 391                                                     pprFSAsString s,
 392                                                     pprParendType ty])
 393 \end{code}
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398 \subsection{Hashing
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 Hash values should be zero or a positive integer.  No negatives please.
 403 (They mess up the UniqFM for some reason.)
 404
 405 \begin{code}
 406 hashCon :: Con -> Int
 407 hashCon (DataCon dc)  = hashName (dataConName dc)
 408 hashCon (PrimOp op)   = primOpTag op + 500      -- Keep it out of range of common ints
 409 hashCon (Literal lit) = hashLiteral lit
 410 hashCon other         = pprTrace "hashCon" (ppr other) 0
 411
 412 hashLiteral :: Literal -> Int
 413 hashLiteral (MachChar c)        = ord c + 1000  -- Keep it out of range of common ints
 414 hashLiteral (MachStr s)         = hashFS s
 415 hashLiteral (MachAddr i)        = hashInteger i
 416 hashLiteral (MachInt i _)       = hashInteger i
 417 hashLiteral (MachInt64 i _)     = hashInteger i
 418 hashLiteral (MachFloat r)       = hashRational r
 419 hashLiteral (MachDouble r)      = hashRational r
 420 hashLiteral (MachLitLit s _)    = hashFS s
 421 hashLiteral (NoRepStr s _)      = hashFS s
 422 hashLiteral (NoRepInteger i _)  = hashInteger i
 423 hashLiteral (NoRepRational r _) = hashRational r
 424
 425 hashRational :: Rational -> Int
 426 hashRational r = hashInteger (numerator r)
 427
 428 hashInteger :: Integer -> Int
 429 hashInteger i = abs (fromInteger (i `rem` 10000))
 430
 431 hashFS :: FAST_STRING -> Int
 432 hashFS s = IBOX( uniqueOfFS s )
 433 \end{code}
 434