\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
\begin{code}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- 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
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Literal
- ( Literal(..) -- Exported to ParseIface
+ (
+ -- * Main data type
+ Literal(..) -- Exported to ParseIface
+
+ -- ** Creating Literals
, mkMachInt, mkMachWord
- , mkMachInt64, mkMachWord64, mkStringLit
- , litSize
- , litIsDupable, litIsTrivial
+ , mkMachInt64, mkMachWord64
+ , mkMachFloat, mkMachDouble
+ , mkMachChar, mkMachString
+
+ -- ** Operations on Literals
, literalType
, hashLiteral
+ , absentLiteralOf
+ -- ** Predicates on Literals and their contents
+ , litIsDupable, litIsTrivial
, inIntRange, inWordRange, tARGET_MAX_INT, inCharRange
, isZeroLit
+ , litFitsInChar
+ -- ** Coercions
, word2IntLit, int2WordLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, nullAddrLit, float2DoubleLit, double2FloatLit
) where
-#include "HsVersions.h"
-
import TysPrim
+import PrelNames
import Type
+import TyCon
import Outputable
import FastTypes
import FastString
+import BasicTypes
import Binary
-import Ratio
-import FastString
-
+import Constants
+import UniqFM
import Data.Int
+import Data.Ratio
import Data.Word
import Data.Char
+import Data.Data( Data, Typeable )
\end{code}
%************************************************************************
%* *
-\subsection{Sizes}
-%* *
-%************************************************************************
-
-If we're compiling with GHC (and we're not cross-compiling), then we
-know that minBound and maxBound :: Int are the right values for the
-target architecture. Otherwise, we assume -2^31 and 2^31-1
-respectively (which will be wrong on a 64-bit machine).
-
-\begin{code}
-tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: Integer
-#if __GLASGOW_HASKELL__
-tARGET_MIN_INT = toInteger (minBound :: Int)
-tARGET_MAX_INT = toInteger (maxBound :: Int)
-#else
-tARGET_MIN_INT = -2147483648
-tARGET_MAX_INT = 2147483647
-#endif
-tARGET_MAX_WORD = (tARGET_MAX_INT * 2) + 1
-
-tARGET_MAX_CHAR :: Int
-tARGET_MAX_CHAR = 0x10ffff
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Literals}
%* *
%************************************************************************
-So-called @Literals@ are {\em either}:
-\begin{itemize}
-\item
-An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
-which is presumed to be surrounded by appropriate constructors
-(@mKINT@, etc.), so that the overall thing makes sense.
-\item
-An Integer, Rational, or String literal whose representation we are
-{\em uncommitted} about; i.e., the surrounding with constructors,
-function applications, etc., etc., has not yet been done.
-\end{itemize}
-
\begin{code}
+-- | 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')
data Literal
= ------------------
-- First the primitive guys
- MachChar Char -- Char# At least 31 bits
+ MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
- | MachStr FastString -- A string-literal: stored and emitted
+ | MachStr FastString -- ^ A string-literal: stored and emitted
-- UTF-8 encoded, we'll arrange to decode it
- -- at runtime. Also emitted with a '\0'
- -- terminator.
-
- | MachNullAddr -- the NULL pointer, the only pointer value
- -- that can be represented as a Literal.
-
- | MachInt Integer -- Int# At least WORD_SIZE_IN_BITS bits
- | MachInt64 Integer -- Int64# At least 64 bits
- | MachWord Integer -- Word# At least WORD_SIZE_IN_BITS bits
- | MachWord64 Integer -- Word64# At least 64 bits
-
- | MachFloat Rational
- | MachDouble Rational
-
- -- MachLabel is used (only) for the literal derived from a
- -- "foreign label" declaration.
- -- string argument is the name of a symbol. This literal
- -- refers to the *address* of the label.
- | MachLabel FastString -- always an Addr#
- (Maybe Int) -- the size (in bytes) of the arguments
- -- the label expects. Only applicable with
- -- 'stdcall' labels.
- -- Just x => "@<x>" will be appended to label
- -- name when emitting asm.
+ -- 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
+ (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
+ -- the label expects. Only applicable with
+ -- @stdcall@ labels. @Just x@ => @\<x\>@ will
+ -- be appended to label name when emitting assembly.
+ deriving (Data, Typeable)
\end{code}
Binary instance
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
- put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
+ put_ bh (MachLabel aj mb fod)
+ = do putByte bh 9
+ put_ bh aj
+ put_ bh mb
+ put_ bh fod
get bh = do
h <- getByte bh
case h of
9 -> do
aj <- get bh
mb <- get bh
- return (MachLabel aj mb)
+ fod <- get bh
+ return (MachLabel aj mb fod)
\end{code}
\begin{code}
Construction
~~~~~~~~~~~~
\begin{code}
-mkMachInt, mkMachWord, mkMachInt64, mkMachWord64 :: Integer -> Literal
-
+-- | Creates a 'Literal' of type @Int#@
+mkMachInt :: Integer -> Literal
mkMachInt x = -- ASSERT2( inIntRange x, integer x )
-- 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.
MachInt x
+
+-- | Creates a 'Literal' of type @Word#@
+mkMachWord :: Integer -> Literal
mkMachWord x = -- ASSERT2( inWordRange x, integer x )
MachWord x
+
+-- | Creates a 'Literal' of type @Int64#@
+mkMachInt64 :: Integer -> Literal
mkMachInt64 x = MachInt64 x
+
+-- | Creates a 'Literal' of type @Word64#@
+mkMachWord64 :: Integer -> Literal
mkMachWord64 x = MachWord64 x
-mkStringLit :: String -> Literal
-mkStringLit s = MachStr (mkFastString s) -- stored UTF-8 encoded
+-- | 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
inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
+-- | Tests whether the literal represents a zero of whatever type it is
isZeroLit :: Literal -> Bool
isZeroLit (MachInt 0) = True
isZeroLit (MachInt64 0) = True
isZeroLit (MachWord64 0) = True
isZeroLit (MachFloat 0) = True
isZeroLit (MachDouble 0) = True
-isZeroLit other = False
+isZeroLit _ = False
\end{code}
Coercions
Predicates
~~~~~~~~~~
\begin{code}
+-- | True if there is absolutely no penalty to duplicating the literal.
+-- False principally of strings
litIsTrivial :: Literal -> Bool
--- True if there is absolutely no penalty to duplicating the literal
-- c.f. CoreUtils.exprIsTrivial
--- False principally of strings
litIsTrivial (MachStr _) = False
-litIsTrivial other = True
+litIsTrivial _ = True
+-- | True if code space does not go bad if we duplicate this literal
+-- Currently we treat it just like 'litIsTrivial'
litIsDupable :: Literal -> Bool
--- True if code space does not go bad if we duplicate this literal
-- c.f. CoreUtils.exprIsDupable
--- Currently we treat it just like litIsTrivial
litIsDupable (MachStr _) = False
-litIsDupable other = True
-
-litSize :: Literal -> Int
--- Used by CoreUnfold.sizeExpr
-litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
- -- Every literal has size at least 1, otherwise
- -- f "x"
- -- might be too small
- -- [Sept03: make literal strings a bit bigger to avoid fruitless
- -- duplication of little strings]
-litSize _other = 1
+litIsDupable _ = True
+
+litFitsInChar :: Literal -> Bool
+litFitsInChar (MachInt i)
+ = fromInteger i <= ord minBound
+ && fromInteger i >= ord maxBound
+litFitsInChar _ = False
\end{code}
Types
~~~~~
\begin{code}
+-- | Find the Haskell 'Type' the literal occupies
literalType :: Literal -> Type
literalType MachNullAddr = addrPrimTy
literalType (MachChar _) = charPrimTy
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _ _) = addrPrimTy
+literalType (MachLabel _ _ _) = addrPrimTy
+
+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)
+ , (int64PrimTyConKey, MachInt64 0)
+ , (floatPrimTyConKey, MachFloat 0)
+ , (doublePrimTyConKey, MachDouble 0)
+ , (wordPrimTyConKey, MachWord 0)
+ , (word64PrimTyConKey, MachWord64 0) ]
\end{code}
Comparison
~~~~~~~~~~
\begin{code}
+cmpLit :: Literal -> Literal -> Ordering
cmpLit (MachChar a) (MachChar b) = a `compare` b
cmpLit (MachStr a) (MachStr b) = a `compare` b
cmpLit (MachNullAddr) (MachNullAddr) = EQ
cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
-cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
+cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
+litTag :: Literal -> FastInt
litTag (MachChar _) = _ILIT(1)
litTag (MachStr _) = _ILIT(2)
litTag (MachNullAddr) = _ILIT(3)
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
-litTag (MachLabel _ _) = _ILIT(10)
+litTag (MachLabel _ _ _) = _ILIT(10)
\end{code}
Printing
exceptions: MachFloat gets an initial keyword prefix.
\begin{code}
+pprLit :: Literal -> SDoc
pprLit (MachChar ch) = pprHsChar ch
pprLit (MachStr s) = pprHsString s
pprLit (MachInt i) = pprIntVal i
-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
+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
pprLit (MachDouble d) = rational d
-pprLit (MachNullAddr) = ptext SLIT("__NULL")
-pprLit (MachLabel l mb) = ptext SLIT("__label") <+>
- case mb of
- Nothing -> pprHsString l
- Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
+pprLit (MachNullAddr) = ptext (sLit "__NULL")
+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))
pprIntVal :: Integer -> SDoc
--- Print negative integers with parens to be sure it's unambiguous
+-- ^ Print negative integers with parens to be sure it's unambiguous
pprIntVal i | i < 0 = parens (integer i)
| otherwise = integer i
\end{code}
hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
-hashLiteral (MachLabel s _) = hashFS s
+hashLiteral (MachLabel s _ _) = hashFS s
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
projects / ghc-hetmet.git / blobdiff