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