\section[Literal]{@Literal@: Machine literals (unboxed, of course)}
\begin{code}
-#include "HsVersions.h"
-
-module Literal (
- Literal(..),
-
- mkMachInt, mkMachWord,
- literalType, literalPrimRep,
- showLiteral,
- isNoRepLit, isLitLitLit
- ) where
+module Literal
+ (
+ Literal(..)
+
+ , mkMachInt
+ , mkMachInt_safe
+ , mkMachWord
+ , literalType
+ , literalPrimRep
+ , showLiteral
+ , isNoRepLit
+ , isLitLitLit
+ ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ratio)
+#include "HsVersions.h"
-- friends:
import PrimRep ( PrimRep(..), ppPrimRep ) -- non-abstract
import TysPrim ( getPrimRepInfo,
addrPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, charPrimTy, wordPrimTy )
+ doublePrimTy, charPrimTy, wordPrimTy
+ )
-- others:
+import Type ( Type )
import CStrings ( stringToC, charToC, charToEasyHaskell )
import TysWiredIn ( stringTy )
-import Pretty -- pretty-printing stuff
-import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
-import Util ( thenCmp, panic, pprPanic )
+import Outputable
+import Util ( thenCmp )
+
\end{code}
So-called @Literals@ are {\em either}:
| MachInt Integer -- for the numeric types, these are
Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+ | MachInt64 Integer -- guaranteed 64-bit versions of the above.
+ Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
+
| MachFloat Rational
| MachDouble Rational
mkMachInt x = MachInt x True{-signed-}
mkMachWord x = MachInt x False{-unsigned-}
-instance Ord3 Literal where
- cmp (MachChar a) (MachChar b) = a `tcmp` b
- cmp (MachStr a) (MachStr b) = a `tcmp` b
- cmp (MachAddr a) (MachAddr b) = a `tcmp` b
- cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
- cmp (MachFloat a) (MachFloat b) = a `tcmp` b
- cmp (MachDouble a) (MachDouble b) = a `tcmp` b
- cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
- cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b
- cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b
- cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
-
- -- now we *know* the tags are different, so...
- cmp other_1 other_2
- | tag1 _LT_ tag2 = LT_
- | otherwise = GT_
- where
- tag1 = tagof other_1
- tag2 = tagof other_2
-
- tagof (MachChar _) = ILIT(1)
- tagof (MachStr _) = ILIT(2)
- tagof (MachAddr _) = ILIT(3)
- tagof (MachInt _ _) = ILIT(4)
- tagof (MachFloat _) = ILIT(5)
- tagof (MachDouble _) = ILIT(6)
- tagof (MachLitLit _ _) = ILIT(7)
- tagof (NoRepStr _) = ILIT(8)
- tagof (NoRepInteger _ _) = ILIT(9)
- tagof (NoRepRational _ _) = ILIT(10)
+-- check if the int is within range
+mkMachInt_safe :: Integer -> Literal
+mkMachInt_safe i
+ | out_of_range =
+ pprPanic "mkMachInt_safe"
+ (hsep [text "ERROR: Int ", text (show i), text "out of range",
+ brackets (int minInt <+> text ".." <+> int maxInt)])
+ | otherwise = MachInt i True{-signed-}
+ where
+ out_of_range =
+-- i < fromInt minBound ||
+ i > fromInt maxInt
+
+mkMachInt64 x = MachInt64 x True{-signed-}
+mkMachWord64 x = MachInt64 x False{-unsigned-}
+
+cmpLit (MachChar a) (MachChar b) = a `compare` b
+cmpLit (MachStr a) (MachStr b) = a `compare` b
+cmpLit (MachAddr a) (MachAddr b) = a `compare` b
+cmpLit (MachInt a b) (MachInt c d) = (a `compare` c) `thenCmp` (b `compare` d)
+cmpLit (MachFloat a) (MachFloat b) = a `compare` b
+cmpLit (MachDouble a) (MachDouble b) = a `compare` b
+cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d)
+cmpLit (NoRepStr a) (NoRepStr b) = a `compare` b
+cmpLit (NoRepInteger a _) (NoRepInteger b _) = a `compare` b
+cmpLit (NoRepRational a _) (NoRepRational b _) = a `compare` b
+
+ -- now we *know* the tags are different, so...
+cmpLit other_1 other_2
+ | tag1 _LT_ tag2 = LT
+ | otherwise = GT
+ where
+ tag1 = tagof other_1
+ tag2 = tagof other_2
+
+ tagof (MachChar _) = ILIT(1)
+ tagof (MachStr _) = ILIT(2)
+ tagof (MachAddr _) = ILIT(3)
+ tagof (MachInt _ _) = ILIT(4)
+ tagof (MachFloat _) = ILIT(5)
+ tagof (MachDouble _) = ILIT(6)
+ tagof (MachLitLit _ _) = ILIT(7)
+ tagof (NoRepStr _) = ILIT(8)
+ tagof (NoRepInteger _ _) = ILIT(9)
+ tagof (NoRepRational _ _) = ILIT(10)
-tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
-
instance Eq Literal where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord Literal where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
- _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = cmpLit a b
\end{code}
\begin{code}
literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
literalPrimRep (MachAddr _) = AddrRep
literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
+literalPrimRep (MachInt64 _ signed) = if signed then Int64Rep else Word64Rep
literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachLitLit _ k) = k
The boring old output stuff:
\begin{code}
-ppCast :: PprStyle -> FAST_STRING -> Pretty
-ppCast PprForC cast = ppPStr cast
-ppCast _ _ = ppNil
-
-- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
-- exceptions: MachFloat and MachAddr get an initial keyword prefix
--
-- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
instance Outputable Literal where
- ppr sty (MachChar ch)
- = let
- char_encoding
- = case sty of
- PprForC -> charToC ch
- PprForAsm _ _ -> charToC ch
- PprInterface -> charToEasyHaskell ch
- _ -> [ch]
- in
- ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']
-
- ppr sty (MachStr s)
- | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
- | otherwise = ppBesides [ppChar '"', ppPStr s, ppChar '"']
-
- ppr sty lit@(NoRepStr s)
- | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
- | otherwise = ppBesides [ppPStr SLIT("_string_"), ppChar '"', ppPStr s,ppChar '"']
-
- ppr sty (MachInt i signed)
- | codeStyle sty && out_of_range
- = panic ("ERROR: Int " ++ show i ++ " out of range [" ++
- show range_min ++ " .. " ++ show range_max ++ "]\n")
-
- | otherwise = ppInteger i
-
- where
- range_min = if signed then minInt else 0
- range_max = maxInt
- out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
-
- ppr sty (MachFloat f)
- | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f]
- | otherwise = ppBesides [ppPStr SLIT("_float_"), ppRational f]
-
- ppr sty (MachDouble d) = ppRational d
-
- ppr sty (MachAddr p)
- | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p]
- | otherwise = ppBesides [ppPStr SLIT("_addr_"), ppInteger p]
-
- ppr sty lit@(NoRepInteger i _)
- | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
- | otherwise = ppCat [ppPStr SLIT("_integer_"), ppInteger i]
-
- ppr sty lit@(NoRepRational r _)
- | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
- | otherwise = ppCat [ppPStr SLIT("_rational_"), ppInteger (numerator r), ppInteger (denominator r)]
-
- ppr sty (MachLitLit s k)
- | codeStyle sty = ppPStr s
- | otherwise = ppBesides [ppPStr SLIT("_litlit_ "), ppPrimRep k, ppStr " \"", ppPStr s, ppChar '"']
-
-showLiteral :: PprStyle -> Literal -> String
-showLiteral sty lit = ppShow 80 (ppr sty lit)
+ ppr lit = pprLit lit
+
+pprLit lit
+ = getPprStyle $ \ sty ->
+ let
+ code_style = codeStyle sty
+ in
+ case lit of
+ MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), char '\'', text (charToC ch), char '\'']
+ | ifaceStyle sty -> char '\'' <> text (charToEasyHaskell ch) <> char '\''
+ | otherwise -> text ['\'', ch, '\'']
+
+ MachStr s | code_style -> doubleQuotes (text (stringToC (_UNPK_ s)))
+ | otherwise -> text (show (_UNPK_ s))
+
+ NoRepStr s | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> ptext SLIT("_string_") <+> text (show (_UNPK_ s))
+
+ MachInt i _ -> integer i
+{-
+ | code_style && out_of_range
+ -> pprPanic "" (hsep [text "ERROR: Int ", text (show i), text "out of range",
+ brackets (ppr range_min <+> text ".." <+> ppr range_max)])
+ | otherwise -> integer i
+
+ where
+ range_min = if signed then minInt else 0
+ range_max = maxInt
+ out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
+-}
+
+ MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f
+ | otherwise -> ptext SLIT("_float_") <+> rational f
+
+ MachDouble d -> rational d
+
+ MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p
+ | otherwise -> ptext SLIT("_addr_") <+> integer p
+
+ NoRepInteger i _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> ptext SLIT("_integer_") <+> integer i
+
+ NoRepRational r _ | code_style -> pprPanic "NoRep in code style" (ppr lit)
+ | otherwise -> hsep [ptext SLIT("_rational_"), integer (numerator r),
+ integer (denominator r)]
+
+ MachLitLit s k | code_style -> ptext s
+ | otherwise -> hsep [ptext SLIT("_litlit_"), ppPrimRep k, text (show (_UNPK_ s))]
+
+showLiteral :: Literal -> String
+showLiteral lit = showSDoc (ppr lit)
\end{code}
projects / ghc-hetmet.git / blobdiff