diff options
40 files changed, 442 insertions, 427 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 0bf3897da3..7e49816d1f 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -2,7 +2,7 @@ (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 -\section[Literal]{@Literal@: Machine literals (unboxed, of course)} +\section[Literal]{@Literal@: literals} -} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} @@ -14,12 +14,12 @@ module Literal , LitNumType(..) -- ** Creating Literals - , mkMachInt, mkMachIntWrap, mkMachIntWrapC - , mkMachWord, mkMachWordWrap, mkMachWordWrapC - , mkMachInt64, mkMachInt64Wrap - , mkMachWord64, mkMachWord64Wrap - , mkMachFloat, mkMachDouble - , mkMachChar, mkMachString + , mkLitInt, mkLitIntWrap, mkLitIntWrapC + , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt64, mkLitInt64Wrap + , mkLitWord64, mkLitWord64Wrap + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString , mkLitInteger, mkLitNatural , mkLitNumber, mkLitNumberWrap @@ -84,59 +84,66 @@ import Numeric ( fromRat ) -- | 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. +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. -- --- We maintain the invariant that the 'Integer' the Mach{Int,Word}* --- constructors are actually in the (possibly target-dependent) range. --- The mkMach{Int,Word}*Wrap smart constructors ensure this by applying +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying -- the target machine's wrapping semantics. Use these in situations -- where you know the wrapping semantics are correct. -- -- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('MachLabel') +-- declaration ('LitLabel') -- --- * A 'RubbishLit' to be used in place of values of 'UnliftedRep' +-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' -- (i.e. 'MutVar#') when the the value is never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- data Literal - = ------------------ - -- First the primitive guys - MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar' + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' | LitNumber !LitNumType !Integer Type - -- ^ Any numeric literal that can be - -- internally represented with an Integer + -- ^ Any numeric literal that can be + -- internally represented with an Integer - | MachStr ByteString -- ^ A string-literal: stored and emitted + | LitString ByteString -- ^ A string-literal: stored and emitted -- UTF-8 encoded, we'll arrange to decode it -- at runtime. Also emitted with a @'\0'@ - -- terminator. Create with 'mkMachString' + -- terminator. Create with 'mkLitString' - | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | RubbishLit -- ^ A nonsense value, used when an unlifted + | LitRubbish -- ^ A nonsense value, used when an unlifted -- binding is absent and has type -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. -- May be lowered by code-gen to any possible - -- value. Also see Note [RubbishLit] - - | 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. + -- value. Also see Note [Rubbish literals] + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel 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. + -- + -- 3) Flag indicating whether the symbol + -- references a function or a data deriving Data -- | Numeric literal type @@ -190,12 +197,12 @@ instance Binary LitNumType where return (toEnum (fromIntegral h)) 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 (MachNullAddr) = do putByte bh 2 - put_ bh (MachFloat ah) = do putByte bh 3; put_ bh ah - put_ bh (MachDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (MachLabel aj mb fod) + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj mb fod) = do putByte bh 5 put_ bh aj put_ bh mb @@ -204,29 +211,29 @@ instance Binary Literal where = do putByte bh 6 put_ bh nt put_ bh i - put_ bh (RubbishLit) = do putByte bh 7 + put_ bh (LitRubbish) = do putByte bh 7 get bh = do h <- getByte bh case h of 0 -> do aa <- get bh - return (MachChar aa) + return (LitChar aa) 1 -> do ab <- get bh - return (MachStr ab) + return (LitString ab) 2 -> do - return (MachNullAddr) + return (LitNullAddr) 3 -> do ah <- get bh - return (MachFloat ah) + return (LitFloat ah) 4 -> do ai <- get bh - return (MachDouble ai) + return (LitDouble ai) 5 -> do aj <- get bh mb <- get bh fod <- get bh - return (MachLabel aj mb fod) + return (LitLabel aj mb fod) 6 -> do nt <- get bh i <- get bh @@ -243,7 +250,7 @@ instance Binary Literal where panic "Evaluated the place holder for mkNatural" return (LitNumber nt i t) _ -> do - return (RubbishLit) + return (LitRubbish) instance Outputable Literal where ppr lit = pprLiteral (\d -> d) lit @@ -322,96 +329,96 @@ mkLitNumber dflags nt i t = (LitNumber nt i t) -- | Creates a 'Literal' of type @Int#@ -mkMachInt :: DynFlags -> Integer -> Literal -mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x ) - (mkMachIntUnchecked x) +mkLitInt :: DynFlags -> Integer -> Literal +mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) + (mkLitIntUnchecked x) -- | Creates a 'Literal' of type @Int#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] -mkMachIntWrap :: DynFlags -> Integer -> Literal -mkMachIntWrap dflags i = wrapLitNumber dflags $ mkMachIntUnchecked i +mkLitIntWrap :: DynFlags -> Integer -> Literal +mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i -- | Creates a 'Literal' of type @Int#@ without checking its range. -mkMachIntUnchecked :: Integer -> Literal -mkMachIntUnchecked i = LitNumber LitNumInt i intPrimTy +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating -- overflow. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the overflow flag will be set. -- See Note [Word/Int underflow/overflow] -mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkMachIntWrapC dflags i = (n, i /= i') +mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkLitIntWrapC dflags i = (n, i /= i') where - n@(LitNumber _ i' _) = mkMachIntWrap dflags i + n@(LitNumber _ i' _) = mkLitIntWrap dflags i -- | Creates a 'Literal' of type @Word#@ -mkMachWord :: DynFlags -> Integer -> Literal -mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x ) - (mkMachWordUnchecked x) +mkLitWord :: DynFlags -> Integer -> Literal +mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) + (mkLitWordUnchecked x) -- | Creates a 'Literal' of type @Word#@. -- If the argument is out of the (target-dependent) range, it is wrapped. -- See Note [Word/Int underflow/overflow] -mkMachWordWrap :: DynFlags -> Integer -> Literal -mkMachWordWrap dflags i = wrapLitNumber dflags $ mkMachWordUnchecked i +mkLitWordWrap :: DynFlags -> Integer -> Literal +mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i -- | Creates a 'Literal' of type @Word#@ without checking its range. -mkMachWordUnchecked :: Integer -> Literal -mkMachWordUnchecked i = LitNumber LitNumWord i wordPrimTy +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating -- carry. That is, if the argument is out of the (target-dependent) range -- the argument is wrapped and the carry flag will be set. -- See Note [Word/Int underflow/overflow] -mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool) -mkMachWordWrapC dflags i = (n, i /= i') +mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkLitWordWrapC dflags i = (n, i /= i') where - n@(LitNumber _ i' _) = mkMachWordWrap dflags i + n@(LitNumber _ i' _) = mkLitWordWrap dflags i -- | Creates a 'Literal' of type @Int64#@ -mkMachInt64 :: Integer -> Literal -mkMachInt64 x = ASSERT2( inInt64Range x, integer x ) (mkMachInt64Unchecked x) +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) -- | Creates a 'Literal' of type @Int64#@. -- If the argument is out of the range, it is wrapped. -mkMachInt64Wrap :: DynFlags -> Integer -> Literal -mkMachInt64Wrap dflags i = wrapLitNumber dflags $ mkMachInt64Unchecked i +mkLitInt64Wrap :: DynFlags -> Integer -> Literal +mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i -- | Creates a 'Literal' of type @Int64#@ without checking its range. -mkMachInt64Unchecked :: Integer -> Literal -mkMachInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy -- | Creates a 'Literal' of type @Word64#@ -mkMachWord64 :: Integer -> Literal -mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) (mkMachWord64Unchecked x) +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) -- | Creates a 'Literal' of type @Word64#@. -- If the argument is out of the range, it is wrapped. -mkMachWord64Wrap :: DynFlags -> Integer -> Literal -mkMachWord64Wrap dflags i = wrapLitNumber dflags $ mkMachWord64Unchecked i +mkLitWord64Wrap :: DynFlags -> Integer -> Literal +mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i -- | Creates a 'Literal' of type @Word64#@ without checking its range. -mkMachWord64Unchecked :: Integer -> Literal -mkMachWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy -- | Creates a 'Literal' of type @Float#@ -mkMachFloat :: Rational -> Literal -mkMachFloat = MachFloat +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat -- | Creates a 'Literal' of type @Double#@ -mkMachDouble :: Rational -> Literal -mkMachDouble = MachDouble +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble -- | Creates a 'Literal' of type @Char#@ -mkMachChar :: Char -> Literal -mkMachChar = MachChar +mkLitChar :: Char -> Literal +mkLitChar = LitChar -- | 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 +mkLitString :: String -> Literal -- stored UTF-8 encoded -mkMachString s = MachStr (fastStringToByteString $ mkFastString s) +mkLitString s = LitString (fastStringToByteString $ mkFastString s) mkLitInteger :: Integer -> Type -> Literal mkLitInteger x ty = LitNumber LitNumInteger x ty @@ -439,8 +446,8 @@ 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 (LitNumber _ 0 _) = True -isZeroLit (MachFloat 0) = True -isZeroLit (MachDouble 0) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True isZeroLit _ = False -- | Returns the 'Integer' contained in the 'Literal', for when that makes @@ -453,7 +460,7 @@ litValue l = case isLitValue_maybe l of -- | Returns the 'Integer' contained in the 'Literal', for when that makes -- sense, i.e. for 'Char' and numbers. isLitValue_maybe :: Literal -> Maybe Integer -isLitValue_maybe (MachChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c isLitValue_maybe (LitNumber _ i _) = Just i isLitValue_maybe _ = Nothing @@ -463,7 +470,7 @@ isLitValue_maybe _ = Nothing -- with the semantics of the target type. -- See Note [Word/Int underflow/overflow] mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal -mapLitValue _ f (MachChar c) = mkMachChar (fchar c) +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) where fchar = chr . fromInteger . f . toInteger . ord mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags (LitNumber nt (f i) t) @@ -488,13 +495,19 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit, word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal word2IntLit dflags (LitNumber LitNumWord w _) - | w > tARGET_MAX_INT dflags = mkMachInt dflags (w - tARGET_MAX_WORD dflags - 1) - | otherwise = mkMachInt dflags w + -- Map Word range [max_int+1, max_word] + -- to Int range [min_int , -1] + -- Range [0,max_int] has the same representation with both Int and Word + | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) + | otherwise = mkLitInt dflags w word2IntLit _ l = pprPanic "word2IntLit" (ppr l) int2WordLit dflags (LitNumber LitNumInt i _) - | i < 0 = mkMachWord dflags (1 + tARGET_MAX_WORD dflags + i) -- (-1) ---> tARGET_MAX_WORD - | otherwise = mkMachWord dflags i + -- Map Int range [min_int , -1] + -- to Word range [max_int+1, max_word] + -- Range [0,max_int] has the same representation with both Int and Word + | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) + | otherwise = mkLitWord dflags i int2WordLit _ l = pprPanic "int2WordLit" (ppr l) -- | Narrow a literal number (unchecked result range) @@ -509,32 +522,32 @@ narrow8WordLit = narrowLit (Proxy :: Proxy Word8) narrow16WordLit = narrowLit (Proxy :: Proxy Word16) narrow32WordLit = narrowLit (Proxy :: Proxy Word32) -char2IntLit (MachChar c) = mkMachIntUnchecked (toInteger (ord c)) -char2IntLit l = pprPanic "char2IntLit" (ppr l) -int2CharLit (LitNumber _ i _) = MachChar (chr (fromInteger i)) +char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) int2CharLit l = pprPanic "int2CharLit" (ppr l) -float2IntLit (MachFloat f) = mkMachIntUnchecked (truncate f) -float2IntLit l = pprPanic "float2IntLit" (ppr l) -int2FloatLit (LitNumber _ i _) = MachFloat (fromInteger i) +float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) int2FloatLit l = pprPanic "int2FloatLit" (ppr l) -double2IntLit (MachDouble f) = mkMachIntUnchecked (truncate f) -double2IntLit l = pprPanic "double2IntLit" (ppr l) -int2DoubleLit (LitNumber _ i _) = MachDouble (fromInteger i) +double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) -float2DoubleLit (MachFloat f) = MachDouble f -float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) -double2FloatLit (MachDouble d) = MachFloat d -double2FloatLit l = pprPanic "double2FloatLit" (ppr l) +float2DoubleLit (LitFloat f) = LitDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (LitDouble d) = LitFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) nullAddrLit :: Literal -nullAddrLit = MachNullAddr +nullAddrLit = LitNullAddr -- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. rubbishLit :: Literal -rubbishLit = RubbishLit +rubbishLit = LitRubbish {- Predicates @@ -576,7 +589,7 @@ rubbishLit = RubbishLit -- user code. One approach to this is described in #8472. litIsTrivial :: Literal -> Bool -- c.f. CoreUtils.exprIsTrivial -litIsTrivial (MachStr _) = False +litIsTrivial (LitString _) = False litIsTrivial (LitNumber nt _ _) = case nt of LitNumInteger -> False LitNumNatural -> False @@ -584,12 +597,12 @@ litIsTrivial (LitNumber nt _ _) = case nt of LitNumInt64 -> True LitNumWord -> True LitNumWord64 -> True -litIsTrivial _ = True +litIsTrivial _ = True -- | True if code space does not go bad if we duplicate this literal litIsDupable :: DynFlags -> Literal -> Bool -- c.f. CoreUtils.exprIsDupable -litIsDupable _ (MachStr _) = False +litIsDupable _ (LitString _) = False litIsDupable dflags (LitNumber nt i _) = case nt of LitNumInteger -> inIntRange dflags i LitNumNatural -> inIntRange dflags i @@ -597,7 +610,7 @@ litIsDupable dflags (LitNumber nt i _) = case nt of LitNumInt64 -> True LitNumWord -> True LitNumWord64 -> True -litIsDupable _ _ = True +litIsDupable _ _ = True litFitsInChar :: Literal -> Bool litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) @@ -612,7 +625,7 @@ litIsLifted (LitNumber nt _ _) = case nt of LitNumInt64 -> False LitNumWord -> False LitNumWord64 -> False -litIsLifted _ = False +litIsLifted _ = False {- Types @@ -621,34 +634,34 @@ litIsLifted _ = False -- | Find the Haskell 'Type' the literal occupies literalType :: Literal -> Type -literalType MachNullAddr = addrPrimTy -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _ _ _) = addrPrimTy +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _ _) = addrPrimTy literalType (LitNumber _ _ t) = t -literalType (RubbishLit) = mkForAllTy a Inferred (mkTyVarTy a) +literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) where a = alphaTyVarUnliftedRep absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primitive -- TyCon, to use as a placeholder when it doesn't matter --- RubbishLits are handled in WwLib, because +-- Rubbish literals are handled in WwLib, because -- 1. Looking at the TyCon is not enough, we need the actual type -- 2. This would need to return a type application to a literal absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) absent_lits :: UniqFM Literal -absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) - , (charPrimTyConKey, MachChar 'x') - , (intPrimTyConKey, mkMachIntUnchecked 0) - , (int64PrimTyConKey, mkMachInt64Unchecked 0) - , (wordPrimTyConKey, mkMachWordUnchecked 0) - , (word64PrimTyConKey, mkMachWord64Unchecked 0) - , (floatPrimTyConKey, MachFloat 0) - , (doublePrimTyConKey, MachDouble 0) +absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) + , (charPrimTyConKey, LitChar 'x') + , (intPrimTyConKey, mkLitIntUnchecked 0) + , (int64PrimTyConKey, mkLitInt64Unchecked 0) + , (wordPrimTyConKey, mkLitWordUnchecked 0) + , (word64PrimTyConKey, mkLitWord64Unchecked 0) + , (floatPrimTyConKey, LitFloat 0) + , (doublePrimTyConKey, LitDouble 0) ] {- @@ -657,29 +670,29 @@ absent_lits = listToUFM [ (addrPrimTyConKey, MachNullAddr) -} 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 (MachFloat a) (MachFloat b) = a `compare` b -cmpLit (MachDouble a) (MachDouble b) = a `compare` b -cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b -cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b +cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) | nt1 == nt2 = a `compare` b | otherwise = nt1 `compare` nt2 -cmpLit (RubbishLit) (RubbishLit) = EQ +cmpLit (LitRubbish) (LitRubbish) = EQ cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT | otherwise = GT litTag :: Literal -> Int -litTag (MachChar _) = 1 -litTag (MachStr _) = 2 -litTag (MachNullAddr) = 3 -litTag (MachFloat _) = 4 -litTag (MachDouble _) = 5 -litTag (MachLabel _ _ _) = 6 -litTag (LitNumber {}) = 7 -litTag (RubbishLit) = 8 +litTag (LitChar _) = 1 +litTag (LitString _) = 2 +litTag (LitNullAddr) = 3 +litTag (LitFloat _) = 4 +litTag (LitDouble _) = 5 +litTag (LitLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 +litTag (LitRubbish) = 8 {- Printing @@ -688,11 +701,11 @@ litTag (RubbishLit) = 8 -} pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc -pprLiteral _ (MachChar c) = pprPrimChar c -pprLiteral _ (MachStr s) = pprHsBytes s -pprLiteral _ (MachNullAddr) = text "__NULL" -pprLiteral _ (MachFloat f) = float (fromRat f) <> primFloatSuffix -pprLiteral _ (MachDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix pprLiteral add_par (LitNumber nt i _) = case nt of LitNumInteger -> pprIntegerVal add_par i @@ -701,11 +714,12 @@ pprLiteral add_par (LitNumber nt i _) LitNumInt64 -> pprPrimInt64 i LitNumWord -> pprPrimWord i LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) +pprLiteral add_par (LitLabel l mb fod) = + add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (RubbishLit) = text "__RUBBISH" +pprLiteral _ (LitRubbish) = text "__RUBBISH" pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core]. @@ -716,7 +730,7 @@ pprIntegerVal add_par i | i < 0 = add_par (integer i) Note [Printing of literals in Core] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The function `add_par` is used to wrap parenthesis around negative integers -(`LitInteger`) and labels (`MachLabel`), if they occur in a context requiring +(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring an atomic thing (for example function application). Although not all Core literals would be valid Haskell, we are trying to stay @@ -736,21 +750,21 @@ To that end: Literal Output Output if context requires an atom (if different) ------- ------- ---------------------- -MachChar 'a'# -MachStr "aaa"# -MachNullAddr "__NULL" -MachInt -1# -MachInt64 -1L# -MachWord 1## -MachWord64 1L## -MachFloat -1.0# -MachDouble -1.0## +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitInt64 -1L# +LitWord 1## +LitWord64 1L## +LitFloat -1.0# +LitDouble -1.0## LitInteger -1 (-1) -MachLabel "__label" ... ("__label" ...) -RubbishLit "__RUBBISH" +LitLabel "__label" ... ("__label" ...) +LitRubbish "__RUBBISH" -Note [RubbishLit] -~~~~~~~~~~~~~~~~~ +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ During worker/wrapper after demand analysis, where an argument is unused (absent) we do the following w/w split (supposing that y is absent): @@ -772,12 +786,12 @@ What is <absent value>? * But what about /unlifted/ but /boxed/ types like MutVar# or Array#? We need a literal value of that type. -That is 'RubbishLit'. Since we need a rubbish literal for -many boxed, unlifted types, we say that RubbishLit has type - RubbishLit :: forall (a :: TYPE UnliftedRep). a +That is 'LitRubbish'. Since we need a rubbish literal for +many boxed, unlifted types, we say that LitRubbish has type + LitRubbish :: forall (a :: TYPE UnliftedRep). a So we might see a w/w split like - $wf x z = let y :: Array# Int = RubbishLit @(Array# Int) + $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) in e Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted @@ -785,19 +799,19 @@ heap pointers. Here are the moving parts: -* We define RubbishLit as a constructor in Literal.Literal +* We define LitRubbish as a constructor in Literal.Literal * It is given its polymoprhic type by Literal.literalType -* WwLib.mk_absent_let introduces a RubbishLit for absent - arguments of boxed, unliftd type. +* WwLib.mk_absent_let introduces a LitRubbish for absent + arguments of boxed, unlifted type. * In CoreToSTG we convert (RubishLit @t) to just (). STG is untyped, so it doesn't matter that it points to a lifted value. The important thing is that it is a heap pointer, which the garbage collector can follow if it encounters it. - We considered maintaining RubbishLit in STG, and lowering + We considered maintaining LitRubbish in STG, and lowering it in the code genreators, but it seems simpler to do it once and for all in CoreToSTG. diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 3f7c97fbf6..40b4e70aa0 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -419,7 +419,7 @@ data RtsLabelInfo | RtsSlowFastTickyCtr String deriving (Eq, Ord) - -- NOTE: Eq on LitString compares the pointer only, so this isn't + -- NOTE: Eq on PtrString compares the pointer only, so this isn't -- a real equality. @@ -1368,7 +1368,7 @@ tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> underscorePrefix :: Bool -- leading underscore on assembler labels? underscorePrefix = (cLeadingUnderscore == "YES") -asmTempLabelPrefix :: Platform -> LitString -- for formatting labels +asmTempLabelPrefix :: Platform -> PtrString -- for formatting labels asmTempLabelPrefix platform = case platformOS platform of OSDarwin -> sLit "L" OSAIX -> sLit "__L" -- follow IBM XL C's convention diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 97b181a243..77d894b1c7 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -173,7 +173,7 @@ data Width = W8 | W16 | W32 | W64 instance Outputable Width where ppr rep = ptext (mrStr rep) -mrStr :: Width -> LitString +mrStr :: Width -> PtrString mrStr W8 = sLit("W8") mrStr W16 = sLit("W16") mrStr W32 = sLit("W32") diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index a8ec300157..2ddeceb825 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -214,7 +214,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] buildDynCon' dflags platform binder _ _cc con [arg] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) - , NonVoid (StgLitArg (MachChar val)) <- arg + , NonVoid (StgLitArg (LitChar val)) <- arg , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 94e19e47fd..4a6135607e 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -86,27 +86,27 @@ import Data.Word ------------------------------------------------------------------------- cgLit :: Literal -> FCode CmmLit -cgLit (MachStr s) = newByteStringCLit (BS.unpack s) +cgLit (LitString s) = newByteStringCLit (BS.unpack s) -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = do dflags <- getDynFlags - return (mkSimpleLit dflags other_lit) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) mkSimpleLit :: DynFlags -> Literal -> CmmLit -mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) -mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (LitChar c) = CmmInt (fromIntegral (ord c)) + (wordWidth dflags) +mkSimpleLit dflags LitNullAddr = zeroCLit dflags mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags) mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64 mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags) mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64 -mkSimpleLit _ (MachFloat r) = CmmFloat r W32 -mkSimpleLit _ (MachDouble r) = CmmFloat r W64 -mkSimpleLit _ (MachLabel fs ms fod) - = CmmLabel (mkForeignLabel fs ms labelSrc fod) - where - -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage --- NB: RubbishLit should have been lowered in "CoreToStg" -mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit _ (LitFloat r) = CmmFloat r W32 +mkSimpleLit _ (LitDouble r) = CmmFloat r W64 +mkSimpleLit _ (LitLabel fs ms fod) + = let -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage + in CmmLabel (mkForeignLabel fs ms labelSrc fod) +-- NB: LitRubbish should have been lowered in "CoreToStg" +mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index cc0ae6fe28..aebd0e3828 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -30,7 +30,7 @@ import CoreUtils import CoreFVs import PprCore ( pprCoreBindings, pprRules ) import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) -import Literal ( Literal(MachStr) ) +import Literal ( Literal(LitString) ) import Id import Var ( varType, isNonCoVarId ) import VarSet @@ -816,8 +816,8 @@ exprIsConApp_maybe (in_scope, id_unf) expr -- See Note [exprIsConApp_maybe on literal strings] | (fun `hasKey` unpackCStringIdKey) || (fun `hasKey` unpackCStringUtf8IdKey) - , [arg] <- args - , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + , [arg] <- args + , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg = dealWithStringLiteral fun str co where unfolding = id_unf fun @@ -858,7 +858,7 @@ dealWithStringLiteral fun str co rest = if BS.null charTail then mkConApp nilDataCon [Type charTy] else App (Var fun) - (Lit (MachStr charTail)) + (Lit (LitString charTail)) in pushCoDataCon consDataCon [Type charTy, char, rest] co diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 19b6364e1e..58a7162dca 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -684,7 +684,7 @@ cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr -- See Note [Integer literals] in Literal cvtLitInteger dflags _ (Just sdatacon) i | inIntRange dflags i -- Special case for small integers - = mkConApp sdatacon [Lit (mkMachInt dflags i)] + = mkConApp sdatacon [Lit (mkLitInt dflags i)] cvtLitInteger dflags mk_integer _ i = mkApps (Var mk_integer) [isNonNegative, ints] @@ -694,7 +694,7 @@ cvtLitInteger dflags mk_integer _ i f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp intDataCon [Lit (mkMachInt dflags low)] : f high + in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high bits = 31 mask = 2 ^ bits - 1 @@ -704,7 +704,7 @@ cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr -- See Note [Natural literals] in Literal cvtLitNatural dflags _ (Just sdatacon) i | inWordRange dflags i -- Special case for small naturals - = mkConApp sdatacon [Lit (mkMachWord dflags i)] + = mkConApp sdatacon [Lit (mkLitWord dflags i)] cvtLitNatural dflags mk_natural _ i = mkApps (Var mk_natural) [words] @@ -712,7 +712,7 @@ cvtLitNatural dflags mk_natural _ i f 0 = [] f x = let low = x .&. mask high = x `shiftR` bits - in mkConApp wordDataCon [Lit (mkMachWord dflags low)] : f high + in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high bits = 32 mask = 2 ^ bits - 1 diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index aa27d7a7fb..53a399204e 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -1854,8 +1854,8 @@ mkIntLit :: DynFlags -> Integer -> Expr b -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' mkIntLitInt :: DynFlags -> Int -> Expr b -mkIntLit dflags n = Lit (mkMachInt dflags n) -mkIntLitInt dflags n = Lit (mkMachInt dflags (toInteger n)) +mkIntLit dflags n = Lit (mkLitInt dflags n) +mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) -- | Create a machine word literal expression of type @Word#@ from an @Integer@. -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' @@ -1864,14 +1864,14 @@ mkWordLit :: DynFlags -> Integer -> Expr b -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' mkWordLitWord :: DynFlags -> Word -> Expr b -mkWordLit dflags w = Lit (mkMachWord dflags w) -mkWordLitWord dflags w = Lit (mkMachWord dflags (toInteger w)) +mkWordLit dflags w = Lit (mkLitWord dflags w) +mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) mkWord64LitWord64 :: Word64 -> Expr b -mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) +mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) mkInt64LitInt64 :: Int64 -> Expr b -mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) +mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) -- | Create a machine character literal expression of type @Char#@. -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' @@ -1880,8 +1880,8 @@ mkCharLit :: Char -> Expr b -- If you want an expression of type @String@ use 'MkCore.mkStringExpr' mkStringLit :: String -> Expr b -mkCharLit c = Lit (mkMachChar c) -mkStringLit s = Lit (mkMachString s) +mkCharLit c = Lit (mkLitChar c) +mkStringLit s = Lit (mkLitString s) -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' @@ -1890,8 +1890,8 @@ mkFloatLit :: Rational -> Expr b -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' mkFloatLitFloat :: Float -> Expr b -mkFloatLit f = Lit (mkMachFloat f) -mkFloatLitFloat f = Lit (mkMachFloat (toRational f)) +mkFloatLit f = Lit (mkLitFloat f) +mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' @@ -1900,8 +1900,8 @@ mkDoubleLit :: Rational -> Expr b -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' mkDoubleLitDouble :: Double -> Expr b -mkDoubleLit d = Lit (mkMachDouble d) -mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) +mkDoubleLit d = Lit (mkLitDouble d) +mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes -- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index adb399ea6f..020aa8525a 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -772,7 +772,7 @@ litSize :: Literal -> Int -- Used by CoreUnfold.sizeExpr litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] litSize (LitNumber LitNumNatural _ _) = 100 -litSize (MachStr str) = 10 + 10 * ((BS.length str + 3) `div` 4) +litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless -- duplication of little strings] diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index c39e681ccb..aa77592ef0 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1527,7 +1527,7 @@ expr_ok primop_ok other_expr | (expr, args) <- collectArgs other_expr = case stripTicksTopE (not . tickishCounts) expr of Var f -> app_ok primop_ok f args - -- 'RubbishLit' is the only literal that can occur in the head of an + -- 'LitRubbish' is the only literal that can occur in the head of an -- application and will not be matched by the above case (Var /= Lit). Lit lit -> ASSERT( lit == rubbishLit ) True _ -> False @@ -1853,7 +1853,7 @@ exprIsTickedString = isJust . exprIsTickedString_maybe -- different shape. -- Used to "look through" Ticks in places that need to handle literal strings. exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString -exprIsTickedString_maybe (Lit (MachStr bs)) = Just bs +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs exprIsTickedString_maybe (Tick t e) -- we don't tick literals with CostCentre ticks, compare to mkTick | tickishPlace t == PlaceCostCentre = Nothing @@ -2489,9 +2489,9 @@ rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of Just e -> is_static in_arg e Nothing -> True - is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit (LitLabel {})) = False is_static _ (Lit _) = True - -- A MachLabel (foreign import "&foo") in an argument + -- A LitLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols -- in the object file: under Linux, references to "weak" diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index 8a7d3b4f6a..73c2e7c134 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -302,7 +302,7 @@ mkStringExprFSWith lookupM str where chars = unpackFS str safeChar c = ord c >= 1 && ord c <= 0x7F - lit = Lit (MachStr (fastStringToByteString str)) + lit = Lit (LitString (fastStringToByteString str)) {- ************************************************************************ @@ -658,7 +658,7 @@ mkRuntimeErrorApp err_id res_ty err_msg = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) , Type res_ty, err_string ] where - err_string = Lit (mkMachString err_msg) + err_string = Lit (mkLitString err_msg) mkImpossibleExpr :: Type -> CoreExpr mkImpossibleExpr res_ty @@ -896,4 +896,4 @@ mkAbsentErrorApp :: Type -- The type to instantiate 'a' mkAbsentErrorApp res_ty err_msg = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] where - err_string = Lit (mkMachString err_msg) + err_string = Lit (mkLitString err_msg) diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index 7a634ac1ff..7cab8e8e25 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -327,8 +327,8 @@ resultWrapper result_ty = do { dflags <- getDynFlags ; let marshal_bool e = mkWildCase e intPrimTy boolTy - [ (DEFAULT ,[],Var trueDataConId ) - , (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)] + [ (DEFAULT ,[],Var trueDataConId ) + , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)] ; return (Just intPrimTy, marshal_bool) } -- Newtypes diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 5856ff2445..2e20cc7f35 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -163,7 +163,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do (resTy, foRhs) <- resultWrapper ty ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let - rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) + rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) rhs' = Cast rhs co stdcall_info = fun_type_arg_stdcall_info dflags cconv ty in @@ -442,8 +442,8 @@ dsFExportDynamic id co0 cconv = do -} adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) , Var stbl_value - , Lit (MachLabel fe_nm mb_sz_args IsFunction) - , Lit (mkMachString typestring) + , Lit (LitLabel fe_nm mb_sz_args IsFunction) + , Lit (mkLitString typestring) ] -- name of external entry point providing these services. -- (probably in the RTS.) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 921276e4d8..e93b2c30d6 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -82,7 +82,7 @@ import ErrUtils import FastString import Var (EvVar) import UniqFM ( lookupWithDefaultUFM ) -import Literal ( mkMachString ) +import Literal ( mkLitString ) import CostCentreState import Data.IORef @@ -609,5 +609,5 @@ pprRuntimeTrace str doc expr = do dflags <- getDynFlags let message :: CoreExpr message = App (Var unpackCStringId) $ - Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc) + Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) return $ mkApps (Var traceId) [Type (exprType expr), message, expr] diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 001b36151c..ca22387b59 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -403,8 +403,8 @@ mkErrorAppDs err_id ty msg = do dflags <- getDynFlags let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkMachString full_msg) - -- mkMachString returns a result of type String# + core_msg = Lit (mkLitString full_msg) + -- mkLitString returns a result of type String# return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg]) {- diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index e4a8bad525..f207d6039d 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -848,8 +848,8 @@ Previously we had, as PatGroup constructors But Literal is really supposed to represent an *unboxed* literal, like Int#. We were sticking the literal from, say, an overloaded numeric literal pattern -into a MachInt constructor. This didn't really make sense; and we now have -the invariant that value in a MachInt must be in the range of the target +into a LitInt constructor. This didn't really make sense; and we now have +the invariant that value in a LitInt must be in the range of the target machine's Int# type, and an overloaded literal could meaningfully be larger. Solution: For pattern grouping purposes, just store the literal directly in diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index ca7ef0af2f..b91f44de26 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -80,14 +80,14 @@ dsLit :: HsLit GhcRn -> DsM CoreExpr dsLit l = do dflags <- getDynFlags case l of - HsStringPrim _ s -> return (Lit (MachStr s)) - HsCharPrim _ c -> return (Lit (MachChar c)) - HsIntPrim _ i -> return (Lit (mkMachIntWrap dflags i)) - HsWordPrim _ w -> return (Lit (mkMachWordWrap dflags w)) - HsInt64Prim _ i -> return (Lit (mkMachInt64Wrap dflags i)) - HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w)) - HsFloatPrim _ f -> return (Lit (MachFloat (fl_value f))) - HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d))) + HsStringPrim _ s -> return (Lit (LitString s)) + HsCharPrim _ c -> return (Lit (LitChar c)) + HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) + HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) + HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) + HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) + HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) + HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str HsInteger _ i _ -> mkIntegerExpr i @@ -375,9 +375,9 @@ matchLiterals (var:vars) ty sub_groups wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals - wrap_str_guard eq_str (MachStr s, mr) + wrap_str_guard eq_str (LitString s, mr) = do { -- We now have to convert back to FastString. Perhaps there - -- should be separate MachBytes and MachStr constructors? + -- should be separate LitBytes and LitString constructors? let s' = mkFastStringByteString s ; lit <- mkStringExprFS s' ; let pred = mkApps (Var eq_str) [Var var, lit] @@ -391,20 +391,20 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal -- Get the Core literal corresponding to a HsLit. -- It only works for primitive types and strings; -- others have been removed by tidy --- For HsString, it produces a MachStr, which really represents an _unboxed_ +-- For HsString, it produces a LitString, which really represents an _unboxed_ -- string literal; and we deal with it in matchLiterals above. Otherwise, it -- produces a primitive Literal of type matching the original HsLit. -- In the case of the fixed-width numeric types, we need to wrap here -- because Literal has an invariant that the literal is in range, while -- HsLit does not. -hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i -hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w -hsLitKey dflags (HsInt64Prim _ i) = mkMachInt64Wrap dflags i -hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w -hsLitKey _ (HsCharPrim _ c) = mkMachChar c -hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f) -hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d) -hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s) +hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i +hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w +hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i +hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) +hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) +hsLitKey _ (HsString _ s) = LitString (fastStringToByteString s) hsLitKey _ l = pprPanic "hsLitKey" (ppr l) {- diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 4473a9e9b2..0776e406d6 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -441,18 +441,18 @@ assembleI dflags i = case i of Op q, Op np] where - literal (MachLabel fs (Just sz) _) + literal (LitLabel fs (Just sz) _) | platformOS (targetPlatform dflags) == OSMinGW32 = litlabel (appendFS fs (mkFastString ('@':show sz))) -- On Windows, stdcall labels have a suffix indicating the no. of -- arg words, e.g. foo@8. testcase: ffi012(ghci) - literal (MachLabel fs _ _) = litlabel fs - literal MachNullAddr = int 0 - literal (MachFloat r) = float (fromRational r) - literal (MachDouble r) = double (fromRational r) - literal (MachChar c) = int (ord c) - literal (MachStr bs) = lit [BCONPtrStr bs] - -- MachStr requires a zero-terminator when emitted + literal (LitLabel fs _ _) = litlabel fs + literal LitNullAddr = int 0 + literal (LitFloat r) = float (fromRational r) + literal (LitDouble r) = double (fromRational r) + literal (LitChar c) = int (ord c) + literal (LitString bs) = lit [BCONPtrStr bs] + -- LitString requires a zero-terminator when emitted literal (LitNumber nt i _) = case nt of LitNumInt -> int (fromIntegral i) LitNumWord -> int (fromIntegral i) @@ -460,10 +460,10 @@ assembleI dflags i = case i of LitNumWord64 -> int64 (fromIntegral i) LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger" LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural" - -- We can lower 'RubbishLit' to an arbitrary constant, but @NULL@ is most + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most -- likely to elicit a crash (rather than corrupt memory) in case absence -- analysis messed up. - literal RubbishLit = int 0 + literal LitRubbish = int 0 litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a] diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index e723258910..113690780b 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -998,9 +998,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple my_discr (LitAlt l, _, _) = case l of LitNumber LitNumInt i _ -> DiscrI (fromInteger i) LitNumber LitNumWord w _ -> DiscrW (fromInteger w) - MachFloat r -> DiscrF (fromRational r) - MachDouble r -> DiscrD (fromRational r) - MachChar i -> DiscrI (ord i) + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons @@ -1200,7 +1200,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l StaticTarget _ _ _ False -> panic "generateCCall: unexpected FFI value import" StaticTarget _ target _ True -> - Just (MachLabel target mb_size IsFunction) + Just (LitLabel target mb_size IsFunction) where mb_size | OSMinGW32 <- platformOS (targetPlatform dflags) @@ -1300,13 +1300,13 @@ primRepToFFIType dflags r mkDummyLiteral :: DynFlags -> PrimRep -> Literal mkDummyLiteral dflags pr = case pr of - IntRep -> mkMachInt dflags 0 - WordRep -> mkMachWord dflags 0 - Int64Rep -> mkMachInt64 0 - Word64Rep -> mkMachWord64 0 - AddrRep -> MachNullAddr - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 + IntRep -> mkLitInt dflags 0 + WordRep -> mkLitWord dflags 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 _ -> pprPanic "mkDummyLiteral" (ppr pr) @@ -1423,7 +1423,7 @@ implement_tagToId d s p arg names slide_ws = bytesToWords dflags (d - s + arg_bytes) return (push_arg - `appOL` unitOL (PUSH_UBX MachNullAddr 1) + `appOL` unitOL (PUSH_UBX LitNullAddr 1) -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, @@ -1507,7 +1507,7 @@ pushAtom d p (AnnVar var) = do topStrings <- getTopStrings dflags <- getDynFlags case lookupVarEnv topStrings var of - Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $ + Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $ fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr Nothing -> do let sz = idSizeCon dflags var @@ -1523,12 +1523,13 @@ pushAtom _ _ (AnnLit lit) = do wordsToBytes dflags size_words) case lit of - MachLabel _ _ _ -> code N - MachFloat _ -> code F - MachDouble _ -> code D - MachChar _ -> code N - MachNullAddr -> code N - MachStr _ -> code N + LitLabel _ _ _ -> code N + LitFloat _ -> code F + LitDouble _ -> code D + LitChar _ -> code N + LitNullAddr -> code N + LitString _ -> code N + LitRubbish -> code N LitNumber nt _ _ -> case nt of LitNumInt -> code N LitNumWord -> code N @@ -1539,7 +1540,6 @@ pushAtom _ _ (AnnLit lit) = do -- representation. LitNumInteger -> panic "pushAtom: LitInteger" LitNumNatural -> panic "pushAtom: LitNatural" - RubbishLit -> code N pushAtom _ _ expr = pprPanic "ByteCodeGen.pushAtom" @@ -1552,7 +1552,7 @@ pushAtom _ _ expr pushConstrAtom :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff) -pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) = +pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) = return (unitOL (PUSH_UBX32 lit), 4) pushConstrAtom d p (AnnVar v) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index bc7bbaab1b..975c361085 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -188,7 +188,8 @@ pprSpecialStatic (LMBitc v t) = pprSpecialStatic stat = ppr stat -pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc +pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString + -> String -> SDoc pprStaticArith s1 s2 int_op float_op op_name = let ty1 = getStatType s1 op = if isFloat ty1 then float_op else int_op diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 9a3cb6009b..3e2c9638e3 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -604,7 +604,7 @@ cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") (sLit "Ambiguous interface for") -cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult +cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult -> SDoc cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) | Just pkgs <- unambiguousPackages @@ -751,8 +751,8 @@ cantFindErr cannot_find _ dflags mod_name find_result <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty -cantFindInstalledErr :: LitString -> LitString -> DynFlags -> ModuleName -> InstalledFindResult - -> SDoc +cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName + -> InstalledFindResult -> SDoc cantFindInstalledErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs index db5395af35..687a4f818f 100644 --- a/compiler/nativeGen/Dwarf/Constants.hs +++ b/compiler/nativeGen/Dwarf/Constants.hs @@ -164,7 +164,7 @@ dwarfSection name = sdocWithPlatform $ \plat -> -> text "\t.section .debug_" <> text name <> text ",\"dr\"" -- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: LitString +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString dwarfInfoLabel = sLit ".Lsection_info" dwarfAbbrevLabel = sLit ".Lsection_abbrev" dwarfLineLabel = sLit ".Lsection_line" diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index 25629448dd..05b5b7faad 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -56,7 +56,7 @@ data DwarfInfo , dwCompDir :: String , dwLowLabel :: CLabel , dwHighLabel :: CLabel - , dwLineLabel :: LitString } + , dwLineLabel :: PtrString } | DwarfSubprogram { dwChildren :: [DwarfInfo] , dwName :: String , dwLabel :: CLabel diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 2f64d82ee5..3d9077df19 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -986,7 +986,7 @@ pprInstr (UPDATE_SP fmt amount) -- pprInstr _ = panic "pprInstr (ppc)" -pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc +pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc pprLogic op reg1 reg2 ri = hcat [ char '\t', ptext op, @@ -1039,7 +1039,7 @@ pprDiv fmt sgn reg1 reg2 reg3 = hcat [ ] -pprUnary :: LitString -> Reg -> Reg -> SDoc +pprUnary :: PtrString -> Reg -> Reg -> SDoc pprUnary op reg1 reg2 = hcat [ char '\t', ptext op, @@ -1050,7 +1050,7 @@ pprUnary op reg1 reg2 = hcat [ ] -pprBinaryF :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc +pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc pprBinaryF op fmt reg1 reg2 reg3 = hcat [ char '\t', ptext op, diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index eb401fff06..b4cdbda369 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -572,7 +572,7 @@ pprRI (RIImm r) = pprImm r -- | Pretty print a two reg instruction. -pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc +pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc pprFormatRegReg name format reg1 reg2 = hcat [ char '\t', @@ -589,7 +589,7 @@ pprFormatRegReg name format reg1 reg2 -- | Pretty print a three reg instruction. -pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc +pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc pprFormatRegRegReg name format reg1 reg2 reg3 = hcat [ char '\t', @@ -607,7 +607,7 @@ pprFormatRegRegReg name format reg1 reg2 reg3 -- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: LitString -> Bool -> Reg -> RI -> Reg -> SDoc +pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc pprRegRIReg name b reg1 ri reg2 = hcat [ char '\t', @@ -621,7 +621,7 @@ pprRegRIReg name b reg1 ri reg2 ] {- -pprRIReg :: LitString -> Bool -> RI -> Reg -> SDoc +pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc pprRIReg name b ri reg1 = hcat [ char '\t', diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index acfae71b17..141e781cc6 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -407,7 +407,7 @@ pprReg f r _ -> ppr_reg_float i }) -ppr_reg_float :: Int -> LitString +ppr_reg_float :: Int -> PtrString ppr_reg_float i = case i of 16 -> sLit "%fake0"; 17 -> sLit "%fake1" 18 -> sLit "%fake2"; 19 -> sLit "%fake3" @@ -1202,17 +1202,17 @@ pprOperand _ (OpImm i) = pprDollImm i pprOperand _ (OpAddr ea) = pprAddr ea -pprMnemonic_ :: LitString -> SDoc +pprMnemonic_ :: PtrString -> SDoc pprMnemonic_ name = char '\t' <> ptext name <> space -pprMnemonic :: LitString -> Format -> SDoc +pprMnemonic :: PtrString -> Format -> SDoc pprMnemonic name format = char '\t' <> ptext name <> pprFormat format <> space -pprFormatImmOp :: LitString -> Format -> Imm -> Operand -> SDoc +pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc pprFormatImmOp name format imm op1 = hcat [ pprMnemonic name format, @@ -1223,14 +1223,14 @@ pprFormatImmOp name format imm op1 ] -pprFormatOp_ :: LitString -> Format -> Operand -> SDoc +pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc pprFormatOp_ name format op1 = hcat [ pprMnemonic_ name , pprOperand format op1 ] -pprFormatOp :: LitString -> Format -> Operand -> SDoc +pprFormatOp :: PtrString -> Format -> Operand -> SDoc pprFormatOp name format op1 = hcat [ pprMnemonic name format, @@ -1238,7 +1238,7 @@ pprFormatOp name format op1 ] -pprFormatOpOp :: LitString -> Format -> Operand -> Operand -> SDoc +pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc pprFormatOpOp name format op1 op2 = hcat [ pprMnemonic name format, @@ -1248,7 +1248,7 @@ pprFormatOpOp name format op1 op2 ] -pprOpOp :: LitString -> Format -> Operand -> Operand -> SDoc +pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc pprOpOp name format op1 op2 = hcat [ pprMnemonic_ name, @@ -1258,7 +1258,7 @@ pprOpOp name format op1 op2 ] -pprFormatReg :: LitString -> Format -> Reg -> SDoc +pprFormatReg :: PtrString -> Format -> Reg -> SDoc pprFormatReg name format reg1 = hcat [ pprMnemonic name format, @@ -1266,7 +1266,7 @@ pprFormatReg name format reg1 ] -pprFormatRegReg :: LitString -> Format -> Reg -> Reg -> SDoc +pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc pprFormatRegReg name format reg1 reg2 = hcat [ pprMnemonic name format, @@ -1276,7 +1276,7 @@ pprFormatRegReg name format reg1 reg2 ] -pprRegReg :: LitString -> Reg -> Reg -> SDoc +pprRegReg :: PtrString -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2 = sdocWithPlatform $ \platform -> hcat [ @@ -1287,7 +1287,7 @@ pprRegReg name reg1 reg2 ] -pprFormatOpReg :: LitString -> Format -> Operand -> Reg -> SDoc +pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc pprFormatOpReg name format op1 reg2 = sdocWithPlatform $ \platform -> hcat [ @@ -1297,7 +1297,7 @@ pprFormatOpReg name format op1 reg2 pprReg (archWordFormat (target32Bit platform)) reg2 ] -pprCondOpReg :: LitString -> Format -> Cond -> Operand -> Reg -> SDoc +pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc pprCondOpReg name format cond op1 reg2 = hcat [ char '\t', @@ -1309,7 +1309,7 @@ pprCondOpReg name format cond op1 reg2 pprReg format reg2 ] -pprCondRegReg :: LitString -> Format -> Cond -> Reg -> Reg -> SDoc +pprCondRegReg :: PtrString -> Format -> Cond -> Reg -> Reg -> SDoc pprCondRegReg name format cond reg1 reg2 = hcat [ char '\t', @@ -1321,7 +1321,7 @@ pprCondRegReg name format cond reg1 reg2 pprReg format reg2 ] -pprFormatFormatRegReg :: LitString -> Format -> Format -> Reg -> Reg -> SDoc +pprFormatFormatRegReg :: PtrString -> Format -> Format -> Reg -> Reg -> SDoc pprFormatFormatRegReg name format1 format2 reg1 reg2 = hcat [ char '\t', @@ -1334,7 +1334,7 @@ pprFormatFormatRegReg name format1 format2 reg1 reg2 pprReg format2 reg2 ] -pprFormatFormatOpReg :: LitString -> Format -> Format -> Operand -> Reg -> SDoc +pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc pprFormatFormatOpReg name format1 format2 op1 reg2 = hcat [ pprMnemonic name format2, @@ -1343,7 +1343,7 @@ pprFormatFormatOpReg name format1 format2 op1 reg2 pprReg format2 reg2 ] -pprFormatRegRegReg :: LitString -> Format -> Reg -> Reg -> Reg -> SDoc +pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc pprFormatRegRegReg name format reg1 reg2 reg3 = hcat [ pprMnemonic name format, @@ -1354,7 +1354,7 @@ pprFormatRegRegReg name format reg1 reg2 reg3 pprReg format reg3 ] -pprFormatOpOpReg :: LitString -> Format -> Operand -> Operand -> Reg -> SDoc +pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc pprFormatOpOpReg name format op1 op2 reg3 = hcat [ pprMnemonic name format, @@ -1365,7 +1365,7 @@ pprFormatOpOpReg name format op1 op2 reg3 pprReg format reg3 ] -pprFormatAddrReg :: LitString -> Format -> AddrMode -> Reg -> SDoc +pprFormatAddrReg :: PtrString -> Format -> AddrMode -> Reg -> SDoc pprFormatAddrReg name format op dst = hcat [ pprMnemonic name format, @@ -1375,7 +1375,7 @@ pprFormatAddrReg name format op dst ] -pprFormatRegAddr :: LitString -> Format -> Reg -> AddrMode -> SDoc +pprFormatRegAddr :: PtrString -> Format -> Reg -> AddrMode -> SDoc pprFormatRegAddr name format src op = hcat [ pprMnemonic name format, @@ -1385,7 +1385,7 @@ pprFormatRegAddr name format src op ] -pprShift :: LitString -> Format -> Operand -> Operand -> SDoc +pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc pprShift name format src dest = hcat [ pprMnemonic name format, @@ -1395,7 +1395,7 @@ pprShift name format src dest ] -pprFormatOpOpCoerce :: LitString -> Format -> Format -> Operand -> Operand -> SDoc +pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc pprFormatOpOpCoerce name format1 format2 op1 op2 = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, pprOperand format1 op1, @@ -1404,6 +1404,6 @@ pprFormatOpOpCoerce name format1 format2 op1 op2 ] -pprCondInstr :: LitString -> Cond -> SDoc -> SDoc +pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc pprCondInstr name cond arg = hcat [ char '\t', ptext name, pprCond cond, space, arg] diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 3d419ba382..ce269e36f6 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -362,18 +362,18 @@ mkFloatingRelOpRule nm cmp -- common constants zeroi, onei, zerow, onew :: DynFlags -> Literal -zeroi dflags = mkMachInt dflags 0 -onei dflags = mkMachInt dflags 1 -zerow dflags = mkMachWord dflags 0 -onew dflags = mkMachWord dflags 1 +zeroi dflags = mkLitInt dflags 0 +onei dflags = mkLitInt dflags 1 +zerow dflags = mkLitWord dflags 0 +onew dflags = mkLitWord dflags 1 zerof, onef, twof, zerod, oned, twod :: Literal -zerof = mkMachFloat 0.0 -onef = mkMachFloat 1.0 -twof = mkMachFloat 2.0 -zerod = mkMachDouble 0.0 -oned = mkMachDouble 1.0 -twod = mkMachDouble 2.0 +zerof = mkLitFloat 0.0 +onef = mkLitFloat 1.0 +twof = mkLitFloat 2.0 +zerod = mkLitDouble 0.0 +oned = mkLitDouble 1.0 +twod = mkLitDouble 2.0 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) -> Literal -> Literal -> Maybe CoreExpr @@ -383,9 +383,9 @@ cmpOp dflags cmp = go done False = Just $ falseValInt dflags -- These compares are at different types - go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) - go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2) - go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2) + go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) + go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) + go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) | nt1 /= nt2 = Nothing | otherwise = done (i1 `cmp` i2) @@ -394,10 +394,10 @@ cmpOp dflags cmp = go -------------------------- negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate -negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f)) -negOp _ (MachDouble 0.0) = Nothing -negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d)) +negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) +negOp _ (LitDouble 0.0) = Nothing +negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) negOp dflags (LitNumber nt i t) | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) negOp _ _ = Nothing @@ -493,7 +493,7 @@ wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shi floatOp2 :: (Rational -> Rational -> Rational) -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -floatOp2 op dflags (MachFloat f1) (MachFloat f2) +floatOp2 op dflags (LitFloat f1) (LitFloat f2) = Just (mkFloatVal dflags (f1 `op` f2)) floatOp2 _ _ _ _ = Nothing @@ -501,7 +501,7 @@ floatOp2 _ _ _ _ = Nothing doubleOp2 :: (Rational -> Rational -> Rational) -> DynFlags -> Literal -> Literal -> Maybe (Expr CoreBndr) -doubleOp2 op dflags (MachDouble f1) (MachDouble f2) +doubleOp2 op dflags (LitDouble f1) (LitDouble f2) = Just (mkDoubleVal dflags (f1 `op` f2)) doubleOp2 _ _ _ _ = Nothing @@ -573,7 +573,7 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dfla mkRuleFn _ _ _ _ = Nothing isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (MachChar c) = c == minBound +isMinBound _ (LitChar c) = c == minBound isMinBound dflags (LitNumber nt i _) = case nt of LitNumInt -> i == tARGET_MIN_INT dflags LitNumInt64 -> i == toInteger (minBound :: Int64) @@ -584,7 +584,7 @@ isMinBound dflags (LitNumber nt i _) = case nt of isMinBound _ _ = False isMaxBound :: DynFlags -> Literal -> Bool -isMaxBound _ (MachChar c) = c == maxBound +isMaxBound _ (LitChar c) = c == maxBound isMaxBound dflags (LitNumber nt i _) = case nt of LitNumInt -> i == tARGET_MAX_INT dflags LitNumInt64 -> i == toInteger (maxBound :: Int64) @@ -600,7 +600,7 @@ intResult :: DynFlags -> Integer -> Maybe CoreExpr intResult dflags result = Just (intResult' dflags result) intResult' :: DynFlags -> Integer -> CoreExpr -intResult' dflags result = Lit (mkMachIntWrap dflags result) +intResult' dflags result = Lit (mkLitIntWrap dflags result) -- | Create an unboxed pair of an Int literal expression, ensuring the given -- Integer is in the target Int range and the corresponding overflow flag @@ -609,7 +609,7 @@ intCResult :: DynFlags -> Integer -> Maybe CoreExpr intCResult dflags result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] - (lit, b) = mkMachIntWrapC dflags result + (lit, b) = mkLitIntWrapC dflags result c = if b then onei dflags else zeroi dflags -- | Create a Word literal expression while ensuring the given Integer is in the @@ -618,7 +618,7 @@ wordResult :: DynFlags -> Integer -> Maybe CoreExpr wordResult dflags result = Just (wordResult' dflags result) wordResult' :: DynFlags -> Integer -> CoreExpr -wordResult' dflags result = Lit (mkMachWordWrap dflags result) +wordResult' dflags result = Lit (mkLitWordWrap dflags result) -- | Create an unboxed pair of a Word literal expression, ensuring the given -- Integer is in the target Word range and the corresponding carry flag @@ -627,7 +627,7 @@ wordCResult :: DynFlags -> Integer -> Maybe CoreExpr wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) where mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] - (lit, b) = mkMachWordWrapC dflags result + (lit, b) = mkLitWordWrapC dflags result c = if b then onei dflags else zeroi dflags inversePrimOp :: PrimOp -> RuleM CoreExpr @@ -898,21 +898,21 @@ nonZeroLit n = getLiteral n >>= guard . not . isZeroLit -- Rational value to that of Float/Double. We confuse host architecture -- and target architecture here, but it's convenient (and wrong :-). convFloating :: DynFlags -> Literal -> Literal -convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) = - MachFloat (toRational (fromRational f :: Float )) -convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) = - MachDouble (toRational (fromRational d :: Double)) +convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = + LitFloat (toRational (fromRational f :: Float )) +convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = + LitDouble (toRational (fromRational d :: Double)) convFloating _ l = l guardFloatDiv :: RuleM () guardFloatDiv = do - [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs + [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] && f2 /= 0 -- avoid NaN and Infinity/-Infinity guardDoubleDiv :: RuleM () guardDoubleDiv = do - [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs + [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] && d2 /= 0 -- avoid NaN and Infinity/-Infinity -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to @@ -961,11 +961,11 @@ eqVal = Var ordEQDataConId gtVal = Var ordGTDataConId mkIntVal :: DynFlags -> Integer -> Expr CoreBndr -mkIntVal dflags i = Lit (mkMachInt dflags i) +mkIntVal dflags i = Lit (mkLitInt dflags i) mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr -mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f)) +mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr -mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d)) +mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) matchPrimOpId :: PrimOp -> Id -> RuleM () matchPrimOpId op id = do @@ -1342,11 +1342,11 @@ match_append_lit _ id_unf _ ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 - , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 `BS.append` s2)) + `App` Lit (LitString (s1 `BS.append` s2)) `App` c1 `App` n) @@ -1361,8 +1361,8 @@ match_eq_string _ id_unf _ [Var unpk1 `App` lit1, Var unpk2 `App` lit2] | unpk1 `hasKey` unpackCStringIdKey , unpk2 `hasKey` unpackCStringIdKey - , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 = Just (if s1 == s2 then trueValBool else falseValBool) match_eq_string _ _ _ _ = Nothing @@ -1639,7 +1639,7 @@ match_rationalTo _ _ _ _ _ = Nothing match_decodeDouble :: RuleFun match_decodeDouble dflags id_unf fn [xl] - | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl + | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, res) | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res @@ -1647,7 +1647,7 @@ match_decodeDouble dflags id_unf fn [xl] (y, z) -> Just $ mkCoreUbxTup [integerTy, intHashTy] [Lit (mkLitInteger y integerTy), - Lit (mkMachInt dflags (toInteger z))] + Lit (mkLitInt dflags (toInteger z))] _ -> pprPanic "match_decodeDouble: Id has the wrong type" (ppr fn <+> dcolon <+> ppr (idType fn)) @@ -2004,7 +2004,7 @@ tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon tx_lit_con _ _ DEFAULT = Just DEFAULT tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) - -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the + -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges -- (See Note [Word/Int underflow/overflow] in Literal and #13172). @@ -2046,7 +2046,7 @@ tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon tx_con_tte _ DEFAULT = Just DEFAULT tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] - = Just $ LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc + = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc tx_con_dtt :: Type -> AltCon -> Maybe AltCon tx_con_dtt _ DEFAULT = Just DEFAULT diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index aeb4755552..a63ed27407 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -980,7 +980,7 @@ It's important to float Integer literals, so that they get shared, rather than being allocated every time round the loop. Hence the litIsTrivial. -Ditto literal strings (MachStr), which we'd like to float to top +Ditto literal strings (LitString), which we'd like to float to top level, which is now possible. diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 872973925f..fca9904f19 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -19,7 +19,7 @@ import SimplEnv import SimplUtils import OccurAnal ( occurAnalyseExpr ) import FamInstEnv ( FamInstEnv ) -import Literal ( litIsLifted ) --, mkMachInt ) -- temporalily commented out. See #8326 +import Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 import Id import MkId ( seqId ) import MkCore ( mkImpossibleExpr, castBottomExpr ) @@ -1963,7 +1963,7 @@ tryRules env rules fn args call_cont = ASSERT( isEnumerationTyCon (dataConTyCon con) ) (LitAlt tag, [], rhs) where - tag = mkMachInt dflags (toInteger (dataConTag con - fIRST_TAG)) + tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG)) enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index c3a8bc76e2..e87fd853c9 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -580,8 +580,8 @@ mkUbxSum dc ty_args args0 -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore slotRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0 wordPrimTy) slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy) - slotRubbishArg FloatSlot = StgLitArg (MachFloat 0) - slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0) + slotRubbishArg FloatSlot = StgLitArg (LitFloat 0) + slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0) in tag_arg : mkTupArgs 0 sum_slots arg_idxs diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 1b1d4639f2..74bb7b6014 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -371,8 +371,8 @@ coreToStgExpr coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (App (Lit RubbishLit) _some_unlifted_type) - -- We lower 'RubbishLit' to @()@ here, which is much easier than doing it in +coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) + -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in -- a STG to Cmm pass. = coreToStgExpr (Var unitDataConId) coreToStgExpr (Var v) = coreToStgApp Nothing v [] [] diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 8a2ecc2016..f01dc6c385 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -922,7 +922,7 @@ buggily is used we'll get a runtime error message. Coping with absence for *unlifted* types is important; see, for example, Trac #4306 and Trac #15627. In the UnliftedRep case, we can -use RubbishLit, which we need to apply to the required type. +use LitRubbish, which we need to apply to the required type. For the unlifted types of singleton kind like Float#, Addr#, etc. we also find a suitable literal, using Literal.absentLiteralOf. We don't have literals for every primitive type, so the function is partial. diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs index 8d8aa9bb10..7ccd018e26 100644 --- a/compiler/typecheck/TcEvTerm.hs +++ b/compiler/typecheck/TcEvTerm.hs @@ -29,7 +29,7 @@ evDelayedError ty msg Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg] where errorId = tYPE_ERROR_ID - litMsg = Lit (MachStr (fastStringToByteString msg)) + litMsg = Lit (LitString (fastStringToByteString msg)) -- Dictionary for CallStack implicit parameters evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 31ac55fe5e..5fd91c6b3b 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -2080,7 +2080,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: LitString -> SDoc -> TcM a +noTH :: PtrString -> SDoc -> TcM a noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+> text "in Template Haskell:", nest 2 d]) diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs index 99c043ce41..f4b406fe90 100644 --- a/compiler/utils/BufWrite.hs +++ b/compiler/utils/BufWrite.hs @@ -19,7 +19,7 @@ module BufWrite ( bPutStr, bPutFS, bPutFZS, - bPutLitString, + bPutPtrString, bPutReplicate, bFlush, ) where @@ -98,15 +98,15 @@ bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do copyBytes (buf `plusPtr` i) ptr len writeFastMutInt r (i + len) -bPutLitString :: BufHandle -> LitString -> IO () -bPutLitString b@(BufHandle buf r hdl) l@(LitString a len) = l `seq` do +bPutPtrString :: BufHandle -> PtrString -> IO () +bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do i <- readFastMutInt r if (i+len) >= buf_size then do hPutBuf hdl buf i writeFastMutInt r 0 if (len >= buf_size) then hPutBuf hdl a len - else bPutLitString b l + else bPutPtrString b l else do copyBytes (buf `plusPtr` i) a len writeFastMutInt r (i+len) diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs index 5869449f86..c53eff1dd1 100644 --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -16,7 +16,7 @@ -- * Generated by 'fsLit'. -- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. -- --- ['LitString'] +-- ['PtrString'] -- -- * Pointer and size of a Latin-1 encoded string. -- * Practically no operations. @@ -28,7 +28,7 @@ -- * It assumes Latin-1 as the encoding, therefore it cannot represent -- arbitrary Unicode strings. -- --- Use 'LitString' unless you want the facilities of 'FastString'. +-- Use 'PtrString' unless you want the facilities of 'FastString'. module FastString ( -- * ByteString @@ -79,19 +79,19 @@ module FastString getFastStringTable, hasZEncoding, - -- * LitStrings - LitString (..), + -- * PtrStrings + PtrString (..), -- ** Construction sLit, - mkLitString#, - mkLitString, + mkPtrString#, + mkPtrString, -- ** Deconstruction - unpackLitString, + unpackPtrString, -- ** Operations - lengthLS + lengthPS ) where #include "HsVersions.h" @@ -627,21 +627,21 @@ hPutFS handle fs = BS.hPut handle $ fastStringToByteString fs -- in the current locale's encoding (for error messages and suchlike). -- ----------------------------------------------------------------------------- --- LitStrings, here for convenience only. +-- PtrStrings, here for convenience only. --- | A 'LitString' is a pointer to some array of Latin-1 encoded chars. -data LitString = LitString !(Ptr Word8) !Int +-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. +data PtrString = PtrString !(Ptr Word8) !Int --- | Wrap an unboxed address into a 'LitString'. -mkLitString# :: Addr# -> LitString -mkLitString# a# = LitString (Ptr a#) (ptrStrLength (Ptr a#)) +-- | Wrap an unboxed address into a 'PtrString'. +mkPtrString# :: Addr# -> PtrString +mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) --- | Encode a 'String' into a newly allocated 'LitString' using Latin-1 +-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 -- encoding. The original string must not contain non-Latin-1 characters -- (above codepoint @0xff@). -{-# INLINE mkLitString #-} -mkLitString :: String -> LitString -mkLitString s = +{-# INLINE mkPtrString #-} +mkPtrString :: String -> PtrString +mkPtrString s = -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks -- and because someone might be using `eqAddr#` to check for string equality. unsafePerformIO (do @@ -654,17 +654,17 @@ mkLitString s = pokeByteOff p n (fromIntegral (ord c) :: Word8) loop (1+n) cs loop 0 s - return (LitString p len) + return (PtrString p len) ) --- | Decode a 'LitString' back into a 'String' using Latin-1 encoding. --- This does not free the memory associated with 'LitString'. -unpackLitString :: LitString -> String -unpackLitString (LitString (Ptr p#) (I# n#)) = unpackNBytes# p# n# +-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. +-- This does not free the memory associated with 'PtrString'. +unpackPtrString :: PtrString -> String +unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# --- | Return the length of a 'LitString' -lengthLS :: LitString -> Int -lengthLS (LitString _ n) = n +-- | Return the length of a 'PtrString' +lengthPS :: PtrString -> Int +lengthPS (PtrString _ n) = n -- ----------------------------------------------------------------------------- -- under the carpet @@ -673,14 +673,14 @@ foreign import ccall unsafe "strlen" ptrStrLength :: Ptr Word8 -> Int {-# NOINLINE sLit #-} -sLit :: String -> LitString -sLit x = mkLitString x +sLit :: String -> PtrString +sLit x = mkPtrString x {-# NOINLINE fsLit #-} fsLit :: String -> FastString fsLit x = mkFastString x {-# RULES "slit" - forall x . sLit (unpackCString# x) = mkLitString# x #-} + forall x . sLit (unpackCString# x) = mkPtrString# x #-} {-# RULES "fslit" forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 929c7f3d58..28fd48783c 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -553,7 +553,7 @@ empty :: SDoc char :: Char -> SDoc text :: String -> SDoc ftext :: FastString -> SDoc -ptext :: LitString -> SDoc +ptext :: PtrString -> SDoc ztext :: FastZString -> SDoc int :: Int -> SDoc integer :: Integer -> SDoc diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs index 1a8bc23205..32b982855a 100644 --- a/compiler/utils/Pretty.hs +++ b/compiler/utils/Pretty.hs @@ -270,7 +270,7 @@ data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment | Str String -- ^ A whole String fragment | PStr FastString -- a hashed string | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !LitString + | LStr {-# UNPACK #-} !PtrString -- a '\0'-terminated array of bytes | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char -- a repeated character (e.g., ' ') @@ -306,17 +306,17 @@ text s = textBeside_ (Str s) (length s) Empty -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the -- intermediate packing/unpacking of the string. {-# RULES "text/str" - forall a. text (unpackCString# a) = ptext (mkLitString# a) + forall a. text (unpackCString# a) = ptext (mkPtrString# a) #-} {-# RULES "text/unpackNBytes#" - forall p n. text (unpackNBytes# p n) = ptext (LitString (Ptr p) (I# n)) + forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) #-} ftext :: FastString -> Doc ftext s = textBeside_ (PStr s) (lengthFS s) Empty -ptext :: LitString -> Doc -ptext s = textBeside_ (LStr s) (lengthLS s) Empty +ptext :: PtrString -> Doc +ptext s = textBeside_ (LStr s) (lengthPS s) Empty ztext :: FastZString -> Doc ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty @@ -941,7 +941,7 @@ txtPrinter (Chr c) s = c:s txtPrinter (Str s1) s2 = s1 ++ s2 txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 txtPrinter (ZStr s1) s2 = zString s1 ++ s2 -txtPrinter (LStr s1) s2 = unpackLitString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 txtPrinter (RStr n c) s2 = replicate n c ++ s2 -- | The general rendering interface. @@ -1053,15 +1053,15 @@ printDoc_ mode pprCols hdl doc -- NB. not hPutFS, we want this to go through -- the I/O library's encoding layer. (#3398) put (ZStr s) next = hPutFZS hdl s >> next - put (LStr s) next = hPutLitString hdl s >> next + put (LStr s) next = hPutPtrString hdl s >> next put (RStr n c) next = hPutStr hdl (replicate n c) >> next done = return () -- hPutChar hdl '\n' -- some versions of hPutBuf will barf if the length is zero -hPutLitString :: Handle -> LitString -> IO () -hPutLitString _handle (LitString _ 0) = return () -hPutLitString handle (LitString a l) = hPutBuf handle a l +hPutPtrString :: Handle -> PtrString -> IO () +hPutPtrString _handle (PtrString _ 0) = return () +hPutPtrString handle (PtrString a l) = hPutBuf handle a l -- Printing output in LeftMode is performance critical: it's used when -- dumping C and assembly output, so we allow ourselves a few dirty @@ -1099,7 +1099,7 @@ layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s - put b (LStr s) = bPutLitString b s + put b (LStr s) = bPutPtrString b s put b (RStr n c) = bPutReplicate b n c layLeft _ _ = panic "layLeft: Unhandled case" diff --git a/testsuite/tests/plugins/HomePackagePlugin.hs b/testsuite/tests/plugins/HomePackagePlugin.hs index 7a6942be6a..7c979c3fb5 100644 --- a/testsuite/tests/plugins/HomePackagePlugin.hs +++ b/testsuite/tests/plugins/HomePackagePlugin.hs @@ -20,7 +20,7 @@ replaceInBind (Rec bes) = Rec [(b, replaceInExpr e) | (b, e) <- bes] replaceInExpr :: CoreExpr -> CoreExpr replaceInExpr (Var x) = Var x -replaceInExpr (Lit (MachStr _)) = mkStringLit "Hello From The Plugin" -- The payload +replaceInExpr (Lit (LitString _)) = mkStringLit "Hello From The Plugin" -- The payload replaceInExpr (Lit l) = Lit l replaceInExpr (Lam b e) = Lam b (replaceInExpr e) replaceInExpr (App e1 e2) = App (replaceInExpr e1) (replaceInExpr e2) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs index 94cb74b151..9c0fdcbb5a 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -67,11 +67,11 @@ changeBindPr anns mb_replacement b e = do changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of - Lit (MachStr _) -> case mb_replacement of + Lit (LitString _) -> case mb_replacement of Nothing -> return e Just replacement -> do putMsgS "Performing Replacement" - return $ Lit (MachStr (fastStringToByteString (mkFastString replacement))) + return $ Lit (LitString (fastStringToByteString (mkFastString replacement))) App e1 e2 -> liftM2 App (go e1) (go e2) Lam b e -> liftM (Lam b) (go e) Let bind e -> liftM2 Let (changeBind anns mb_replacement bind) (go e) |