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
21 import PrimRep ( PrimRep(..) ) -- non-abstract
22 import TysPrim ( getPrimRepInfo,
23 addrPrimTy, intPrimTy, floatPrimTy,
24 doublePrimTy, charPrimTy, wordPrimTy )
27 import CStrings ( stringToC, charToC, charToEasyHaskell )
28 import TysWiredIn ( stringTy )
29 import Pretty -- pretty-printing stuff
30 import PprStyle ( PprStyle(..), codeStyle )
31 import Util ( thenCmp, panic )
34 So-called @Literals@ are {\em either}:
37 An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.),
38 which is presumed to be surrounded by appropriate constructors
39 (@mKINT@, etc.), so that the overall thing makes sense.
41 An Integer, Rational, or String literal whose representation we are
42 {\em uncommitted} about; i.e., the surrounding with constructors,
43 function applications, etc., etc., has not yet been done.
50 | MachAddr Integer -- whatever this machine thinks is a "pointer"
51 | MachInt Integer -- for the numeric types, these are
52 Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
55 | MachLitLit FAST_STRING
58 | NoRepStr FAST_STRING -- the uncommitted ones
59 | NoRepInteger Integer Type{-save what we learned in the typechecker-}
60 | NoRepRational Rational Type{-ditto-}
62 -- deriving (Eq, Ord): no, don't want to compare Types
63 -- The Ord is needed for the FiniteMap used in the lookForConstructor
64 -- in SimplEnv. If you declared that lookForConstructor *ignores*
65 -- constructor-applications with LitArg args, then you could get
68 mkMachInt, mkMachWord :: Integer -> Literal
70 mkMachInt x = MachInt x True{-signed-}
71 mkMachWord x = MachInt x False{-unsigned-}
73 instance Ord3 Literal where
74 cmp (MachChar a) (MachChar b) = a `tcmp` b
75 cmp (MachStr a) (MachStr b) = a `tcmp` b
76 cmp (MachAddr a) (MachAddr b) = a `tcmp` b
77 cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
78 cmp (MachFloat a) (MachFloat b) = a `tcmp` b
79 cmp (MachDouble a) (MachDouble b) = a `tcmp` b
80 cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d)
81 cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b
82 cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b
83 cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b
85 -- now we *know* the tags are different, so...
87 | tag1 _LT_ tag2 = LT_
93 tagof (MachChar _) = ILIT(1)
94 tagof (MachStr _) = ILIT(2)
95 tagof (MachAddr _) = ILIT(3)
96 tagof (MachInt _ _) = ILIT(4)
97 tagof (MachFloat _) = ILIT(5)
98 tagof (MachDouble _) = ILIT(6)
99 tagof (MachLitLit _ _) = ILIT(7)
100 tagof (NoRepStr _) = ILIT(8)
101 tagof (NoRepInteger _ _) = ILIT(9)
102 tagof (NoRepRational _ _) = ILIT(10)
104 tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
106 instance Eq Literal where
107 a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
108 a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
110 instance Ord Literal where
111 a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
112 a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
113 a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
114 a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
115 _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
119 isNoRepLit (NoRepStr _) = True -- these are not primitive typed!
120 isNoRepLit (NoRepInteger _ _) = True
121 isNoRepLit (NoRepRational _ _) = True
124 isLitLitLit (MachLitLit _ _) = True
125 isLitLitLit _ = False
129 literalType :: Literal -> Type
131 literalType (MachChar _) = charPrimTy
132 literalType (MachStr _) = addrPrimTy
133 literalType (MachAddr _) = addrPrimTy
134 literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy
135 literalType (MachFloat _) = floatPrimTy
136 literalType (MachDouble _) = doublePrimTy
137 literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t }
138 literalType (NoRepInteger _ t) = t
139 literalType (NoRepRational _ t) = t
140 literalType (NoRepStr _) = stringTy
144 literalPrimRep :: Literal -> PrimRep
146 literalPrimRep (MachChar _) = CharRep
147 literalPrimRep (MachStr _) = AddrRep -- specifically: "char *"
148 literalPrimRep (MachAddr _) = AddrRep
149 literalPrimRep (MachInt _ signed) = if signed then IntRep else WordRep
150 literalPrimRep (MachFloat _) = FloatRep
151 literalPrimRep (MachDouble _) = DoubleRep
152 literalPrimRep (MachLitLit _ k) = k
154 literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger"
155 literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational"
156 literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString"
160 The boring old output stuff:
162 ppCast :: PprStyle -> FAST_STRING -> Pretty
163 ppCast PprForC cast = ppPStr cast
166 instance Outputable Literal where
167 ppr sty (MachChar ch)
171 PprForC -> charToC ch
172 PprForAsm _ _ -> charToC ch
173 PprUnfolding -> charToEasyHaskell ch
176 ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
180 = ppBeside (if codeStyle sty
181 then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
182 else ppStr (show (_UNPK_ s)))
185 ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty]
186 ppr sty (MachInt i signed)
188 && ((signed && (i >= toInteger minInt && i <= toInteger maxInt))
189 || (not signed && (i >= toInteger 0 && i <= toInteger maxInt)))
190 -- ToDo: Think about these ranges!
191 = ppBesides [ppInteger i, if_ubxd sty]
193 | not (codeStyle sty) -- we'd prefer the code to the error message
194 = ppBesides [ppInteger i, if_ubxd sty]
197 = error ("ERROR: Int " ++ show i ++ " out of range [" ++
198 show range_min ++ " .. " ++ show maxInt ++ "]\n")
200 range_min = if signed then minInt else 0
202 ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
203 ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
205 ppr sty (NoRepInteger i _)
206 | codeStyle sty = ppInteger i
207 | ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
208 | otherwise = ppBesides [ppInteger i, ppChar 'I']
210 ppr sty (NoRepRational r _)
211 | ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
212 | codeStyle sty = panic "ppr.ForC.NoRepRational"
213 | otherwise = ppBesides [ppRational r, ppChar 'R']
216 | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))]
217 | ufStyle sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))]
218 | otherwise = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S']
220 ppr sty (MachLitLit s k)
221 | codeStyle sty = ppPStr s
222 | ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
223 | otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
225 ufStyle PprUnfolding = True
228 if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
230 showLiteral :: PprStyle -> Literal -> String
232 showLiteral sty lit = ppShow 80 (ppr sty lit)