Literal.lhs 14.3 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
5
6
7
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[Literal]{@Literal@: Machine literals (unboxed, of course)}

\begin{code}
8
{-# OPTIONS -fno-warn-incomplete-patterns #-}
9
10
11
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
12
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
13
-- for details
14
{-# LANGUAGE DeriveDataTypeable #-}
15

16
module Literal
17
18
19
20
21
	( 
	-- * Main data type
	  Literal(..)		-- Exported to ParseIface
	
	-- ** Creating Literals
22
	, mkMachInt, mkMachWord
23
24
25
26
27
	, mkMachInt64, mkMachWord64
	, mkMachFloat, mkMachDouble
	, mkMachChar, mkMachString
	
	-- ** Operations on Literals
28
	, literalType
29
	, hashLiteral
30
        , absentLiteralOf
31

32
33
        -- ** Predicates on Literals and their contents
	, litIsDupable, litIsTrivial
34
	, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
35
	, isZeroLit
36
	, litFitsInChar
37

38
        -- ** Coercions
39
	, word2IntLit, int2WordLit
apt's avatar
apt committed
40
41
	, narrow8IntLit, narrow16IntLit, narrow32IntLit
	, narrow8WordLit, narrow16WordLit, narrow32WordLit
42
	, char2IntLit, int2CharLit
43
	, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
apt's avatar
apt committed
44
	, nullAddrLit, float2DoubleLit, double2FloatLit
45
	) where
46

Simon Marlow's avatar
Simon Marlow committed
47
import TysPrim
48
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
49
import Type
50
import TyCon
51
import Outputable
52
import FastTypes
53
import FastString
54
import BasicTypes
55
import Binary
56
import Constants
57
import UniqFM
Simon Marlow's avatar
Simon Marlow committed
58
import Data.Int
Ian Lynagh's avatar
Ian Lynagh committed
59
import Data.Ratio
Simon Marlow's avatar
Simon Marlow committed
60
61
import Data.Word
import Data.Char
62
import Data.Data( Data, Typeable )
63
64
65
66
67
68
69
70
71
72
\end{code}


%************************************************************************
%*									*
\subsection{Literals}
%*									*
%************************************************************************

\begin{code}
73
74
75
76
77
78
79
80
-- | So-called 'Literal's are one of:
--
-- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.),
--   which is presumed to be surrounded by appropriate constructors
--   (@Int#@, etc.), so that the overall thing makes sense.
--
-- * The literal derived from the label mentioned in a \"foreign label\" 
--   declaration ('MachLabel')
81
82
83
data Literal
  =	------------------
	-- First the primitive guys
84
    MachChar	Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
85

86
  | MachStr	FastString	-- ^ A string-literal: stored and emitted
87
				-- UTF-8 encoded, we'll arrange to decode it
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
				-- at runtime.  Also emitted with a @'\0'@
				-- terminator. Create with 'mkMachString'

  | MachNullAddr                -- ^ The @NULL@ pointer, the only pointer value
                                -- that can be represented as a Literal. Create 
                                -- with 'nullAddrLit'

  | MachInt	Integer		-- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
  | MachInt64	Integer		-- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
  | MachWord	Integer		-- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
  | MachWord64	Integer		-- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'

  | MachFloat	Rational        -- ^ @Float#@. Create with 'mkMachFloat'
  | MachDouble	Rational        -- ^ @Double#@. Create with 'mkMachDouble'

  | MachLabel   FastString
104
105
106
107
108
109
110
  		(Maybe Int)
        FunctionOrData
                -- ^ A label literal. Parameters:
  		        --
  		        -- 1) The name of the symbol mentioned in the declaration
  		        --
  		        -- 2) The size (in bytes) of the arguments
111
112
113
				--    the label expects. Only applicable with
				--    @stdcall@ labels. @Just x@ => @\<x\>@ will
				--    be appended to label name when emitting assembly.
114
  deriving (Data, Typeable)
115
116
\end{code}

117
Binary instance
118
119
120
121
122

\begin{code}
instance Binary Literal where
    put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa
    put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab
sof's avatar
sof committed
123
    put_ bh (MachNullAddr)    = do putByte bh 2
