2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
7 #include "HsVersions.h"
12 mkMachInt, mkMachWord,
13 literalType, literalPrimRep,
15 isNoRepLit, isLitLitLit
22 import PrimRep ( PrimRep(..) ) -- non-abstract
23 import TysPrim ( getPrimRepInfo,
24 addrPrimTy, intPrimTy, floatPrimTy,
25 doublePrimTy, charPrimTy, wordPrimTy )
28 import CStrings ( stringToC, charToC, charToEasyHaskell )
29 import TysWiredIn ( stringTy )
30 import Pretty -- pretty-printing stuff
31 import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
32 import Util ( thenCmp, panic, pprPanic )
35 So-called @Literals@ are {\em either}:
38 An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
39 which is presumed to be surrounded by appropriate constructors
40 (@mKINT@, etc.), so that the overall thing makes sense.
42 An Integer, Rational, or String literal whose representation we are
43 {\em uncommitted} about; i.e., the surrounding with constructors,
44 function applications, etc., etc., has not yet been done.
52 | MachAddr Integer -- whatever this machine thinks is a "pointer"
54 | MachInt Integer -- for the numeric types, these are
55 Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
60 | MachLitLit FAST_STRING
63 | NoRepStr FAST_STRING
64 | NoRepInteger Integer Type -- This Type is always Integer
65 | NoRepRational Rational Type -- This Type is always Rational
66 -- We keep these Types in the literal because Rational isn't
67 -- (currently) wired in, so we can't conjure up its type out of
68 -- thin air. Integer is, so the type here is really redundant.
70 -- deriving (Eq, Ord): no, don't want to compare Types
71 -- The Ord is needed for the FiniteMap used in the lookForConstructor
72 -- in SimplEnv. If you declared that lookForConstructor *ignores*
73 -- constructor-applications with LitArg args, then you could get
76 mkMachInt, mkMachWord :: Integer -> Literal
78 mkMachInt x = MachInt x True{-signed-}
79 mkMachWord x = MachInt x False{-unsigned-}
81 instance Ord3 Literal where
82 cmp (MachChar a) (MachChar b) = a `tcmp` b
83 cmp (MachStr a) (MachStr b) = a `tcmp` b
84 cmp (MachAddr a) (MachAddr b) = a `tcmp` b
85 cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
86 cmp (MachFloat a) (MachFloat b) = a `tcmp` b
87 cmp (MachDouble a) (MachDouble b) = a `tcmp` b
88 cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
89 cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b
90 cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b
91 cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
93 -- now we *know* the tags are different, so...
95 | tag1 _LT_ tag2 = LT_
101 tagof (MachChar _) = ILIT(1)
102 tagof (MachStr _) = ILIT(2)
103 tagof (MachAddr _) = ILIT(3)
104 tagof (MachInt _ _) = ILIT(4)
105 tagof (MachFloat _) = ILIT(5)
106 tagof (MachDouble _) = ILIT(6)
107 tagof (MachLitLit _ _) = ILIT(7)
108 tagof (NoRepStr _) = ILIT(8)
109 tagof (NoRepInteger _ _) = ILIT(9)
110 tagof (NoRepRational _ _) = ILIT(10)
112 tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
114 instance Eq Literal where
115 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
116 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
118 instance Ord Literal where
119 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
120 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
121 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
122 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
123 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
127 isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
128 isNoRepLit (NoRepInteger _ _) = True
129 isNoRepLit (NoRepRational _ _) = True
132 isLitLitLit (MachLitLit _ _) = True
133 isLitLitLit _ = False
137 literalType :: Literal -> Type
139 literalType (MachChar _) = charPrimTy
140 literalType (MachStr _) = addrPrimTy
141 literalType (MachAddr _) = addrPrimTy
142 literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
143 literalType (MachFloat _) = floatPrimTy
144 literalType (MachDouble _) = doublePrimTy
145 literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
146 literalType (NoRepInteger _ t) = t
147 literalType (NoRepRational _ t) = t
148 literalType (NoRepStr _) = stringTy
152 literalPrimRep :: Literal -> PrimRep
154 literalPrimRep (MachChar _) = CharRep
155 literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
156 literalPrimRep (MachAddr _) = AddrRep
157 literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
158 literalPrimRep (MachFloat _) = FloatRep
159 literalPrimRep (MachDouble _) = DoubleRep
160 literalPrimRep (MachLitLit _ k) = k
162 literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
163 literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
164 literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
168 The boring old output stuff:
170 ppCast :: PprStyle -> FAST_STRING -> Pretty
171 ppCast PprForC cast = ppPStr cast
174 -- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
175 -- exceptions: MachFloat and MachAddr get an initial keyword prefix
177 -- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
179 instance Outputable Literal where
180 ppr sty (MachChar ch)
184 PprForC -> charToC ch
185 PprForAsm _ _ -> charToC ch
186 PprInterface -> charToEasyHaskell ch
189 ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']
192 | codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
193 | otherwise = ppStr (show (_UNPK_ s))
195 ppr sty lit@(NoRepStr s)
196 | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
197 | otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))]
199 ppr sty (MachInt i signed)
200 | codeStyle sty && out_of_range
201 = panic ("ERROR: Int " ++ show i ++ " out of range [" ++
202 show range_min ++ " .. " ++ show range_max ++ "]\n")
204 | otherwise = ppInteger i
207 range_min = if signed then minInt else 0
209 out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
211 ppr sty (MachFloat f)
212 | codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f]
213 | otherwise = ppBesides [ppStr "_float_", ppRational f]
215 ppr sty (MachDouble d) = ppRational d
218 | codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p]
219 | otherwise = ppBesides [ppStr "_addr_", ppInteger p]
221 ppr sty lit@(NoRepInteger i _)
222 | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
223 | otherwise = ppCat [ppStr "_integer_", ppInteger i]
225 ppr sty lit@(NoRepRational r _)
226 | codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
227 | otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)]
229 ppr sty (MachLitLit s k)
230 | codeStyle sty = ppPStr s
231 | otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))]
233 showLiteral :: PprStyle -> Literal -> String
234 showLiteral sty lit = ppShow 80 (ppr sty lit)