2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
8 ( Literal(..) -- Exported to ParseIface
9 , mkMachInt, mkMachWord
10 , mkMachInt64, mkMachWord64
12 , litIsDupable, litIsTrivial
13 , literalType, literalPrimRep
16 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
19 , word2IntLit, int2WordLit
20 , narrow8IntLit, narrow16IntLit, narrow32IntLit
21 , narrow8WordLit, narrow16WordLit, narrow32WordLit
22 , char2IntLit, int2CharLit
23 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
24 , nullAddrLit, float2DoubleLit, double2FloatLit
27 #include "HsVersions.h"
29 import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
30 intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
32 import PrimRep ( PrimRep(..) )
33 import TcType ( Type, tcCmpType )
34 import Type ( typePrimRep )
35 import PprType ( pprParendType )
36 import CStrings ( pprFSInCStyle )
42 import Util ( thenCmp )
44 import Ratio ( numerator )
45 import FastString ( uniqueOfFS, lengthFS )
46 import DATA_INT ( Int8, Int16, Int32 )
47 import DATA_WORD ( Word8, Word16, Word32 )
48 import Char ( ord, chr )
53 %************************************************************************
57 %************************************************************************
59 If we're compiling with GHC (and we're not cross-compiling), then we
60 know that minBound and maxBound :: Int are the right values for the
61 target architecture. Otherwise, we assume -2^31 and 2^31-1
62 respectively (which will be wrong on a 64-bit machine).
65 tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer
66 #if __GLASGOW_HASKELL__
67 tARGET_MIN_INT = toInteger (minBound :: Int)
68 tARGET_MAX_INT = toInteger (maxBound :: Int)
70 tARGET_MIN_INT = -2147483648
71 tARGET_MAX_INT = 2147483647
73 tARGET_MAX_WORD = (tARGET_MAX_INT * 2) + 1
75 tARGET_MAX_CHAR :: Int
76 tARGET_MAX_CHAR = 0x10ffff
80 %************************************************************************
84 %************************************************************************
86 So-called @Literals@ are {\em either}:
89 An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
90 which is presumed to be surrounded by appropriate constructors
91 (@mKINT@, etc.), so that the overall thing makes sense.
93 An Integer, Rational, or String literal whose representation we are
94 {\em uncommitted} about; i.e., the surrounding with constructors,
95 function applications, etc., etc., has not yet been done.
101 -- First the primitive guys
102 MachChar Int -- Char# At least 31 bits
105 | MachNullAddr -- the NULL pointer, the only pointer value
106 -- that can be represented as a Literal.
108 | MachInt Integer -- Int# At least WORD_SIZE_IN_BITS bits
109 | MachInt64 Integer -- Int64# At least 64 bits
110 | MachWord Integer -- Word# At least WORD_SIZE_IN_BITS bits
111 | MachWord64 Integer -- Word64# At least 64 bits
114 | MachDouble Rational
116 -- MachLabel is used (only) for the literal derived from a
117 -- "foreign label" declaration.
118 -- string argument is the name of a symbol. This literal
119 -- refers to the *address* of the label.
120 | MachLabel FastString -- always an Addr#
121 (Maybe Int) -- the size (in bytes) of the arguments
122 -- the label expects. Only applicable with
124 -- Just x => "@<x>" will be appended to label
125 -- name when emitting asm.
131 instance Binary Literal where
132 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
133 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
134 put_ bh (MachNullAddr) = do putByte bh 2
135 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
136 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
137 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
138 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
139 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
140 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
141 put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
152 return (MachNullAddr)
158 return (MachInt64 ae)
164 return (MachWord64 ag)
167 return (MachFloat ah)
170 return (MachDouble ai)
174 return (MachLabel aj mb)
178 instance Outputable Literal where
181 instance Show Literal where
182 showsPrec p lit = showsPrecSDoc p (ppr lit)
184 instance Eq Literal where
185 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
186 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
188 instance Ord Literal where
189 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
190 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
191 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
192 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
193 compare a b = cmpLit a b
200 mkMachInt, mkMachWord, mkMachInt64, mkMachWord64 :: Integer -> Literal
202 mkMachInt x = -- ASSERT2( inIntRange x, integer x )
203 -- Not true: you can write out of range Int# literals
204 -- For example, one can write (intToWord# 0xffff0000) to
205 -- get a particular Word bit-pattern, and there's no other
206 -- convenient way to write such literals, which is why we allow it.
208 mkMachWord x = -- ASSERT2( inWordRange x, integer x )
210 mkMachInt64 x = MachInt64 x
211 mkMachWord64 x = MachWord64 x
213 inIntRange, inWordRange :: Integer -> Bool
214 inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
215 inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
217 inCharRange :: Int -> Bool
218 inCharRange c = c >= 0 && c <= tARGET_MAX_CHAR
220 isZeroLit :: Literal -> Bool
221 isZeroLit (MachInt 0) = True
222 isZeroLit (MachInt64 0) = True
223 isZeroLit (MachWord 0) = True
224 isZeroLit (MachWord64 0) = True
225 isZeroLit (MachFloat 0) = True
226 isZeroLit (MachDouble 0) = True
227 isZeroLit other = False
233 word2IntLit, int2WordLit,
234 narrow8IntLit, narrow16IntLit, narrow32IntLit,
235 narrow8WordLit, narrow16WordLit, narrow32WordLit,
236 char2IntLit, int2CharLit,
237 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
238 float2DoubleLit, double2FloatLit
239 :: Literal -> Literal
241 word2IntLit (MachWord w)
242 | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
243 | otherwise = MachInt w
245 int2WordLit (MachInt i)
246 | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
247 | otherwise = MachWord i
249 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
250 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
251 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
252 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
253 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
254 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
256 char2IntLit (MachChar c) = MachInt (toInteger c)
257 int2CharLit (MachInt i) = MachChar (fromInteger i)
259 float2IntLit (MachFloat f) = MachInt (truncate f)
260 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
262 double2IntLit (MachDouble f) = MachInt (truncate f)
263 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
265 float2DoubleLit (MachFloat f) = MachDouble f
266 double2FloatLit (MachDouble d) = MachFloat d
268 nullAddrLit :: Literal
269 nullAddrLit = MachNullAddr
275 litIsTrivial :: Literal -> Bool
276 -- True if there is absolutely no penalty to duplicating the literal
277 -- c.f. CoreUtils.exprIsTrivial
278 -- False principally of strings
279 litIsTrivial (MachStr _) = False
280 litIsTrivial other = True
282 litIsDupable :: Literal -> Bool
283 -- True if code space does not go bad if we duplicate this literal
284 -- c.f. CoreUtils.exprIsDupable
285 -- Currently we treat it just like litIsTrivial
286 litIsDupable (MachStr _) = False
287 litIsDupable other = True
289 litSize :: Literal -> Int
290 -- Used by CoreUnfold.sizeExpr
291 litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
292 -- Every literal has size at least 1, otherwise
294 -- might be too small
295 -- [Sept03: make literal strings a bit bigger to avoid fruitless
296 -- duplication of little strings]
303 literalType :: Literal -> Type
304 literalType (MachChar _) = charPrimTy
305 literalType (MachStr _) = addrPrimTy
306 literalType (MachNullAddr) = addrPrimTy
307 literalType (MachInt _) = intPrimTy
308 literalType (MachWord _) = wordPrimTy
309 literalType (MachInt64 _) = int64PrimTy
310 literalType (MachWord64 _) = word64PrimTy
311 literalType (MachFloat _) = floatPrimTy
312 literalType (MachDouble _) = doublePrimTy
313 literalType (MachLabel _ _) = addrPrimTy
317 literalPrimRep :: Literal -> PrimRep
319 literalPrimRep (MachChar _) = CharRep
320 literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
321 literalPrimRep (MachNullAddr) = AddrRep
322 literalPrimRep (MachInt _) = IntRep
323 literalPrimRep (MachWord _) = WordRep
324 literalPrimRep (MachInt64 _) = Int64Rep
325 literalPrimRep (MachWord64 _) = Word64Rep
326 literalPrimRep (MachFloat _) = FloatRep
327 literalPrimRep (MachDouble _) = DoubleRep
328 literalPrimRep (MachLabel _ _) = AddrRep
335 cmpLit (MachChar a) (MachChar b) = a `compare` b
336 cmpLit (MachStr a) (MachStr b) = a `compare` b
337 cmpLit (MachNullAddr) (MachNullAddr) = EQ
338 cmpLit (MachInt a) (MachInt b) = a `compare` b
339 cmpLit (MachWord a) (MachWord b) = a `compare` b
340 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
341 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
342 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
343 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
344 cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
345 cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
348 litTag (MachChar _) = _ILIT(1)
349 litTag (MachStr _) = _ILIT(2)
350 litTag (MachNullAddr) = _ILIT(3)
351 litTag (MachInt _) = _ILIT(4)
352 litTag (MachWord _) = _ILIT(5)
353 litTag (MachInt64 _) = _ILIT(6)
354 litTag (MachWord64 _) = _ILIT(7)
355 litTag (MachFloat _) = _ILIT(8)
356 litTag (MachDouble _) = _ILIT(9)
357 litTag (MachLabel _ _) = _ILIT(10)
362 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
363 exceptions: MachFloat gets an initial keyword prefix.
367 = getPprStyle $ \ sty ->
369 code_style = codeStyle sty
372 MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)]
373 | otherwise -> pprHsChar ch
375 MachStr s | code_style -> pprFSInCStyle s
376 | otherwise -> pprHsString s
377 -- Warning: printing MachStr in code_style assumes it contains
378 -- only characters '\0'..'\xFF'!
380 MachInt i | code_style && i == tARGET_MIN_INT -> parens (integer (i+1) <> text "-1")
381 -- Avoid a problem whereby gcc interprets
382 -- the constant minInt as unsigned.
383 | otherwise -> pprIntVal i
385 MachInt64 i | code_style -> pprIntVal i -- Same problem with gcc???
386 | otherwise -> ptext SLIT("__int64") <+> integer i
388 MachWord w | code_style -> pprHexVal w
389 | otherwise -> ptext SLIT("__word") <+> integer w
391 MachWord64 w | code_style -> pprHexVal w
392 | otherwise -> ptext SLIT("__word64") <+> integer w
394 MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> code_rational f
395 | otherwise -> ptext SLIT("__float") <+> rational f
397 MachDouble d | code_style -> code_rational d
398 | otherwise -> rational d
400 MachNullAddr | code_style -> ptext SLIT("(void*)0")
401 | otherwise -> ptext SLIT("__NULL")
404 | code_style -> ptext SLIT("(&") <> ftext l <> char ')'
405 | otherwise -> ptext SLIT("__label") <+>
407 Nothing -> pprHsString l
408 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
410 -- negative floating literals in code style need parentheses to avoid
411 -- interacting with surrounding syntax.
412 code_rational d | d < 0 = parens (rational d)
413 | otherwise = rational d
415 pprIntVal :: Integer -> SDoc
416 -- Print negative integers with parens to be sure it's unambiguous
417 pprIntVal i | i < 0 = parens (integer i)
418 | otherwise = integer i
420 pprHexVal :: Integer -> SDoc
421 -- Print in C hex format: 0x13fa
422 pprHexVal 0 = ptext SLIT("0x0")
423 pprHexVal w = ptext SLIT("0x") <> go w
426 go w = go quot <> dig
428 (quot,rem) = w `quotRem` 16
429 dig | rem < 10 = char (chr (fromInteger rem + ord '0'))
430 | otherwise = char (chr (fromInteger rem - 10 + ord 'a'))
434 %************************************************************************
438 %************************************************************************
440 Hash values should be zero or a positive integer. No negatives please.
441 (They mess up the UniqFM for some reason.)
444 hashLiteral :: Literal -> Int
445 hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints
446 hashLiteral (MachStr s) = hashFS s
447 hashLiteral (MachNullAddr) = 0
448 hashLiteral (MachInt i) = hashInteger i
449 hashLiteral (MachInt64 i) = hashInteger i
450 hashLiteral (MachWord i) = hashInteger i
451 hashLiteral (MachWord64 i) = hashInteger i
452 hashLiteral (MachFloat r) = hashRational r
453 hashLiteral (MachDouble r) = hashRational r
454 hashLiteral (MachLabel s _) = hashFS s
456 hashRational :: Rational -> Int
457 hashRational r = hashInteger (numerator r)
459 hashInteger :: Integer -> Int
460 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
461 -- The 1+ is to avoid zero, which is a Bad Number
462 -- since we use * to combine hash values
464 hashFS :: FastString -> Int
465 hashFS s = iBox (uniqueOfFS s)