124
125
126
127
128
129
    put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad
    put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae
    put_ bh (MachWord af)     = do putByte bh 5; put_ bh af
    put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag
    put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah
    put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai
130
131
132
133
134
    put_ bh (MachLabel aj mb fod)
        = do putByte bh 9
             put_ bh aj
             put_ bh mb
             put_ bh fod
135
136
137
138
139
140
141
142
143
144
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do
		    aa <- get bh
		    return (MachChar aa)
	      1 -> do
		    ab <- get bh
		    return (MachStr ab)
	      2 -> do
sof's avatar
sof committed
145
		    return (MachNullAddr)
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
	      3 -> do
		    ad <- get bh
		    return (MachInt ad)
	      4 -> do
		    ae <- get bh
		    return (MachInt64 ae)
	      5 -> do
		    af <- get bh
		    return (MachWord af)
	      6 -> do
		    ag <- get bh
		    return (MachWord64 ag)
	      7 -> do
		    ah <- get bh
		    return (MachFloat ah)
	      8 -> do
		    ai <- get bh
		    return (MachDouble ai)
	      9 -> do
		    aj <- get bh
sof's avatar
sof committed
166
		    mb <- get bh
167
168
		    fod <- get bh
		    return (MachLabel aj mb fod)
169
170
\end{code}

171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
\begin{code}
instance Outputable Literal where
    ppr lit = pprLit lit

instance Show Literal where
    showsPrec p lit = showsPrecSDoc p (ppr lit)

instance Eq Literal where
    a == b = case (a `compare` b) of { EQ -> True;   _ -> False }
    a /= b = case (a `compare` b) of { EQ -> False;  _ -> True  }

instance Ord Literal where
    a <= b = case (a `compare` b) of { LT -> True;  EQ -> True;  GT -> False }
    a <	 b = case (a `compare` b) of { LT -> True;  EQ -> False; GT -> False }
    a >= b = case (a `compare` b) of { LT -> False; EQ -> True;  GT -> True  }
    a >	 b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True  }
    compare a b = cmpLit a b
\end{code}


	Construction
	~~~~~~~~~~~~
\begin{code}
194
195
-- | Creates a 'Literal' of type @Int#@
mkMachInt :: Integer -> Literal
196
mkMachInt  x   = -- ASSERT2( inIntRange x,  integer x ) 
197
198
199
200
	 	 -- Not true: you can write out of range Int# literals
		 -- For example, one can write (intToWord# 0xffff0000) to
		 -- get a particular Word bit-pattern, and there's no other
		 -- convenient way to write such literals, which is why we allow it.
201
		 MachInt x
202
203
204

-- | Creates a 'Literal' of type @Word#@
mkMachWord :: Integer -> Literal
205
206
mkMachWord x   = -- ASSERT2( inWordRange x, integer x ) 
		 MachWord x
207
208
209

-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
210
mkMachInt64  x = MachInt64 x
211
212
213

-- | Creates a 'Literal' of type @Word64#@
mkMachWord64 :: Integer -> Literal
214
mkMachWord64 x = MachWord64 x
215

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
-- | Creates a 'Literal' of type @Float#@
mkMachFloat :: Rational -> Literal
mkMachFloat = MachFloat

-- | Creates a 'Literal' of type @Double#@
mkMachDouble :: Rational -> Literal
mkMachDouble = MachDouble

-- | Creates a 'Literal' of type @Char#@
mkMachChar :: Char -> Literal
mkMachChar = MachChar

-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to
-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@
mkMachString :: String -> Literal
mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded
232

233
234
235
inIntRange, inWordRange :: Integer -> Bool
inIntRange  x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0		    && x <= tARGET_MAX_WORD
236

237
238
inCharRange :: Char -> Bool
inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
239

240
-- | Tests whether the literal represents a zero of whatever type it is
241
242
243
244
245
246
247
isZeroLit :: Literal -> Bool
isZeroLit (MachInt    0) = True
isZeroLit (MachInt64  0) = True
isZeroLit (MachWord   0) = True
isZeroLit (MachWord64 0) = True
isZeroLit (MachFloat  0) = True
isZeroLit (MachDouble 0) = True
248
isZeroLit _              = False
249
250
251
252
253
\end{code}

	Coercions
	~~~~~~~~~
\begin{code}
254
word2IntLit, int2WordLit,
apt's avatar
apt committed
255
256
  narrow8IntLit, narrow16IntLit, narrow32IntLit,
  narrow8WordLit, narrow16WordLit, narrow32WordLit,
257
258
  char2IntLit, int2CharLit,
  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,
apt's avatar
apt committed
259
  float2DoubleLit, double2FloatLit
260
  :: Literal -> Literal
261
262

word2IntLit (MachWord w) 
263
  | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1)
