Whitespace only in basicTypes/Literal.lhs
[ghc.git] / compiler / basicTypes / Literal.lhs
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 \begin{code}
8 {-# LANGUAGE 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
21         -- ** Operations on Literals
22         , literalType
23         , hashLiteral
24         , absentLiteralOf
25
26         -- ** Predicates on Literals and their contents
27         , litIsDupable, litIsTrivial
28         , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
29         , isZeroLit
30         , litFitsInChar
31
32         -- ** Coercions
33         , word2IntLit, int2WordLit
34         , narrow8IntLit, narrow16IntLit, narrow32IntLit
35         , narrow8WordLit, narrow16WordLit, narrow32WordLit
36         , char2IntLit, int2CharLit
37         , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
38         , nullAddrLit, float2DoubleLit, double2FloatLit
39         ) where
40
41 import TysPrim
42 import PrelNames
43 import Type
44 import TyCon
45 import Outputable
46 import FastTypes
47 import FastString
48 import BasicTypes
49 import Binary
50 import Constants
51 import UniqFM
52 import Data.Int
53 import Data.Ratio
54 import Data.Word
55 import Data.Char
56 import Data.Data ( Data, Typeable )
57 import Numeric ( fromRat )
58 \end{code}
59
60
61 %************************************************************************
62 %*                                                                      *
63 \subsection{Literals}
64 %*                                                                      *
65 %************************************************************************
66
67 \begin{code}
68 -- | So-called 'Literal's are one of:
69 --
70 -- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
71 --   which is presumed to be surrounded by appropriate constructors
72 --   (@Int#@, etc.), so that the overall thing makes sense.
73 --
74 -- * The literal derived from the label mentioned in a \"foreign label\"
75 --   declaration ('MachLabel')
76 data Literal
77   =     ------------------
78         -- First the primitive guys
79     MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
80
81   | MachStr     FastString      -- ^ A string-literal: stored and emitted
82                                 -- UTF-8 encoded, we'll arrange to decode it
83                                 -- at runtime.  Also emitted with a @'\0'@
84                                 -- terminator. Create with 'mkMachString'
85
86   | MachNullAddr                -- ^ The @NULL@ pointer, the only pointer value
87                                 -- that can be represented as a Literal. Create
88                                 -- with 'nullAddrLit'
89
90   | MachInt     Integer         -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
91   | MachInt64   Integer         -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
92   | MachWord    Integer         -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
93   | MachWord64  Integer         -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
94
95   | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'
96   | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'
97
98   | MachLabel   FastString
99                 (Maybe Int)
100         FunctionOrData
101                 -- ^ A label literal. Parameters:
102                         --
103                         -- 1) The name of the symbol mentioned in the declaration
104                         --
105                         -- 2) The size (in bytes) of the arguments
106                                 --    the label expects. Only applicable with
107                                 --    @stdcall@ labels. @Just x@ => @\<x\>@ will
108                                 --    be appended to label name when emitting assembly.
109   deriving (Data, Typeable)
110 \end{code}
111
112 Binary instance
113
114 \begin{code}
115 instance Binary Literal where
116     put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa
117     put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab
118     put_ bh (MachNullAddr)    = do putByte bh 2
119     put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad
120     put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae
121     put_ bh (MachWord af)     = do putByte bh 5; put_ bh af
122     put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag
123     put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah
124     put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai
125     put_ bh (MachLabel aj mb fod)
126         = do putByte bh 9
127              put_ bh aj
128              put_ bh mb
129              put_ bh fod
130     get bh = do
131             h <- getByte bh
132             case h of
133               0 -> do
134                     aa <- get bh
135                     return (MachChar aa)
136               1 -> do
137                     ab <- get bh
138                     return (MachStr ab)
139               2 -> do
140                     return (MachNullAddr)
141               3 -> do
142                     ad <- get bh
143                     return (MachInt ad)
144               4 -> do
145                     ae <- get bh
146                     return (MachInt64 ae)
147               5 -> do
148                     af <- get bh
149                     return (MachWord af)
150               6 -> do
151                     ag <- get bh
152                     return (MachWord64 ag)
153               7 -> do
154                     ah <- get bh
155                     return (MachFloat ah)
156               8 -> do
157                     ai <- get bh
158                     return (MachDouble ai)
159               9 -> do
160                     aj <- get bh
161                     mb <- get bh
162                     fod <- get bh
163                     return (MachLabel aj mb fod)
164 \end{code}
165
166 \begin{code}
167 instance Outputable Literal where
168     ppr lit = pprLit lit
169
170 instance Show Literal where
171     showsPrec p lit = showsPrecSDoc p (ppr lit)
172
173 instance Eq Literal where
174     a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
175     a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }
176
177 instance Ord Literal where
178     a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
179     a <  b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
180     a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
181     a >  b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
182     compare a b = cmpLit a b
183 \end{code}
184
185
186         Construction
187         ~~~~~~~~~~~~
188 \begin{code}
189 -- | Creates a 'Literal' of type @Int#@
190 mkMachInt :: Integer -> Literal
191 mkMachInt  x   = -- ASSERT2( inIntRange x,  integer x )
192                  -- Not true: you can write out of range Int# literals
193                  -- For example, one can write (intToWord# 0xffff0000) to
194                  -- get a particular Word bit-pattern, and there's no other
195                  -- convenient way to write such literals, which is why we allow it.
196                  MachInt x
197
198 -- | Creates a 'Literal' of type @Word#@
199 mkMachWord :: Integer -> Literal
200 mkMachWord x   = -- ASSERT2( inWordRange x, integer x )
201                  MachWord x
202
203 -- | Creates a 'Literal' of type @Int64#@
204 mkMachInt64 :: Integer -> Literal
205 mkMachInt64  x = MachInt64 x
206
207 -- | Creates a 'Literal' of type @Word64#@
208 mkMachWord64 :: Integer -> Literal
209 mkMachWord64 x = MachWord64 x
210
211 -- | Creates a 'Literal' of type @Float#@
212 mkMachFloat :: Rational -> Literal
213 mkMachFloat = MachFloat
214
215 -- | Creates a 'Literal' of type @Double#@
216 mkMachDouble :: Rational -> Literal
217 mkMachDouble = MachDouble
218
219 -- | Creates a 'Literal' of type @Char#@
220 mkMachChar :: Char -> Literal
221 mkMachChar = MachChar
222
223 -- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
224 -- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
225 mkMachString :: String -> Literal
226 mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
227
228 inIntRange, inWordRange :: Integer -> Bool
229 inIntRange  x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
230 inWordRange x = x >= 0              && x <= tARGET_MAX_WORD
231
232 inCharRange :: Char -> Bool
233 inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
234
235 -- | Tests whether the literal represents a zero of whatever type it is
236 isZeroLit :: Literal -> Bool
237 isZeroLit (MachInt    0) = True
238 isZeroLit (MachInt64  0) = True
239 isZeroLit (MachWord   0) = True
240 isZeroLit (MachWord64 0) = True
241 isZeroLit (MachFloat  0) = True
242 isZeroLit (MachDouble 0) = True
243 isZeroLit _              = False
244 \end{code}
245
246         Coercions
247         ~~~~~~~~~
248 \begin{code}
249 word2IntLit, int2WordLit,
250   narrow8IntLit, narrow16IntLit, narrow32IntLit,
251   narrow8WordLit, narrow16WordLit, narrow32WordLit,
252   char2IntLit, int2CharLit,
253   float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
254   float2DoubleLit, double2FloatLit
255   :: Literal -> Literal
256
257 word2IntLit (MachWord w)
258   | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
259   | otherwise          = MachInt w
260
261 int2WordLit (MachInt i)
262   | i < 0     = MachWord (1 + tARGET_MAX_WORD + i)      -- (-1)  --->  tARGET_MAX_WORD
263   | otherwise = MachWord i
264
265 narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
266 narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
267 narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
268 narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
269 narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
270 narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
271
272 char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
273 int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
274
275 float2IntLit (MachFloat f) = MachInt   (truncate    f)
276 int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
277
278 double2IntLit (MachDouble f) = MachInt    (truncate    f)
279 int2DoubleLit (MachInt   i) = MachDouble (fromInteger i)
280
281 float2DoubleLit (MachFloat  f) = MachDouble f
282 double2FloatLit (MachDouble d) = MachFloat  d
283
284 nullAddrLit :: Literal
285 nullAddrLit = MachNullAddr
286 \end{code}
287
288         Predicates
289         ~~~~~~~~~~
290 \begin{code}
291 -- | True if there is absolutely no penalty to duplicating the literal.
292 -- False principally of strings
293 litIsTrivial :: Literal -> Bool
294 --      c.f. CoreUtils.exprIsTrivial
295 litIsTrivial (MachStr _) = False
296 litIsTrivial _           = True
297
298 -- | True if code space does not go bad if we duplicate this literal
299 -- Currently we treat it just like 'litIsTrivial'
300 litIsDupable :: Literal -> Bool
301 --      c.f. CoreUtils.exprIsDupable
302 litIsDupable (MachStr _) = False
303 litIsDupable _           = True
304
305 litFitsInChar :: Literal -> Bool
306 litFitsInChar (MachInt i)
307                          = fromInteger i <= ord minBound
308                         && fromInteger i >= ord maxBound
309 litFitsInChar _         = False
310 \end{code}
311
312         Types
313         ~~~~~
314 \begin{code}
315 -- | Find the Haskell 'Type' the literal occupies
316 literalType :: Literal -> Type
317 literalType MachNullAddr    = addrPrimTy
318 literalType (MachChar _)    = charPrimTy
319 literalType (MachStr  _)    = addrPrimTy
320 literalType (MachInt  _)    = intPrimTy
321 literalType (MachWord  _)   = wordPrimTy
322 literalType (MachInt64  _)  = int64PrimTy
323 literalType (MachWord64  _) = word64PrimTy
324 literalType (MachFloat _)   = floatPrimTy
325 literalType (MachDouble _)  = doublePrimTy
326 literalType (MachLabel _ _ _) = addrPrimTy
327
328 absentLiteralOf :: TyCon -> Maybe Literal
329 -- Return a literal of the appropriate primtive
330 -- TyCon, to use as a placeholder when it doesn't matter
331 absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
332
333 absent_lits :: UniqFM Literal
334 absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
335                         , (charPrimTyConKey,    MachChar 'x')
336                         , (intPrimTyConKey,     MachInt 0)
337                         , (int64PrimTyConKey,   MachInt64 0)
338                         , (floatPrimTyConKey,   MachFloat 0)
339                         , (doublePrimTyConKey,  MachDouble 0)
340                         , (wordPrimTyConKey,    MachWord 0)
341                         , (word64PrimTyConKey,  MachWord64 0) ]
342 \end{code}
343
344
345         Comparison
346         ~~~~~~~~~~
347 \begin{code}
348 cmpLit :: Literal -> Literal -> Ordering
349 cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
350 cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
351 cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
352 cmpLit (MachInt       a)   (MachInt        b)   = a `compare` b
353 cmpLit (MachWord      a)   (MachWord       b)   = a `compare` b
354 cmpLit (MachInt64     a)   (MachInt64      b)   = a `compare` b
355 cmpLit (MachWord64    a)   (MachWord64     b)   = a `compare` b
356 cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b
357 cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b
358 cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
359 cmpLit lit1                lit2                 | litTag lit1 <# litTag lit2 = LT
360                                                 | otherwise                  = GT
361
362 litTag :: Literal -> FastInt
363 litTag (MachChar      _)   = _ILIT(1)
364 litTag (MachStr       _)   = _ILIT(2)
365 litTag (MachNullAddr)      = _ILIT(3)
366 litTag (MachInt       _)   = _ILIT(4)
367 litTag (MachWord      _)   = _ILIT(5)
368 litTag (MachInt64     _)   = _ILIT(6)
369 litTag (MachWord64    _)   = _ILIT(7)
370 litTag (MachFloat     _)   = _ILIT(8)
371 litTag (MachDouble    _)   = _ILIT(9)
372 litTag (MachLabel _ _ _)   = _ILIT(10)
373 \end{code}
374
375         Printing
376         ~~~~~~~~
377 * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
378   exceptions: MachFloat gets an initial keyword prefix.
379
380 \begin{code}
381 pprLit :: Literal -> SDoc
382 pprLit (MachChar ch)    = pprHsChar ch
383 pprLit (MachStr s)      = pprHsString s
384 pprLit (MachInt i)      = pprIntVal i
385 pprLit (MachInt64 i)    = ptext (sLit "__int64") <+> integer i
386 pprLit (MachWord w)     = ptext (sLit "__word") <+> integer w
387 pprLit (MachWord64 w)   = ptext (sLit "__word64") <+> integer w
388 pprLit (MachFloat f)    = ptext (sLit "__float") <+> float (fromRat f)
389 pprLit (MachDouble d)   = double (fromRat d)
390 pprLit (MachNullAddr)   = ptext (sLit "__NULL")
391 pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
392     where b = case mb of
393               Nothing -> pprHsString l
394               Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
395
396 pprIntVal :: Integer -> SDoc
397 -- ^ Print negative integers with parens to be sure it's unambiguous
398 pprIntVal i | i < 0     = parens (integer i)
399             | otherwise = integer i
400 \end{code}
401
402
403 %************************************************************************
404 %*                                                                      *
405 \subsection{Hashing}
406 %*                                                                      *
407 %************************************************************************
408
409 Hash values should be zero or a positive integer.  No negatives please.
410 (They mess up the UniqFM for some reason.)
411
412 \begin{code}
413 hashLiteral :: Literal -> Int
414 hashLiteral (MachChar c)        = ord c + 1000  -- Keep it out of range of common ints
415 hashLiteral (MachStr s)         = hashFS s
416 hashLiteral (MachNullAddr)      = 0
417 hashLiteral (MachInt i)         = hashInteger i
418 hashLiteral (MachInt64 i)       = hashInteger i
419 hashLiteral (MachWord i)        = hashInteger i
420 hashLiteral (MachWord64 i)      = hashInteger i
421 hashLiteral (MachFloat r)       = hashRational r
422 hashLiteral (MachDouble r)      = hashRational r
423 hashLiteral (MachLabel s _ _)     = hashFS s
424
425 hashRational :: Rational -> Int
426 hashRational r = hashInteger (numerator r)
427
428 hashInteger :: Integer -> Int
429 hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
430                 -- The 1+ is to avoid zero, which is a Bad Number
431                 -- since we use * to combine hash values
432
433 hashFS :: FastString -> Int
434 hashFS s = iBox (uniqueOfFS s)
435 \end{code}