X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FLiteral.lhs;h=da8685e6b3f094ae51d141b6dbd787b9cba0b35a;hp=a5c413ad16ab7a82b29435f2214988f5d5fda7b5;hb=c1c2c25355bc462e521b2c5fb41ac79307da22ff;hpb=6758ba711a3f9f3100a9dba1818b131c32e62106 diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index a5c413a..da8685e 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -5,19 +5,37 @@ \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 @@ -26,99 +44,74 @@ module Literal , 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 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 => "@" 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@ => @\@ will + -- be appended to label name when emitting assembly. + deriving (Data, Typeable) \end{code} Binary instance @@ -134,7 +127,11 @@ instance Binary Literal where 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 @@ -167,7 +164,8 @@ instance Binary Literal where 9 -> do aj <- get bh mb <- get bh - return (MachLabel aj mb) + fod <- get bh + return (MachLabel aj mb fod) \end{code} \begin{code} @@ -193,21 +191,44 @@ instance Ord Literal where 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 @@ -216,6 +237,7 @@ inWordRange x = x >= 0 && x <= tARGET_MAX_WORD 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 @@ -223,7 +245,7 @@ isZeroLit (MachWord 0) = True isZeroLit (MachWord64 0) = True isZeroLit (MachFloat 0) = True isZeroLit (MachDouble 0) = True -isZeroLit other = False +isZeroLit _ = False \end{code} Coercions @@ -271,40 +293,31 @@ nullAddrLit = MachNullAddr 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 +litIsDupable _ = True litFitsInChar :: Literal -> Bool litFitsInChar (MachInt i) = fromInteger i <= ord minBound && fromInteger i >= ord maxBound litFitsInChar _ = False - -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 \end{code} Types ~~~~~ \begin{code} +-- | Find the Haskell 'Type' the literal occupies literalType :: Literal -> Type literalType MachNullAddr = addrPrimTy literalType (MachChar _) = charPrimTy @@ -315,13 +328,29 @@ literalType (MachInt64 _) = int64PrimTy 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 @@ -331,10 +360,11 @@ 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 -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) @@ -344,7 +374,7 @@ litTag (MachInt64 _) = _ILIT(6) litTag (MachWord64 _) = _ILIT(7) litTag (MachFloat _) = _ILIT(8) litTag (MachDouble _) = _ILIT(9) -litTag (MachLabel _ _) = _ILIT(10) +litTag (MachLabel _ _ _) = _ILIT(10) \end{code} Printing @@ -353,22 +383,23 @@ litTag (MachLabel _ _) = _ILIT(10) 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} @@ -394,7 +425,7 @@ hashLiteral (MachWord i) = hashInteger i 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)