264
265
266
267
268
269
  | otherwise	       = MachInt w

int2WordLit (MachInt i)
  | i < 0     = MachWord (1 + tARGET_MAX_WORD + i)	-- (-1)  --->  tARGET_MAX_WORD
  | otherwise = MachWord i

apt's avatar
apt committed
270
271
272
273
274
275
narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
276

277
278
char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
279

280
281
282
float2IntLit (MachFloat f) = MachInt   (truncate    f)
int2FloatLit (MachInt   i) = MachFloat (fromInteger i)

apt's avatar
apt committed
283
double2IntLit (MachDouble f) = MachInt    (truncate    f)
284
285
286
287
int2DoubleLit (MachInt   i) = MachDouble (fromInteger i)

float2DoubleLit (MachFloat  f) = MachDouble f
double2FloatLit (MachDouble d) = MachFloat  d
apt's avatar
apt committed
288
289

nullAddrLit :: Literal
sof's avatar
sof committed
290
nullAddrLit = MachNullAddr
291
292
293
294
295
\end{code}

	Predicates
	~~~~~~~~~~
\begin{code}
296
297
-- | True if there is absolutely no penalty to duplicating the literal.
-- False principally of strings
298
299
300
litIsTrivial :: Literal -> Bool
--	c.f. CoreUtils.exprIsTrivial
litIsTrivial (MachStr _) = False
301
litIsTrivial _           = True
302

303
304
-- | True if code space does not go bad if we duplicate this literal
-- Currently we treat it just like 'litIsTrivial'
305
litIsDupable :: Literal -> Bool
306
--	c.f. CoreUtils.exprIsDupable
307
litIsDupable (MachStr _) = False
308
litIsDupable _           = True
309

310
311
312
313
314
litFitsInChar :: Literal -> Bool
litFitsInChar (MachInt i)
    		         = fromInteger i <= ord minBound 
                        && fromInteger i >= ord maxBound 
litFitsInChar _         = False
315
316
317
318
319
\end{code}

	Types
	~~~~~
\begin{code}
320
-- | Find the Haskell 'Type' the literal occupies
321
literalType :: Literal -> Type
322
323
324
325
326
327
328
329
330
literalType MachNullAddr    = addrPrimTy
literalType (MachChar _)    = charPrimTy
literalType (MachStr  _)    = addrPrimTy
literalType (MachInt  _)    = intPrimTy
literalType (MachWord  _)   = wordPrimTy
literalType (MachInt64  _)  = int64PrimTy
literalType (MachWord64  _) = word64PrimTy
literalType (MachFloat _)   = floatPrimTy
literalType (MachDouble _)  = doublePrimTy
331
literalType (MachLabel _ _ _) = addrPrimTy
332
333
334
335
336
337
338
339
340
341

absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
-- TyCon, to use as a placeholder when it doesn't matter
absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)

absent_lits :: UniqFM Literal
absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
            		, (charPrimTyConKey,    MachChar 'x')
            		, (intPrimTyConKey,     MachInt 0)
342
            		, (int64PrimTyConKey,   MachInt64 0)
343
344
345
346
            		, (floatPrimTyConKey,   MachFloat 0)
            		, (doublePrimTyConKey,  MachDouble 0)
            		, (wordPrimTyConKey,    MachWord 0)
            		, (word64PrimTyConKey,  MachWord64 0) ]
347
348
349
350
351
352
\end{code}


	Comparison
	~~~~~~~~~~
