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