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