\begin{code}
353
cmpLit :: Literal -> Literal -> Ordering
354
355
cmpLit (MachChar      a)   (MachChar	   b)   = a `compare` b
cmpLit (MachStr       a)   (MachStr	   b)   = a `compare` b
sof's avatar
sof committed
356
cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
357
358
359
360
361
362
cmpLit (MachInt       a)   (MachInt	   b)   = a `compare` b
cmpLit (MachWord      a)   (MachWord	   b)   = a `compare` b
cmpLit (MachInt64     a)   (MachInt64	   b)   = a `compare` b
cmpLit (MachWord64    a)   (MachWord64	   b)   = a `compare` b
cmpLit (MachFloat     a)   (MachFloat	   b)   = a `compare` b
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
365
					        | otherwise  		     = GT
366

367
litTag :: Literal -> FastInt
368
369
litTag (MachChar      _)   = _ILIT(1)
litTag (MachStr       _)   = _ILIT(2)
sof's avatar
sof committed
370
litTag (MachNullAddr)      = _ILIT(3)
371
372
373
374
375
376
litTag (MachInt       _)   = _ILIT(4)
litTag (MachWord      _)   = _ILIT(5)
litTag (MachInt64     _)   = _ILIT(6)
litTag (MachWord64    _)   = _ILIT(7)
litTag (MachFloat     _)   = _ILIT(8)
litTag (MachDouble    _)   = _ILIT(9)
377
litTag (MachLabel _ _ _)   = _ILIT(10)
378
379
380
381
382
\end{code}

	Printing
	~~~~~~~~
* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
sof's avatar
sof committed
383
  exceptions: MachFloat gets an initial keyword prefix.
384
385

\begin{code}
386
pprLit :: Literal -> SDoc
387
388
389
pprLit (MachChar ch)  	= pprHsChar ch
pprLit (MachStr s)    	= pprHsString s
pprLit (MachInt i)    	= pprIntVal i
Ian Lynagh's avatar
Ian Lynagh committed
390
391
392
393
pprLit (MachInt64 i)  	= ptext (sLit "__int64") <+> integer i
pprLit (MachWord w)   	= ptext (sLit "__word") <+> integer w
pprLit (MachWord64 w) 	= ptext (sLit "__word64") <+> integer w
pprLit (MachFloat f)  	= ptext (sLit "__float") <+> rational f
394
pprLit (MachDouble d) 	= rational d
Ian Lynagh's avatar
Ian Lynagh committed
395
pprLit (MachNullAddr) 	= ptext (sLit "__NULL")
396
397
398
399
pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
    where b = case mb of
              Nothing -> pprHsString l
              Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))
400

401
pprIntVal :: Integer -> SDoc
402
-- ^ Print negative integers with parens to be sure it's unambiguous
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
pprIntVal i | i < 0     = parens (integer i)
	    | otherwise = integer i
\end{code}


%************************************************************************
%*									*
\subsection{Hashing}
%*									*
%************************************************************************

Hash values should be zero or a positive integer.  No negatives please.
(They mess up the UniqFM for some reason.)

\begin{code}
hashLiteral :: Literal -> Int
419
hashLiteral (MachChar c)    	= ord c + 1000	-- Keep it out of range of common ints
420
hashLiteral (MachStr s)     	= hashFS s
sof's avatar
sof committed
421
hashLiteral (MachNullAddr)    	= 0
422
423
424
425
426
427
hashLiteral (MachInt i)   	= hashInteger i
hashLiteral (MachInt64 i) 	= hashInteger i
hashLiteral (MachWord i)   	= hashInteger i
hashLiteral (MachWord64 i) 	= hashInteger i
hashLiteral (MachFloat r)   	= hashRational r
hashLiteral (MachDouble r)  	= hashRational r
428
hashLiteral (MachLabel s _ _)     = hashFS s
429
430
431
432
433
434
435
436
437

hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)

hashInteger :: Integer -> Int
hashInteger i = 1 + abs (fromInteger (i `rem` 10000))
		-- The 1+ is to avoid zero, which is a Bad Number
		-- since we use * to combine hash values

438
hashFS :: FastString -> Int
439
hashFS s = iBox (uniqueOfFS s)
440
\end{code}