2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1998
5 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
8 {-# OPTIONS -fno-warn-incomplete-patterns #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 {-# LANGUAGE DeriveDataTypeable #-}
19 Literal(..) -- Exported to ParseIface
21 -- ** Creating Literals
22 , mkMachInt, mkMachWord
23 , mkMachInt64, mkMachWord64
24 , mkMachFloat, mkMachDouble
25 , mkMachChar, mkMachString
27 -- ** Operations on Literals
32 -- ** Predicates on Literals and their contents
33 , litIsDupable, litIsTrivial
34 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
39 , word2IntLit, int2WordLit
40 , narrow8IntLit, narrow16IntLit, narrow32IntLit
41 , narrow8WordLit, narrow16WordLit, narrow32WordLit
42 , char2IntLit, int2CharLit
43 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
44 , nullAddrLit, float2DoubleLit, double2FloatLit
62 import Data.Data( Data, Typeable )
66 %************************************************************************
70 %************************************************************************
73 -- | So-called 'Literal's are one of:
75 -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
76 -- which is presumed to be surrounded by appropriate constructors
77 -- (@Int#@, etc.), so that the overall thing makes sense.
79 -- * The literal derived from the label mentioned in a \"foreign label\"
80 -- declaration ('MachLabel')
83 -- First the primitive guys
84 MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
86 | MachStr FastString -- ^ A string-literal: stored and emitted
87 -- UTF-8 encoded, we'll arrange to decode it
88 -- at runtime. Also emitted with a @'\0'@
89 -- terminator. Create with 'mkMachString'
91 | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
92 -- that can be represented as a Literal. Create
95 | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
96 | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
97 | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
98 | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
100 | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
101 | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
103 | MachLabel FastString
106 -- ^ A label literal. Parameters:
108 -- 1) The name of the symbol mentioned in the declaration
110 -- 2) The size (in bytes) of the arguments
111 -- the label expects. Only applicable with
112 -- @stdcall@ labels. @Just x@ => @\<x\>@ will
113 -- be appended to label name when emitting assembly.
114 deriving (Data, Typeable)
120 instance Binary Literal where
121 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
122 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
123 put_ bh (MachNullAddr) = do putByte bh 2
124 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
125 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
126 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
127 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
128 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
129 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
130 put_ bh (MachLabel aj mb fod)
145 return (MachNullAddr)
151 return (MachInt64 ae)
157 return (MachWord64 ag)
160 return (MachFloat ah)
163 return (MachDouble ai)
168 return (MachLabel aj mb fod)
172 instance Outputable Literal where
175 instance Show Literal where
176 showsPrec p lit = showsPrecSDoc p (ppr lit)
178 instance Eq Literal where
179 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
180 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
182 instance Ord Literal where
183 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
184 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
185 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
186 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
187 compare a b = cmpLit a b
194 -- | Creates a 'Literal' of type @Int#@
195 mkMachInt :: Integer -> Literal
196 mkMachInt x = -- ASSERT2( inIntRange x, integer x )
197 -- Not true: you can write out of range Int# literals
198 -- For example, one can write (intToWord# 0xffff0000) to
199 -- get a particular Word bit-pattern, and there's no other
200 -- convenient way to write such literals, which is why we allow it.
203 -- | Creates a 'Literal' of type @Word#@
204 mkMachWord :: Integer -> Literal
205 mkMachWord x = -- ASSERT2( inWordRange x, integer x )
208 -- | Creates a 'Literal' of type @Int64#@
209 mkMachInt64 :: Integer -> Literal
210 mkMachInt64 x = MachInt64 x
212 -- | Creates a 'Literal' of type @Word64#@
213 mkMachWord64 :: Integer -> Literal
214 mkMachWord64 x = MachWord64 x
216 -- | Creates a 'Literal' of type @Float#@
217 mkMachFloat :: Rational -> Literal
218 mkMachFloat = MachFloat
220 -- | Creates a 'Literal' of type @Double#@
221 mkMachDouble :: Rational -> Literal
222 mkMachDouble = MachDouble
224 -- | Creates a 'Literal' of type @Char#@
225 mkMachChar :: Char -> Literal
226 mkMachChar = MachChar
228 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
229 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
230 mkMachString :: String -> Literal
231 mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
233 inIntRange, inWordRange :: Integer -> Bool
234 inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
235 inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
237 inCharRange :: Char -> Bool
238 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
240 -- | Tests whether the literal represents a zero of whatever type it is
241 isZeroLit :: Literal -> Bool
242 isZeroLit (MachInt 0) = True
243 isZeroLit (MachInt64 0) = True
244 isZeroLit (MachWord 0) = True
245 isZeroLit (MachWord64 0) = True
246 isZeroLit (MachFloat 0) = True
247 isZeroLit (MachDouble 0) = True
254 word2IntLit, int2WordLit,
255 narrow8IntLit, narrow16IntLit, narrow32IntLit,
256 narrow8WordLit, narrow16WordLit, narrow32WordLit,
257 char2IntLit, int2CharLit,
258 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
259 float2DoubleLit, double2FloatLit
260 :: Literal -> Literal
262 word2IntLit (MachWord w)
263 | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
264 | otherwise = MachInt w
266 int2WordLit (MachInt i)
267 | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
268 | otherwise = MachWord i
270 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
271 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
272 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
273 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
274 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
275 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
277 char2IntLit (MachChar c) = MachInt (toInteger (ord c))
278 int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
280 float2IntLit (MachFloat f) = MachInt (truncate f)
281 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
283 double2IntLit (MachDouble f) = MachInt (truncate f)
284 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
286 float2DoubleLit (MachFloat f) = MachDouble f
287 double2FloatLit (MachDouble d) = MachFloat d
289 nullAddrLit :: Literal
290 nullAddrLit = MachNullAddr
296 -- | True if there is absolutely no penalty to duplicating the literal.
297 -- False principally of strings
298 litIsTrivial :: Literal -> Bool
299 -- c.f. CoreUtils.exprIsTrivial
300 litIsTrivial (MachStr _) = False
301 litIsTrivial _ = True
303 -- | True if code space does not go bad if we duplicate this literal
304 -- Currently we treat it just like 'litIsTrivial'
305 litIsDupable :: Literal -> Bool
306 -- c.f. CoreUtils.exprIsDupable
307 litIsDupable (MachStr _) = False
308 litIsDupable _ = True
310 litFitsInChar :: Literal -> Bool
311 litFitsInChar (MachInt i)
312 = fromInteger i <= ord minBound
313 && fromInteger i >= ord maxBound
314 litFitsInChar _ = False
320 -- | Find the Haskell 'Type' the literal occupies
321 literalType :: Literal -> Type
322 literalType MachNullAddr = addrPrimTy
323 literalType (MachChar _) = charPrimTy
324 literalType (MachStr _) = addrPrimTy
325 literalType (MachInt _) = intPrimTy
326 literalType (MachWord _) = wordPrimTy
327 literalType (MachInt64 _) = int64PrimTy
328 literalType (MachWord64 _) = word64PrimTy
329 literalType (MachFloat _) = floatPrimTy
330 literalType (MachDouble _) = doublePrimTy
331 literalType (MachLabel _ _ _) = addrPrimTy
333 absentLiteralOf :: TyCon -> Maybe Literal
334 -- Return a literal of the appropriate primtive
335 -- TyCon, to use as a placeholder when it doesn't matter
336 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
338 absent_lits :: UniqFM Literal
339 absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
340 , (charPrimTyConKey, MachChar 'x')
341 , (intPrimTyConKey, MachInt 0)
342 , (int64PrimTyConKey, MachInt64 0)
343 , (floatPrimTyConKey, MachFloat 0)
344 , (doublePrimTyConKey, MachDouble 0)
345 , (wordPrimTyConKey, MachWord 0)
346 , (word64PrimTyConKey, MachWord64 0) ]
353 cmpLit :: Literal -> Literal -> Ordering
354 cmpLit (MachChar a) (MachChar b) = a `compare` b
355 cmpLit (MachStr a) (MachStr b) = a `compare` b
356 cmpLit (MachNullAddr) (MachNullAddr) = EQ
357 cmpLit (MachInt a) (MachInt b) = a `compare` b
358 cmpLit (MachWord a) (MachWord b) = a `compare` b
359 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
360 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
361 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
362 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
363 cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
364 cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
367 litTag :: Literal -> FastInt
368 litTag (MachChar _) = _ILIT(1)
369 litTag (MachStr _) = _ILIT(2)
370 litTag (MachNullAddr) = _ILIT(3)
371 litTag (MachInt _) = _ILIT(4)
372 litTag (MachWord _) = _ILIT(5)
373 litTag (MachInt64 _) = _ILIT(6)
374 litTag (MachWord64 _) = _ILIT(7)
375 litTag (MachFloat _) = _ILIT(8)
376 litTag (MachDouble _) = _ILIT(9)
377 litTag (MachLabel _ _ _) = _ILIT(10)
382 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
383 exceptions: MachFloat gets an initial keyword prefix.
386 pprLit :: Literal -> SDoc
387 pprLit (MachChar ch) = pprHsChar ch
388 pprLit (MachStr s) = pprHsString s
389 pprLit (MachInt i) = pprIntVal i
390 pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i
391 pprLit (MachWord w) = ptext (sLit "__word") <+> integer w
392 pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w
393 pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
394 pprLit (MachDouble d) = rational d
395 pprLit (MachNullAddr) = ptext (sLit "__NULL")
396 pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
398 Nothing -> pprHsString l
399 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
401 pprIntVal :: Integer -> SDoc
402 -- ^ Print negative integers with parens to be sure it's unambiguous
403 pprIntVal i | i < 0 = parens (integer i)
404 | otherwise = integer i
408 %************************************************************************
412 %************************************************************************
414 Hash values should be zero or a positive integer. No negatives please.
415 (They mess up the UniqFM for some reason.)
418 hashLiteral :: Literal -> Int
419 hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
420 hashLiteral (MachStr s) = hashFS s
421 hashLiteral (MachNullAddr) = 0
422 hashLiteral (MachInt i) = hashInteger i
423 hashLiteral (MachInt64 i) = hashInteger i
424 hashLiteral (MachWord i) = hashInteger i
425 hashLiteral (MachWord64 i) = hashInteger i
426 hashLiteral (MachFloat r) = hashRational r
427 hashLiteral (MachDouble r) = hashRational r
428 hashLiteral (MachLabel s _ _) = hashFS s
430 hashRational :: Rational -> Int
431 hashRational r = hashInteger (numerator r)
433 hashInteger :: Integer -> Int
434 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
435 -- The 1+ is to avoid zero, which is a Bad Number
436 -- since we use * to combine hash values
438 hashFS :: FastString -> Int
439 hashFS s = iBox (uniqueOfFS s)