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
31 -- ** Predicates on Literals and their contents
32 , litIsDupable, litIsTrivial
33 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
38 , word2IntLit, int2WordLit
39 , narrow8IntLit, narrow16IntLit, narrow32IntLit
40 , narrow8WordLit, narrow16WordLit, narrow32WordLit
41 , char2IntLit, int2CharLit
42 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
43 , nullAddrLit, float2DoubleLit, double2FloatLit
63 %************************************************************************
67 %************************************************************************
70 -- | So-called 'Literal's are one of:
72 -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
73 -- which is presumed to be surrounded by appropriate constructors
74 -- (@Int#@, etc.), so that the overall thing makes sense.
76 -- * The literal derived from the label mentioned in a \"foreign label\"
77 -- declaration ('MachLabel')
80 -- First the primitive guys
81 MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
83 | MachStr FastString -- ^ A string-literal: stored and emitted
84 -- UTF-8 encoded, we'll arrange to decode it
85 -- at runtime. Also emitted with a @'\0'@
86 -- terminator. Create with 'mkMachString'
88 | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
89 -- that can be represented as a Literal. Create
92 | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
93 | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
94 | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
95 | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
97 | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
98 | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
100 | MachLabel FastString
103 -- ^ A label literal. Parameters:
105 -- 1) The name of the symbol mentioned in the declaration
107 -- 2) The size (in bytes) of the arguments
108 -- the label expects. Only applicable with
109 -- @stdcall@ labels. @Just x@ => @\<x\>@ will
110 -- be appended to label name when emitting assembly.
111 deriving (Data, Typeable)
117 instance Binary Literal where
118 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
119 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
120 put_ bh (MachNullAddr) = do putByte bh 2
121 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
122 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
123 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
124 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
125 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
126 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
127 put_ bh (MachLabel aj mb fod)
142 return (MachNullAddr)
148 return (MachInt64 ae)
154 return (MachWord64 ag)
157 return (MachFloat ah)
160 return (MachDouble ai)
165 return (MachLabel aj mb fod)
169 instance Outputable Literal where
172 instance Show Literal where
173 showsPrec p lit = showsPrecSDoc p (ppr lit)
175 instance Eq Literal where
176 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
177 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
179 instance Ord Literal where
180 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
181 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
182 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
183 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
184 compare a b = cmpLit a b
191 -- | Creates a 'Literal' of type @Int#@
192 mkMachInt :: Integer -> Literal
193 mkMachInt x = -- ASSERT2( inIntRange x, integer x )
194 -- Not true: you can write out of range Int# literals
195 -- For example, one can write (intToWord# 0xffff0000) to
196 -- get a particular Word bit-pattern, and there's no other
197 -- convenient way to write such literals, which is why we allow it.
200 -- | Creates a 'Literal' of type @Word#@
201 mkMachWord :: Integer -> Literal
202 mkMachWord x = -- ASSERT2( inWordRange x, integer x )
205 -- | Creates a 'Literal' of type @Int64#@
206 mkMachInt64 :: Integer -> Literal
207 mkMachInt64 x = MachInt64 x
209 -- | Creates a 'Literal' of type @Word64#@
210 mkMachWord64 :: Integer -> Literal
211 mkMachWord64 x = MachWord64 x
213 -- | Creates a 'Literal' of type @Float#@
214 mkMachFloat :: Rational -> Literal
215 mkMachFloat = MachFloat
217 -- | Creates a 'Literal' of type @Double#@
218 mkMachDouble :: Rational -> Literal
219 mkMachDouble = MachDouble
221 -- | Creates a 'Literal' of type @Char#@
222 mkMachChar :: Char -> Literal
223 mkMachChar = MachChar
225 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
226 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
227 mkMachString :: String -> Literal
228 mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
230 inIntRange, inWordRange :: Integer -> Bool
231 inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
232 inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
234 inCharRange :: Char -> Bool
235 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
237 -- | Tests whether the literal represents a zero of whatever type it is
238 isZeroLit :: Literal -> Bool
239 isZeroLit (MachInt 0) = True
240 isZeroLit (MachInt64 0) = True
241 isZeroLit (MachWord 0) = True
242 isZeroLit (MachWord64 0) = True
243 isZeroLit (MachFloat 0) = True
244 isZeroLit (MachDouble 0) = True
251 word2IntLit, int2WordLit,
252 narrow8IntLit, narrow16IntLit, narrow32IntLit,
253 narrow8WordLit, narrow16WordLit, narrow32WordLit,
254 char2IntLit, int2CharLit,
255 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
256 float2DoubleLit, double2FloatLit
257 :: Literal -> Literal
259 word2IntLit (MachWord w)
260 | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
261 | otherwise = MachInt w
263 int2WordLit (MachInt i)
264 | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD
265 | otherwise = MachWord i
267 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
268 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
269 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
270 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
271 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
272 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
274 char2IntLit (MachChar c) = MachInt (toInteger (ord c))
275 int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
277 float2IntLit (MachFloat f) = MachInt (truncate f)
278 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
280 double2IntLit (MachDouble f) = MachInt (truncate f)
281 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
283 float2DoubleLit (MachFloat f) = MachDouble f
284 double2FloatLit (MachDouble d) = MachFloat d
286 nullAddrLit :: Literal
287 nullAddrLit = MachNullAddr
293 -- | True if there is absolutely no penalty to duplicating the literal.
294 -- False principally of strings
295 litIsTrivial :: Literal -> Bool
296 -- c.f. CoreUtils.exprIsTrivial
297 litIsTrivial (MachStr _) = False
298 litIsTrivial _ = True
300 -- | True if code space does not go bad if we duplicate this literal
301 -- Currently we treat it just like 'litIsTrivial'
302 litIsDupable :: Literal -> Bool
303 -- c.f. CoreUtils.exprIsDupable
304 litIsDupable (MachStr _) = False
305 litIsDupable _ = True
307 litFitsInChar :: Literal -> Bool
308 litFitsInChar (MachInt i)
309 = fromInteger i <= ord minBound
310 && fromInteger i >= ord maxBound
311 litFitsInChar _ = False
317 -- | Find the Haskell 'Type' the literal occupies
318 literalType :: Literal -> Type
319 literalType MachNullAddr = addrPrimTy
320 literalType (MachChar _) = charPrimTy
321 literalType (MachStr _) = 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
335 cmpLit :: Literal -> Literal -> Ordering
336 cmpLit (MachChar a) (MachChar b) = a `compare` b
337 cmpLit (MachStr a) (MachStr b) = a `compare` b
338 cmpLit (MachNullAddr) (MachNullAddr) = EQ
339 cmpLit (MachInt a) (MachInt b) = a `compare` b
340 cmpLit (MachWord a) (MachWord b) = a `compare` b
341 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
342 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
343 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
344 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
345 cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
346 cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
349 litTag :: Literal -> FastInt
350 litTag (MachChar _) = _ILIT(1)
351 litTag (MachStr _) = _ILIT(2)
352 litTag (MachNullAddr) = _ILIT(3)
353 litTag (MachInt _) = _ILIT(4)
354 litTag (MachWord _) = _ILIT(5)
355 litTag (MachInt64 _) = _ILIT(6)
356 litTag (MachWord64 _) = _ILIT(7)
357 litTag (MachFloat _) = _ILIT(8)
358 litTag (MachDouble _) = _ILIT(9)
359 litTag (MachLabel _ _ _) = _ILIT(10)
364 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
365 exceptions: MachFloat gets an initial keyword prefix.
368 pprLit :: Literal -> SDoc
369 pprLit (MachChar ch) = pprHsChar ch
370 pprLit (MachStr s) = pprHsString s
371 pprLit (MachInt i) = pprIntVal i
372 pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i
373 pprLit (MachWord w) = ptext (sLit "__word") <+> integer w
374 pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w
375 pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
376 pprLit (MachDouble d) = rational d
377 pprLit (MachNullAddr) = ptext (sLit "__NULL")
378 pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
380 Nothing -> pprHsString l
381 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
383 pprIntVal :: Integer -> SDoc
384 -- ^ Print negative integers with parens to be sure it's unambiguous
385 pprIntVal i | i < 0 = parens (integer i)
386 | otherwise = integer i
390 %************************************************************************
394 %************************************************************************
396 Hash values should be zero or a positive integer. No negatives please.
397 (They mess up the UniqFM for some reason.)
400 hashLiteral :: Literal -> Int
401 hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
402 hashLiteral (MachStr s) = hashFS s
403 hashLiteral (MachNullAddr) = 0
404 hashLiteral (MachInt i) = hashInteger i
405 hashLiteral (MachInt64 i) = hashInteger i
406 hashLiteral (MachWord i) = hashInteger i
407 hashLiteral (MachWord64 i) = hashInteger i
408 hashLiteral (MachFloat r) = hashRational r
409 hashLiteral (MachDouble r) = hashRational r
410 hashLiteral (MachLabel s _ _) = hashFS s
412 hashRational :: Rational -> Int
413 hashRational r = hashInteger (numerator r)
415 hashInteger :: Integer -> Int
416 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
417 -- The 1+ is to avoid zero, which is a Bad Number
418 -- since we use * to combine hash values
420 hashFS :: FastString -> Int
421 hashFS s = iBox (uniqueOfFS s)