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