2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
7 #include "HsVersions.h"
12 mkMachInt, mkMachWord,
13 literalType, literalPrimRep,
15 isNoRepLit, isLitLitLit
22 import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract
23 import TysPrim ( getPrimRepInfo,
24 addrPrimTy, intPrimTy, floatPrimTy,
25 doublePrimTy, charPrimTy, wordPrimTy )
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
39 So-called @Literals@ are {\em either}:
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.
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.
56 | MachAddr Integer -- whatever this machine thinks is a "pointer"
58 | MachInt Integer -- for the numeric types, these are
59 Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
64 | MachLitLit FAST_STRING
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.
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
80 mkMachInt, mkMachWord :: Integer -> Literal
82 mkMachInt x = MachInt x True{-signed-}
83 mkMachWord x = MachInt x False{-unsigned-}
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
97 -- now we *know* the tags are different, so...
99 | tag1 _LT_ tag2 = LT_
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)
116 tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
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 }
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 }
131 isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
132 isNoRepLit (NoRepInteger _ _) = True
133 isNoRepLit (NoRepRational _ _) = True
136 isLitLitLit (MachLitLit _ _) = True
137 isLitLitLit _ = False
141 literalType :: Literal -> Type
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
156 literalPrimRep :: Literal -> PrimRep
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
166 literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
167 literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
168 literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
172 The boring old output stuff:
174 ppCast :: PprStyle -> FAST_STRING -> Doc
175 ppCast PprForC cast = ptext cast
178 -- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
179 -- exceptions: MachFloat and MachAddr get an initial keyword prefix
181 -- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
183 instance Outputable Literal where
184 ppr sty (MachChar ch)
188 PprForC -> charToC ch
189 PprForAsm _ _ -> charToC ch
190 PprInterface -> charToEasyHaskell ch
193 hcat [ppCast sty SLIT("(C_)"), char '\'', text char_encoding, char '\'']
196 | codeStyle sty = hcat [char '"', text (stringToC (_UNPK_ s)), char '"']
197 | otherwise = text (show (_UNPK_ s))
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))]
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")
208 | otherwise = integer i
211 range_min = if signed then minInt else 0
213 out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
215 ppr sty (MachFloat f)
216 | codeStyle sty = hcat [ppCast sty SLIT("(StgFloat)"), rational f]
217 | otherwise = hcat [ptext SLIT("_float_ "), rational f]
219 ppr sty (MachDouble d) = rational d
222 | codeStyle sty = hcat [ppCast sty SLIT("(void*)"), integer p]
223 | otherwise = hcat [ptext SLIT("_addr_ "), integer p]
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]
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)]
233 ppr sty (MachLitLit s k)
234 | codeStyle sty = ptext s
235 | otherwise = hcat [ptext SLIT("_litlit_ "), ppPrimRep k, char ' ', text (show (_UNPK_ s))]
237 showLiteral :: PprStyle -> Literal -> String
238 showLiteral sty lit = show (ppr sty lit)