Commit 13bb4bf4 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

Rename literal constructors

In a previous patch we replaced some built-in literal constructors
(MachInt, MachWord, etc.) with a single LitNumber constructor.

In this patch we replace the `Mach` prefix of the remaining constructors
with `Lit` for consistency (e.g., LitChar, LitLabel, etc.).

Sadly the name `LitString` was already taken for a kind of FastString
and it would become misleading to have both `LitStr` (literal
constructor renamed after `MachStr`) and `LitString` (FastString
variant). Hence this patch renames the FastString variant `PtrString`
(which is more accurate) and the literal string constructor now uses the
least surprising `LitString` name.

Both `Literal` and `LitString/PtrString` have recently seen breaking
changes so doing this kind of renaming now shouldn't harm much.

Reviewers: hvr, goldfire, bgamari, simonmar, jrtc27, tdammers

Subscribers: tdammers, rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4881
parent f5fbecc8
This diff is collapsed.
......@@ -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
......
......@@ -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")
......
......@@ -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
......
......@@ -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)
--------------------------------------------------------------------------
--
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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"
......
......@@ -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)
......@@ -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
......
......@@ -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.)
......
......@@ -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]
......@@ -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])
{-
......
......@@ -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
......
......@@ -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)
{-
......
......@@ -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]
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -56,7 +56,7 @@ data DwarfInfo
, dwCompDir :: String
, dwLowLabel :: CLabel
, dwHighLabel :: CLabel
, dwLineLabel :: LitString }
, dwLineLabel :: PtrString }
| DwarfSubprogram { dwChildren :: [DwarfInfo]
, dwName :: String
, dwLabel :: CLabel
......
......@@ -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,
......
......@@ -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',
......
......@@ -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