X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FLiteral.lhs;h=ad7111848a0dbb1076827ee904146916a7049ee8;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=b561cc3c557bd54be8bb09ba1abf923de6536110;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index b561cc3..ad71118 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -4,32 +4,36 @@ \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}: @@ -54,6 +58,9 @@ data Literal | 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 @@ -78,49 +85,62 @@ mkMachInt, mkMachWord :: Integer -> Literal 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} @@ -155,6 +175,7 @@ literalPrimRep (MachChar _) = CharRep 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 @@ -167,70 +188,62 @@ literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString" 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}