git.haskell.org / ghc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
The Backpack patch.
[ghc.git] / compiler / basicTypes / Literal.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module Literal
11 (
12 -- * Main data type
13 Literal(..) -- Exported to ParseIface
14
15 -- ** Creating Literals
16 , mkMachInt, mkMachWord
17 , mkMachInt64, mkMachWord64
18 , mkMachFloat, mkMachDouble
19 , mkMachChar, mkMachString
20 , mkLitInteger
21
22 -- ** Operations on Literals
23 , literalType
24 , absentLiteralOf
25 , pprLiteral
26
27 -- ** Predicates on Literals and their contents
28 , litIsDupable, litIsTrivial, litIsLifted
29 , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
30 , isZeroLit
31 , litFitsInChar
32 , litValue
33
34 -- ** Coercions
35 , word2IntLit, int2WordLit
36 , narrow8IntLit, narrow16IntLit, narrow32IntLit
37 , narrow8WordLit, narrow16WordLit, narrow32WordLit
38 , char2IntLit, int2CharLit
39 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
40 , nullAddrLit, float2DoubleLit, double2FloatLit
41 ) where
42
43 #include "HsVersions.h"
44
45 import TysPrim
46 import PrelNames
47 import Type
48 import TyCon
49 import Outputable
50 import FastString
51 import BasicTypes
52 import Binary
53 import Constants
54 import DynFlags
55 import UniqFM
56 import Util
57
58 import Data.ByteString (ByteString)
59 import Data.Int
60 import Data.Word
61 import Data.Char
62 import Data.Data ( Data )
63 import Numeric ( fromRat )
64
65 {-
66 ************************************************************************
67 * *
68 \subsection{Literals}
69 * *
70 ************************************************************************
71 -}
72
73 -- | So-called 'Literal's are one of:
74 --
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.
78 --
79 -- * The literal derived from the label mentioned in a \"foreign label\"
80 -- declaration ('MachLabel')
81 data Literal
82 = ------------------
83 -- First the primitive guys
84 MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
85
86 | MachStr ByteString -- ^ 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'
90
91 | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value
92 -- that can be represented as a Literal. Create
93 -- with 'nullAddrLit'
94
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'
99
100 | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
101 | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
102
103 | MachLabel FastString
104 (Maybe Int)
105 FunctionOrData
106 -- ^ A label literal. Parameters:
107 --
108 -- 1) The name of the symbol mentioned in the declaration
109 --
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
115 | LitInteger Integer Type -- ^ Integer literals
116 -- See Note [Integer literals]
117 deriving Data
118
119 {-
120 Note [Integer literals]
121 ~~~~~~~~~~~~~~~~~~~~~~~
122 An Integer literal is represented using, well, an Integer, to make it
123 easier to write RULEs for them. They also contain the Integer type, so
124 that e.g. literalType can return the right Type for them.
125
126 They only get converted into real Core,
127 mkInteger [c1, c2, .., cn]
128 during the CorePrep phase, although TidyPgm looks ahead at what the
129 core will be, so that it can see whether it involves CAFs.
130
131 When we initally build an Integer literal, notably when
132 deserialising it from an interface file (see the Binary instance
133 below), we don't have convenient access to the mkInteger Id. So we
134 just use an error thunk, and fill in the real Id when we do tcIfaceLit
135 in TcIface.
136
137
138 Binary instance
139 -}
140
141 instance Binary Literal where
142 put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa
143 put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab
144 put_ bh (MachNullAddr) = do putByte bh 2
145 put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad
146 put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae
147 put_ bh (MachWord af) = do putByte bh 5; put_ bh af
148 put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
149 put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
150 put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
151 put_ bh (MachLabel aj mb fod)
152 = do putByte bh 9
153 put_ bh aj
154 put_ bh mb
155 put_ bh fod
156 put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
157 get bh = do
158 h <- getByte bh
159 case h of
160 0 -> do
161 aa <- get bh
162 return (MachChar aa)
163 1 -> do
164 ab <- get bh
165 return (MachStr ab)
166 2 -> do
167 return (MachNullAddr)
168 3 -> do
169 ad <- get bh
170 return (MachInt ad)
171 4 -> do
172 ae <- get bh
173 return (MachInt64 ae)
174 5 -> do
175 af <- get bh
176 return (MachWord af)
177 6 -> do
178 ag <- get bh
179 return (MachWord64 ag)
180 7 -> do
181 ah <- get bh
182 return (MachFloat ah)
183 8 -> do
184 ai <- get bh
185 return (MachDouble ai)
186 9 -> do
187 aj <- get bh
188 mb <- get bh
189 fod <- get bh
190 return (MachLabel aj mb fod)
191 _ -> do
192 i <- get bh
193 -- See Note [Integer literals]
194 return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
195
196 instance Outputable Literal where
197 ppr lit = pprLiteral (\d -> d) lit
198
199 instance Eq Literal where
200 a == b = case (a `compare` b) of { EQ -> True; _ -> False }
201 a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
202
203 instance Ord Literal where
204 a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
205 a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
206 a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
207 a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
208 compare a b = cmpLit a b
209
210 {-
211 Construction
212 ~~~~~~~~~~~~
213 -}
214
215 -- | Creates a 'Literal' of type @Int#@
216 mkMachInt :: DynFlags -> Integer -> Literal
217 mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
218 MachInt x
219
220 -- | Creates a 'Literal' of type @Word#@
221 mkMachWord :: DynFlags -> Integer -> Literal
222 mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
223 MachWord x
224
225 -- | Creates a 'Literal' of type @Int64#@
226 mkMachInt64 :: Integer -> Literal
227 mkMachInt64 x = MachInt64 x
228
229 -- | Creates a 'Literal' of type @Word64#@
230 mkMachWord64 :: Integer -> Literal
231 mkMachWord64 x = MachWord64 x
232
233 -- | Creates a 'Literal' of type @Float#@
234 mkMachFloat :: Rational -> Literal
235 mkMachFloat = MachFloat
236
237 -- | Creates a 'Literal' of type @Double#@
238 mkMachDouble :: Rational -> Literal
239 mkMachDouble = MachDouble
240
241 -- | Creates a 'Literal' of type @Char#@
242 mkMachChar :: Char -> Literal
243 mkMachChar = MachChar
244
245 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
246 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
247 mkMachString :: String -> Literal
248 -- stored UTF-8 encoded
249 mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
250
251 mkLitInteger :: Integer -> Type -> Literal
252 mkLitInteger = LitInteger
253
254 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
255 inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
256 inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
257
258 inCharRange :: Char -> Bool
259 inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
260
261 -- | Tests whether the literal represents a zero of whatever type it is
262 isZeroLit :: Literal -> Bool
263 isZeroLit (MachInt 0) = True
264 isZeroLit (MachInt64 0) = True
265 isZeroLit (MachWord 0) = True
266 isZeroLit (MachWord64 0) = True
267 isZeroLit (MachFloat 0) = True
268 isZeroLit (MachDouble 0) = True
269 isZeroLit _ = False
270
271 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
272 -- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
273 litValue :: Literal -> Integer
274 litValue (MachChar c) = toInteger $ ord c
275 litValue (MachInt i) = i
276 litValue (MachInt64 i) = i
277 litValue (MachWord i) = i
278 litValue (MachWord64 i) = i
279 litValue (LitInteger i _) = i
280 litValue l = pprPanic "litValue" (ppr l)
281
282 {-
283 Coercions
284 ~~~~~~~~~
285 -}
286
287 narrow8IntLit, narrow16IntLit, narrow32IntLit,
288 narrow8WordLit, narrow16WordLit, narrow32WordLit,
289 char2IntLit, int2CharLit,
290 float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
291 float2DoubleLit, double2FloatLit
292 :: Literal -> Literal
293
294 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
295 word2IntLit dflags (MachWord w)
296 | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
297 | otherwise = MachInt w
298 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
299
300 int2WordLit dflags (MachInt i)
301 | i < 0 = MachWord (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD
302 | otherwise = MachWord i
303 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
304
305 narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8))
306 narrow8IntLit l = pprPanic "narrow8IntLit" (ppr l)
307 narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16))
308 narrow16IntLit l = pprPanic "narrow16IntLit" (ppr l)
309 narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32))
310 narrow32IntLit l = pprPanic "narrow32IntLit" (ppr l)
311 narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
312 narrow8WordLit l = pprPanic "narrow8WordLit" (ppr l)
313 narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
314 narrow16WordLit l = pprPanic "narrow16WordLit" (ppr l)
315 narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
316 narrow32WordLit l = pprPanic "narrow32WordLit" (ppr l)
317
318 char2IntLit (MachChar c) = MachInt (toInteger (ord c))
319 char2IntLit l = pprPanic "char2IntLit" (ppr l)
320 int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
321 int2CharLit l = pprPanic "int2CharLit" (ppr l)
322
323 float2IntLit (MachFloat f) = MachInt (truncate f)
324 float2IntLit l = pprPanic "float2IntLit" (ppr l)
325 int2FloatLit (MachInt i) = MachFloat (fromInteger i)
326 int2FloatLit l = pprPanic "int2FloatLit" (ppr l)
327
328 double2IntLit (MachDouble f) = MachInt (truncate f)
329 double2IntLit l = pprPanic "double2IntLit" (ppr l)
330 int2DoubleLit (MachInt i) = MachDouble (fromInteger i)
331 int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l)
332
333 float2DoubleLit (MachFloat f) = MachDouble f
334 float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l)
335 double2FloatLit (MachDouble d) = MachFloat d
336 double2FloatLit l = pprPanic "double2FloatLit" (ppr l)
337
338 nullAddrLit :: Literal
339 nullAddrLit = MachNullAddr
340
341 {-
342 Predicates
343 ~~~~~~~~~~
344 -}
345
346 -- | True if there is absolutely no penalty to duplicating the literal.
347 -- False principally of strings
348 litIsTrivial :: Literal -> Bool
349 -- c.f. CoreUtils.exprIsTrivial
350 litIsTrivial (MachStr _) = False
351 litIsTrivial (LitInteger {}) = False
352 litIsTrivial _ = True
353
354 -- | True if code space does not go bad if we duplicate this literal
355 -- Currently we treat it just like 'litIsTrivial'
356 litIsDupable :: DynFlags -> Literal -> Bool
357 -- c.f. CoreUtils.exprIsDupable
358 litIsDupable _ (MachStr _) = False
359 litIsDupable dflags (LitInteger i _) = inIntRange dflags i
360 litIsDupable _ _ = True
361
362 litFitsInChar :: Literal -> Bool
363 litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
364 && i <= toInteger (ord maxBound)
365 litFitsInChar _ = False
366
367 litIsLifted :: Literal -> Bool
368 litIsLifted (LitInteger {}) = True
369 litIsLifted _ = False
370
371 {-
372 Types
373 ~~~~~
374 -}
375
376 -- | Find the Haskell 'Type' the literal occupies
377 literalType :: Literal -> Type
378 literalType MachNullAddr = addrPrimTy
379 literalType (MachChar _) = charPrimTy
380 literalType (MachStr _) = addrPrimTy
381 literalType (MachInt _) = intPrimTy
382 literalType (MachWord _) = wordPrimTy
383 literalType (MachInt64 _) = int64PrimTy
384 literalType (MachWord64 _) = word64PrimTy
385 literalType (MachFloat _) = floatPrimTy
386 literalType (MachDouble _) = doublePrimTy
387 literalType (MachLabel _ _ _) = addrPrimTy
388 literalType (LitInteger _ t) = t
389
390 absentLiteralOf :: TyCon -> Maybe Literal
391 -- Return a literal of the appropriate primtive
392 -- TyCon, to use as a placeholder when it doesn't matter
393 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
394
395 absent_lits :: UniqFM Literal
396 absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr)
397 , (charPrimTyConKey, MachChar 'x')
398 , (intPrimTyConKey, MachInt 0)
399 , (int64PrimTyConKey, MachInt64 0)
400 , (floatPrimTyConKey, MachFloat 0)
401 , (doublePrimTyConKey, MachDouble 0)
402 , (wordPrimTyConKey, MachWord 0)
403 , (word64PrimTyConKey, MachWord64 0) ]
404
405 {-
406 Comparison
407 ~~~~~~~~~~
408 -}
409
410 cmpLit :: Literal -> Literal -> Ordering
411 cmpLit (MachChar a) (MachChar b) = a `compare` b
412 cmpLit (MachStr a) (MachStr b) = a `compare` b
413 cmpLit (MachNullAddr) (MachNullAddr) = EQ
414 cmpLit (MachInt a) (MachInt b) = a `compare` b
415 cmpLit (MachWord a) (MachWord b) = a `compare` b
416 cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
417 cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
418 cmpLit (MachFloat a) (MachFloat b) = a `compare` b
419 cmpLit (MachDouble a) (MachDouble b) = a `compare` b
420 cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
421 cmpLit (LitInteger a _) (LitInteger b _) = a `compare` b
422 cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT
423 | otherwise = GT
424
425 litTag :: Literal -> Int
426 litTag (MachChar _) = 1
427 litTag (MachStr _) = 2
428 litTag (MachNullAddr) = 3
429 litTag (MachInt _) = 4
430 litTag (MachWord _) = 5
431 litTag (MachInt64 _) = 6
432 litTag (MachWord64 _) = 7
433 litTag (MachFloat _) = 8
434 litTag (MachDouble _) = 9
435 litTag (MachLabel _ _ _) = 10
436 litTag (LitInteger {}) = 11
437
438 {-
439 Printing
440 ~~~~~~~~
441 * See Note [Printing of literals in Core]
442 -}
443
444 pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
445 pprLiteral _ (MachChar c) = pprPrimChar c
446 pprLiteral _ (MachStr s) = pprHsBytes s
447 pprLiteral _ (MachNullAddr) = text "__NULL"
448 pprLiteral _ (MachInt i) = pprPrimInt i
449 pprLiteral _ (MachInt64 i) = pprPrimInt64 i
450 pprLiteral _ (MachWord w) = pprPrimWord w
451 pprLiteral _ (MachWord64 w) = pprPrimWord64 w
452 pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix
453 pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix
454 pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
455 pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
456 where b = case mb of
457 Nothing -> pprHsString l
458 Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
459
460 pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
461 -- See Note [Printing of literals in Core].
462 pprIntegerVal add_par i | i < 0 = add_par (integer i)
463 | otherwise = integer i
464
465 {-
466 Note [Printing of literals in Core]
467 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
468 The function `add_par` is used to wrap parenthesis around negative integers
469 (`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring
470 an atomic thing (for example function application).
471
472 Although not all Core literals would be valid Haskell, we are trying to stay
473 as close as possible to Haskell syntax in the printing of Core, to make it
474 easier for a Haskell user to read Core.
475
476 To that end:
477 * We do print parenthesis around negative `LitInteger`, because we print
478 `LitInteger` using plain number literals (no prefix or suffix), and plain
479 number literals in Haskell require parenthesis in contexts like function
480 application (i.e. `1 - -1` is not valid Haskell).
481
482 * We don't print parenthesis around other (negative) literals, because they
483 aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's
484 parser).
485
486 Literal Output Output if context requires
487 an atom (if different)
488 ------- ------- ----------------------
489 MachChar 'a'#
490 MachStr "aaa"#
491 MachNullAddr "__NULL"
492 MachInt -1#
493 MachInt64 -1L#
494 MachWord 1##
495 MachWord64 1L##
496 MachFloat -1.0#
497 MachDouble -1.0##
498 LitInteger -1 (-1)
499 MachLabel "__label" ... ("__label" ...)
500 -}
GHC main repository