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
11 , isLitLitLit, maybeLitLit, litSize
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.
127 -- lit-lits only work for via-C compilation, hence they
128 -- are deprecated. The string is emitted verbatim into
129 -- the C file, and can therefore be any C expression,
130 -- macro call, #defined constant etc.
131 | MachLitLit FastString Type -- Type might be Addr# or Int# etc
134 Binary instance: must do this manually, because we don't want the type
135 arg of MachLitLit involved.
138 instance Binary Literal where
139 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
140 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
141 put_ bh (MachNullAddr) = do putByte bh 2
142 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
143 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
144 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
145 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
146 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
147 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
148 put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
149 put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
160 return (MachNullAddr)
166 return (MachInt64 ae)
172 return (MachWord64 ag)
175 return (MachFloat ah)
178 return (MachDouble ai)
182 return (MachLabel aj mb)
185 return (MachLitLit ak (error "MachLitLit: no type"))
189 instance Outputable Literal where
192 instance Show Literal where
193 showsPrec p lit = showsPrecSDoc p (ppr lit)
195 instance Eq Literal where
196 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
197 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
199 instance Ord Literal where
200 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
201 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
202 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
203 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
204 compare a b = cmpLit a b
211 mkMachInt, mkMachWord, mkMachInt64, mkMachWord64 :: Integer -> Literal
213 mkMachInt x = -- ASSERT2( inIntRange x, integer x )
214 -- Not true: you can write out of range Int# literals
215 -- For example, one can write (intToWord# 0xffff0000) to
216 -- get a particular Word bit-pattern, and there's no other
217 -- convenient way to write such literals, which is why we allow it.
219 mkMachWord x = -- ASSERT2( inWordRange x, integer x )
221 mkMachInt64 x = MachInt64 x
222 mkMachWord64 x = MachWord64 x
224 inIntRange, inWordRange :: Integer -> Bool
225 inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
226 inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
228 inCharRange :: Int -> Bool
229 inCharRange c = c >= 0 && c <= tARGET_MAX_CHAR
231 isZeroLit :: Literal -> Bool
232 isZeroLit (MachInt 0) = True
233 isZeroLit (MachInt64 0) = True
234 isZeroLit (MachWord 0) = True
235 isZeroLit (MachWord64 0) = True
236 isZeroLit (MachFloat 0) = True
237 isZeroLit (MachDouble 0) = True
238 isZeroLit other = False
244 word2IntLit, int2WordLit,
245 narrow8IntLit, narrow16IntLit, narrow32IntLit,
246 narrow8WordLit, narrow16WordLit, narrow32WordLit,
247 char2IntLit, int2CharLit,
248 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
249 float2DoubleLit, double2FloatLit
250 :: Literal -> Literal
252 word2IntLit (MachWord w)
253 | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
254 | otherwise = MachInt w
256 int2WordLit (MachInt i)
257 | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
258 | otherwise = MachWord i
260 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
261 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
262 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
263 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
264 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
265 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
267 char2IntLit (MachChar c) = MachInt (toInteger c)
268 int2CharLit (MachInt i) = MachChar (fromInteger i)
270 float2IntLit (MachFloat f) = MachInt (truncate f)
271 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
273 double2IntLit (MachDouble f) = MachInt (truncate f)
274 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
276 float2DoubleLit (MachFloat f) = MachDouble f
277 double2FloatLit (MachDouble d) = MachFloat d
279 nullAddrLit :: Literal
280 nullAddrLit = MachNullAddr
286 isLitLitLit (MachLitLit _ _) = True
287 isLitLitLit _ = False
289 maybeLitLit (MachLitLit s t) = Just (s,t)
290 maybeLitLit _ = Nothing
292 litIsTrivial :: Literal -> Bool
293 -- True if there is absolutely no penalty to duplicating the literal
294 -- c.f. CoreUtils.exprIsTrivial
295 -- False principally of strings
296 litIsTrivial (MachStr _) = False
297 litIsTrivial other = True
299 litIsDupable :: Literal -> Bool
300 -- True if code space does not go bad if we duplicate this literal
301 -- c.f. CoreUtils.exprIsDupable
302 -- Currently we treat it just like litIsTrivial
303 litIsDupable (MachStr _) = False
304 litIsDupable other = True
306 litSize :: Literal -> Int
307 -- Used by CoreUnfold.sizeExpr
308 litSize (MachStr str) = 1 + (lengthFS str `div` 4)
309 -- Every literal has size at least 1, otherwise
311 -- might be too small
318 literalType :: Literal -> Type
319 literalType (MachChar _) = charPrimTy
320 literalType (MachStr _) = addrPrimTy
321 literalType (MachNullAddr) = addrPrimTy
322 literalType (MachInt _) = intPrimTy
323 literalType (MachWord _) = wordPrimTy
324 literalType (MachInt64 _) = int64PrimTy
325 literalType (MachWord64 _) = word64PrimTy
326 literalType (MachFloat _) = floatPrimTy
327 literalType (MachDouble _) = doublePrimTy
328 literalType (MachLabel _ _) = addrPrimTy
329 literalType (MachLitLit _ ty) = ty
333 literalPrimRep :: Literal -> PrimRep
335 literalPrimRep (MachChar _) = CharRep
336 literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
337 literalPrimRep (MachNullAddr) = AddrRep
338 literalPrimRep (MachInt _) = IntRep
339 literalPrimRep (MachWord _) = WordRep
340 literalPrimRep (MachInt64 _) = Int64Rep
341 literalPrimRep (MachWord64 _) = Word64Rep
342 literalPrimRep (MachFloat _) = FloatRep
343 literalPrimRep (MachDouble _) = DoubleRep
344 literalPrimRep (MachLabel _ _) = AddrRep
345 literalPrimRep (MachLitLit _ ty) = typePrimRep ty
352 cmpLit (MachChar a) (MachChar b) = a `compare` b
353 cmpLit (MachStr a) (MachStr b) = a `compare` b
354 cmpLit (MachNullAddr) (MachNullAddr) = EQ
355 cmpLit (MachInt a) (MachInt b) = a `compare` b
356 cmpLit (MachWord a) (MachWord b) = a `compare` b
357 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
358 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
359 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
360 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
361 cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
362 cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
363 cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
366 litTag (MachChar _) = _ILIT(1)
367 litTag (MachStr _) = _ILIT(2)
368 litTag (MachNullAddr) = _ILIT(3)
369 litTag (MachInt _) = _ILIT(4)
370 litTag (MachWord _) = _ILIT(5)
371 litTag (MachInt64 _) = _ILIT(6)
372 litTag (MachWord64 _) = _ILIT(7)
373 litTag (MachFloat _) = _ILIT(8)
374 litTag (MachDouble _) = _ILIT(9)
375 litTag (MachLabel _ _) = _ILIT(10)
376 litTag (MachLitLit _ _) = _ILIT(11)
381 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
382 exceptions: MachFloat gets an initial keyword prefix.
386 = getPprStyle $ \ sty ->
388 code_style = codeStyle sty
391 MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)]
392 | otherwise -> pprHsChar ch
394 MachStr s | code_style -> pprFSInCStyle s
395 | otherwise -> pprHsString s
396 -- Warning: printing MachStr in code_style assumes it contains
397 -- only characters '\0'..'\xFF'!
399 MachInt i | code_style && i == tARGET_MIN_INT -> parens (integer (i+1) <> text "-1")
400 -- Avoid a problem whereby gcc interprets
401 -- the constant minInt as unsigned.
402 | otherwise -> pprIntVal i
404 MachInt64 i | code_style -> pprIntVal i -- Same problem with gcc???
405 | otherwise -> ptext SLIT("__int64") <+> integer i
407 MachWord w | code_style -> pprHexVal w
408 | otherwise -> ptext SLIT("__word") <+> integer w
410 MachWord64 w | code_style -> pprHexVal w
411 | otherwise -> ptext SLIT("__word64") <+> integer w
413 MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> code_rational f
414 | otherwise -> ptext SLIT("__float") <+> rational f
416 MachDouble d | code_style -> code_rational d
417 | otherwise -> rational d
419 MachNullAddr | code_style -> ptext SLIT("(void*)0")
420 | otherwise -> ptext SLIT("__NULL")
423 | code_style -> ptext SLIT("(&") <> ftext l <> char ')'
424 | otherwise -> ptext SLIT("__label") <+>
426 Nothing -> pprHsString l
427 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
429 MachLitLit s ty | code_style -> ftext s
430 | otherwise -> parens (hsep [ptext SLIT("__litlit"),
434 -- negative floating literals in code style need parentheses to avoid
435 -- interacting with surrounding syntax.
436 code_rational d | d < 0 = parens (rational d)
437 | otherwise = rational d
439 pprIntVal :: Integer -> SDoc
440 -- Print negative integers with parens to be sure it's unambiguous
441 pprIntVal i | i < 0 = parens (integer i)
442 | otherwise = integer i
444 pprHexVal :: Integer -> SDoc
445 -- Print in C hex format: 0x13fa
446 pprHexVal 0 = ptext SLIT("0x0")
447 pprHexVal w = ptext SLIT("0x") <> go w
450 go w = go quot <> dig
452 (quot,rem) = w `quotRem` 16
453 dig | rem < 10 = char (chr (fromInteger rem + ord '0'))
454 | otherwise = char (chr (fromInteger rem - 10 + ord 'a'))
458 %************************************************************************
462 %************************************************************************
464 Hash values should be zero or a positive integer. No negatives please.
465 (They mess up the UniqFM for some reason.)
468 hashLiteral :: Literal -> Int
469 hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints
470 hashLiteral (MachStr s) = hashFS s
471 hashLiteral (MachNullAddr) = 0
472 hashLiteral (MachInt i) = hashInteger i
473 hashLiteral (MachInt64 i) = hashInteger i
474 hashLiteral (MachWord i) = hashInteger i
475 hashLiteral (MachWord64 i) = hashInteger i
476 hashLiteral (MachFloat r) = hashRational r
477 hashLiteral (MachDouble r) = hashRational r
478 hashLiteral (MachLabel s _) = hashFS s
479 hashLiteral (MachLitLit s _) = hashFS s
481 hashRational :: Rational -> Int
482 hashRational r = hashInteger (numerator r)
484 hashInteger :: Integer -> Int
485 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
486 -- The 1+ is to avoid zero, which is a Bad Number
487 -- since we use * to combine hash values
489 hashFS :: FastString -> Int
490 hashFS s = iBox (uniqueOfFS s)