ghc/compiler/basicTypes/Literal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Literal (
  10         Literal(..),
  11
  12         mkMachInt, mkMachWord,
  13         literalType, literalPrimRep,
  14         showLiteral,
  15         isNoRepLit, isLitLitLit
  16     ) where
  17
  18 IMP_Ubiq(){-uitous-}
  19 IMPORT_1_3(Ratio)
  20
  21 -- friends:
  22 import PrimRep          ( PrimRep(..), ppPrimRep ) -- non-abstract
  23 import TysPrim          ( getPrimRepInfo,
  24                           addrPrimTy, intPrimTy, floatPrimTy,
  25                           doublePrimTy, charPrimTy, wordPrimTy )
  26
  27 -- others:
  28 import CStrings         ( stringToC, charToC, charToEasyHaskell )
  29 import TysWiredIn       ( stringTy )
  30 import Pretty           -- pretty-printing stuff
  31 import Outputable       ( PprStyle(..), codeStyle, ifaceStyle, Outputable(..) )
  32 import Util             ( thenCmp, panic, pprPanic, Ord3(..) )
  33 #if __GLASGOW_HASKELL__ >= 202
  34 import Type
  35 #endif
  36 \end{code}
  37
  38 So-called @Literals@ are {\em either}:
  39 \begin{itemize}
  40 \item
  41 An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
  42 which is presumed to be surrounded by appropriate constructors
  43 (@mKINT@, etc.), so that the overall thing makes sense.
  44 \item
  45 An Integer, Rational, or String literal whose representation we are
  46 {\em uncommitted} about; i.e., the surrounding with constructors,
  47 function applications, etc., etc., has not yet been done.
  48 \end{itemize}
  49
  50 \begin{code}
  51 data Literal
  52   = MachChar    Char
  53   | MachStr     FAST_STRING
  54
  55   | MachAddr    Integer -- whatever this machine thinks is a "pointer"
  56
  57   | MachInt     Integer -- for the numeric types, these are
  58                 Bool    -- True <=> signed (Int#); False <=> unsigned (Word#)
  59
  60   | MachFloat   Rational
  61   | MachDouble  Rational
  62
  63   | MachLitLit  FAST_STRING
  64                 PrimRep
  65
  66   | NoRepStr        FAST_STRING
  67   | NoRepInteger    Integer  Type       -- This Type is always Integer
  68   | NoRepRational   Rational Type       -- This Type is always Rational
  69                         -- We keep these Types in the literal because Rational isn't
  70                         -- (currently) wired in, so we can't conjure up its type out of
  71                         -- thin air.    Integer is, so the type here is really redundant.
  72
  73   -- deriving (Eq, Ord): no, don't want to compare Types
  74   -- The Ord is needed for the FiniteMap used in the lookForConstructor
  75   -- in SimplEnv.  If you declared that lookForConstructor *ignores*
  76   -- constructor-applications with LitArg args, then you could get
  77   -- rid of this Ord.
  78
  79 mkMachInt, mkMachWord :: Integer -> Literal
  80
  81 mkMachInt  x = MachInt x True{-signed-}
  82 mkMachWord x = MachInt x False{-unsigned-}
  83
  84 instance Ord3 Literal where
  85     cmp (MachChar      a)   (MachChar      b)   = a `tcmp` b
  86     cmp (MachStr       a)   (MachStr       b)   = a `tcmp` b
  87     cmp (MachAddr      a)   (MachAddr      b)   = a `tcmp` b
  88     cmp (MachInt       a b) (MachInt       c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
  89     cmp (MachFloat     a)   (MachFloat     b)   = a `tcmp` b
  90     cmp (MachDouble    a)   (MachDouble    b)   = a `tcmp` b
  91     cmp (MachLitLit    a b) (MachLitLit    c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
  92     cmp (NoRepStr      a)   (NoRepStr      b)   = a `tcmp` b
  93     cmp (NoRepInteger  a _) (NoRepInteger  b _) = a `tcmp` b
  94     cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
  95
  96       -- now we *know* the tags are different, so...
  97     cmp other_1 other_2
  98       | tag1 _LT_ tag2 = LT_
  99       | otherwise      = GT_
 100       where
 101         tag1 = tagof other_1
 102         tag2 = tagof other_2
 103
 104         tagof (MachChar      _)   = ILIT(1)
 105         tagof (MachStr       _)   = ILIT(2)
 106         tagof (MachAddr      _)   = ILIT(3)
 107         tagof (MachInt       _ _) = ILIT(4)
 108         tagof (MachFloat     _)   = ILIT(5)
 109         tagof (MachDouble    _)   = ILIT(6)
 110         tagof (MachLitLit    _ _) = ILIT(7)
 111         tagof (NoRepStr      _)   = ILIT(8)
 112         tagof (NoRepInteger  _ _) = ILIT(9)
 113         tagof (NoRepRational _ _) = ILIT(10)
 114
 115 tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
 116
 117 instance Eq Literal where
 118     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 119     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 120
 121 instance Ord Literal where
 122     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 123     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 124     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 125     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 126     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 127 \end{code}
 128
 129 \begin{code}
 130 isNoRepLit (NoRepStr _)         = True -- these are not primitive typed!
 131 isNoRepLit (NoRepInteger  _ _)  = True
 132 isNoRepLit (NoRepRational _ _)  = True
 133 isNoRepLit _                    = False
 134
 135 isLitLitLit (MachLitLit _ _) = True
 136 isLitLitLit _                = False
 137 \end{code}
 138
 139 \begin{code}
 140 literalType :: Literal -> Type
 141
 142 literalType (MachChar _)        = charPrimTy
 143 literalType (MachStr  _)        = addrPrimTy
 144 literalType (MachAddr _)        = addrPrimTy
 145 literalType (MachInt  _ signed) = if signed then intPrimTy else wordPrimTy
 146 literalType (MachFloat _)       = floatPrimTy
 147 literalType (MachDouble _)      = doublePrimTy
 148 literalType (MachLitLit _ k)    = case (getPrimRepInfo k) of { (_,t,_) -> t }
 149 literalType (NoRepInteger  _ t) = t
 150 literalType (NoRepRational _ t) = t
 151 literalType (NoRepStr _)        = stringTy
 152 \end{code}
 153
 154 \begin{code}
 155 literalPrimRep :: Literal -> PrimRep
 156
 157 literalPrimRep (MachChar _)     = CharRep
 158 literalPrimRep (MachStr _)      = AddrRep  -- specifically: "char *"
 159 literalPrimRep (MachAddr  _)    = AddrRep
 160 literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
 161 literalPrimRep (MachFloat _)    = FloatRep
 162 literalPrimRep (MachDouble _)   = DoubleRep
 163 literalPrimRep (MachLitLit _ k) = k
 164 #ifdef DEBUG
 165 literalPrimRep (NoRepInteger  _ _) = panic "literalPrimRep:NoRepInteger"
 166 literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
 167 literalPrimRep (NoRepStr _)        = panic "literalPrimRep:NoRepString"
 168 #endif
 169 \end{code}
 170
 171 The boring old output stuff:
 172 \begin{code}
 173 ppCast :: PprStyle -> FAST_STRING -> Doc
 174 ppCast PprForC cast = ptext cast
 175 ppCast _       _    = empty
 176
 177 -- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
 178 --      exceptions: MachFloat and MachAddr get an initial keyword prefix
 179 --
 180 -- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
 181
 182 instance Outputable Literal where
 183     ppr sty (MachChar ch)
 184       = let
 185             char_encoding
 186               = case sty of
 187                   PprForC       -> charToC ch
 188                   PprForAsm _ _ -> charToC ch
 189                   PprInterface  -> charToEasyHaskell ch
 190                   _             -> [ch]
 191         in
 192         hcat [ppCast sty SLIT("(C_)"), char '\'', text char_encoding, char '\'']
 193
 194     ppr sty (MachStr s)
 195       | codeStyle sty = hcat [char '"', text (stringToC (_UNPK_ s)), char '"']
 196       | otherwise     = text (show (_UNPK_ s))
 197
 198     ppr sty lit@(NoRepStr s)
 199       | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
 200       | otherwise     = hcat [ptext SLIT("_string_ "), text (show (_UNPK_ s))]
 201
 202     ppr sty (MachInt i signed)
 203       | codeStyle sty && out_of_range
 204       = panic ("ERROR: Int " ++ show i ++ " out of range [" ++
 205                 show range_min ++ " .. " ++ show range_max ++ "]\n")
 206
 207       | otherwise = integer i
 208
 209       where
 210         range_min = if signed then minInt else 0
 211         range_max = maxInt
 212         out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
 213
 214     ppr sty (MachFloat f)
 215        | codeStyle sty = hcat [ppCast sty SLIT("(StgFloat)"), rational f]
 216        | otherwise     = hcat [ptext SLIT("_float_ "), rational f]
 217
 218     ppr sty (MachDouble d) = rational d
 219
 220     ppr sty (MachAddr p)
 221        | codeStyle sty = hcat [ppCast sty SLIT("(void*)"), integer p]
 222        | otherwise     = hcat [ptext SLIT("_addr_ "), integer p]
 223
 224     ppr sty lit@(NoRepInteger i _)
 225       | codeStyle sty  = pprPanic "NoRep in code style" (ppr PprDebug lit)
 226       | otherwise      = hsep [ptext SLIT("_integer_ "), integer i]
 227
 228     ppr sty lit@(NoRepRational r _)
 229       | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
 230       | otherwise     = hsep [ptext SLIT("_rational_ "), integer (numerator r), integer (denominator r)]
 231
 232     ppr sty (MachLitLit s k)
 233       | codeStyle  sty = ptext s
 234       | otherwise      = hcat [ptext SLIT("_litlit_ "), ppPrimRep k, char ' ', text (show (_UNPK_ s))]
 235
 236 showLiteral :: PprStyle -> Literal -> String
 237 showLiteral sty lit = show (ppr sty lit)
 238 \end{code}
 239