X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FbasicTypes%2FLiteral.lhs;h=3781abefe95c3be766dfbf7ab1843728fab53021;hb=a195d525eb3ad5fd60a8797191c31907e6d9bfb0;hp=1b794a6faae24129889d0ac01ac36e9988ea2ce2;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 1b794a6..3781abe 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -8,7 +8,8 @@ module Literal ( Literal(..) -- Exported to ParseIface , mkMachInt, mkMachWord , mkMachInt64, mkMachWord64 - , isLitLitLit, maybeLitLit, litSize, litIsDupable, + , litSize + , litIsDupable, litIsTrivial , literalType, literalPrimRep , hashLiteral @@ -29,16 +30,13 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) import PrimRep ( PrimRep(..) ) -import TcType ( Type, tcCmpType ) -import Type ( typePrimRep ) -import PprType ( pprParendType ) +import Type ( Type ) import CStrings ( pprFSInCStyle ) import Outputable import FastTypes import FastString import Binary -import Util ( thenCmp ) import Ratio ( numerator ) import FastString ( uniqueOfFS, lengthFS ) @@ -101,7 +99,8 @@ data Literal MachChar Int -- Char# At least 31 bits | MachStr FastString - | MachAddr Integer -- Whatever this machine thinks is a "pointer" + | 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 @@ -116,30 +115,27 @@ data Literal -- string argument is the name of a symbol. This literal -- refers to the *address* of the label. | MachLabel FastString -- always an Addr# - - -- lit-lits only work for via-C compilation, hence they - -- are deprecated. The string is emitted verbatim into - -- the C file, and can therefore be any C expression, - -- macro call, #defined constant etc. - | MachLitLit FastString Type -- Type might be Addr# or Int# etc + (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. \end{code} -Binary instance: must do this manually, because we don't want the type -arg of MachLitLit involved. +Binary instance \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 - put_ bh (MachAddr ac) = do putByte bh 2; put_ bh ac + put_ bh (MachNullAddr) = do putByte bh 2 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 - put_ bh (MachLabel aj) = do putByte bh 9; put_ bh aj - put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak + put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb get bh = do h <- getByte bh case h of @@ -150,8 +146,7 @@ instance Binary Literal where ab <- get bh return (MachStr ab) 2 -> do - ac <- get bh - return (MachAddr ac) + return (MachNullAddr) 3 -> do ad <- get bh return (MachInt ad) @@ -172,10 +167,8 @@ instance Binary Literal where return (MachDouble ai) 9 -> do aj <- get bh - return (MachLabel aj) - 10 -> do - ak <- get bh - return (MachLitLit ak (error "MachLitLit: no type")) + mb <- get bh + return (MachLabel aj mb) \end{code} \begin{code} @@ -270,27 +263,34 @@ float2DoubleLit (MachFloat f) = MachDouble f double2FloatLit (MachDouble d) = MachFloat d nullAddrLit :: Literal -nullAddrLit = MachAddr 0 +nullAddrLit = MachNullAddr \end{code} Predicates ~~~~~~~~~~ \begin{code} -isLitLitLit (MachLitLit _ _) = True -isLitLitLit _ = False - -maybeLitLit (MachLitLit s t) = Just (s,t) -maybeLitLit _ = Nothing +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 litIsDupable :: Literal -> Bool - -- True if code space does not go bad if we duplicate this literal - -- False principally of strings +-- 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) = lengthFS str `div` 4 +-- 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} @@ -300,15 +300,14 @@ litSize _other = 1 literalType :: Literal -> Type literalType (MachChar _) = charPrimTy literalType (MachStr _) = addrPrimTy -literalType (MachAddr _) = addrPrimTy +literalType (MachNullAddr) = addrPrimTy literalType (MachInt _) = intPrimTy literalType (MachWord _) = wordPrimTy literalType (MachInt64 _) = int64PrimTy literalType (MachWord64 _) = word64PrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _) = addrPrimTy -literalType (MachLitLit _ ty) = ty +literalType (MachLabel _ _) = addrPrimTy \end{code} \begin{code} @@ -316,15 +315,14 @@ literalPrimRep :: Literal -> PrimRep literalPrimRep (MachChar _) = CharRep literalPrimRep (MachStr _) = AddrRep -- specifically: "char *" -literalPrimRep (MachAddr _) = AddrRep +literalPrimRep (MachNullAddr) = AddrRep literalPrimRep (MachInt _) = IntRep literalPrimRep (MachWord _) = WordRep literalPrimRep (MachInt64 _) = Int64Rep literalPrimRep (MachWord64 _) = Word64Rep literalPrimRep (MachFloat _) = FloatRep literalPrimRep (MachDouble _) = DoubleRep -literalPrimRep (MachLabel _) = AddrRep -literalPrimRep (MachLitLit _ ty) = typePrimRep ty +literalPrimRep (MachLabel _ _) = AddrRep \end{code} @@ -333,35 +331,33 @@ literalPrimRep (MachLitLit _ ty) = typePrimRep ty \begin{code} cmpLit (MachChar a) (MachChar b) = a `compare` b cmpLit (MachStr a) (MachStr b) = a `compare` b -cmpLit (MachAddr a) (MachAddr b) = a `compare` b +cmpLit (MachNullAddr) (MachNullAddr) = EQ 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 -cmpLit (MachLabel a) (MachLabel b) = a `compare` b -cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d) +cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT - | otherwise = GT + | otherwise = GT litTag (MachChar _) = _ILIT(1) litTag (MachStr _) = _ILIT(2) -litTag (MachAddr _) = _ILIT(3) +litTag (MachNullAddr) = _ILIT(3) litTag (MachInt _) = _ILIT(4) litTag (MachWord _) = _ILIT(5) litTag (MachInt64 _) = _ILIT(6) litTag (MachWord64 _) = _ILIT(7) litTag (MachFloat _) = _ILIT(8) litTag (MachDouble _) = _ILIT(9) -litTag (MachLabel _) = _ILIT(10) -litTag (MachLitLit _ _) = _ILIT(11) +litTag (MachLabel _ _) = _ILIT(10) \end{code} Printing ~~~~~~~~ * MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") - exceptions: MachFloat and MachAddr get an initial keyword prefix + exceptions: MachFloat gets an initial keyword prefix. \begin{code} pprLit lit @@ -398,16 +394,15 @@ pprLit lit MachDouble d | code_style -> code_rational d | otherwise -> rational d - MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p - | otherwise -> ptext SLIT("__addr") <+> integer p - - MachLabel l | code_style -> ptext SLIT("(&") <> ftext l <> char ')' - | otherwise -> ptext SLIT("__label") <+> pprHsString l + MachNullAddr | code_style -> ptext SLIT("(void*)0") + | otherwise -> ptext SLIT("__NULL") - MachLitLit s ty | code_style -> ftext s - | otherwise -> parens (hsep [ptext SLIT("__litlit"), - pprHsString s, - pprParendType ty]) + MachLabel l mb + | code_style -> ptext SLIT("(&") <> ftext l <> char ')' + | otherwise -> ptext SLIT("__label") <+> + case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -- negative floating literals in code style need parentheses to avoid -- interacting with surrounding syntax. @@ -446,15 +441,14 @@ Hash values should be zero or a positive integer. No negatives please. hashLiteral :: Literal -> Int hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints hashLiteral (MachStr s) = hashFS s -hashLiteral (MachAddr i) = hashInteger i +hashLiteral (MachNullAddr) = 0 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 -hashLiteral (MachLabel s) = hashFS s -hashLiteral (MachLitLit s _) = hashFS s +hashLiteral (MachLabel s _) = hashFS s hashRational :: Rational -> Int hashRational r = hashInteger (numerator r)