2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 %************************************************************************
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
8 %************************************************************************
10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11 @TyVars@ as well. Currently trying the former... MEGA SIGH.
15 UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
16 UfBinding(..), UfConAlt(..),
17 HsIdInfo(..), pprHsIdInfo,
19 eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
21 toUfExpr, toUfBndr, ufBinderName
24 #include "HsVersions.h"
27 import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
28 HsTupCon(..), EqHsEnv, hsTupParens,
29 emptyEqHsEnv, extendEqHsEnv, eqListBy,
34 import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
35 import Var ( varType, isId )
36 import IdInfo ( ArityInfo, InlinePragInfo,
37 pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
39 import Name ( Name, NamedThing(..), getName, toRdrName )
40 import RdrName ( RdrName, rdrNameOcc )
41 import OccName ( isTvOcc )
43 import CostCentre ( pprCostCentreCore )
44 import PrimOp ( PrimOp(CCallOp) )
45 import Demand ( StrictnessInfo )
46 import Literal ( Literal, maybeLitLit )
47 import PrimOp ( CCall, pprCCallOp )
48 import DataCon ( dataConTyCon )
49 import TyCon ( isTupleTyCon, tupleTyConBoxity )
51 import FiniteMap ( lookupFM )
56 %************************************************************************
58 \subsection[HsCore-types]{Types for read/written Core unfoldings}
60 %************************************************************************
65 | UfType (HsType name)
66 | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted
67 | UfLam (UfBinder name) (UfExpr name)
68 | UfApp (UfExpr name) (UfExpr name)
69 | UfCase (UfExpr name) name [UfAlt name]
70 | UfLet (UfBinding name) (UfExpr name)
71 | UfNote (UfNote name) (UfExpr name)
73 | UfLitLit FAST_STRING (HsType name)
74 | UfCCall CCall (HsType name)
76 data UfNote name = UfSCC CostCentre
77 | UfCoerce (HsType name)
81 type UfAlt name = (UfConAlt name, [name], UfExpr name)
83 data UfConAlt name = UfDefault
85 | UfTupleAlt (HsTupCon name)
87 | UfLitLitAlt FAST_STRING (HsType name)
90 = UfNonRec (UfBinder name)
92 | UfRec [(UfBinder name, UfExpr name)]
95 = UfValBinder name (HsType name)
96 | UfTyBinder name Kind
98 ufBinderName :: UfBinder name -> name
99 ufBinderName (UfValBinder n _) = n
100 ufBinderName (UfTyBinder n _) = n
104 %************************************************************************
106 \subsection{Converting from Core to UfCore}
108 %************************************************************************
111 toUfExpr :: CoreExpr -> UfExpr Name
112 toUfExpr (Var v) = toUfVar v
113 toUfExpr (Lit l) = case maybeLitLit l of
114 Just (s,ty) -> UfLitLit s (toHsType ty)
116 toUfExpr (Type ty) = UfType (toHsType ty)
117 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
118 toUfExpr (App f a) = toUfApp f [a]
119 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
120 toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
121 toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
123 ---------------------
124 toUfNote (SCC cc) = UfSCC cc
125 toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
126 toUfNote InlineCall = UfInlineCall
127 toUfNote InlineMe = UfInlineMe
129 ---------------------
130 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
131 toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
133 ---------------------
134 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
136 ---------------------
137 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
138 | otherwise = UfDataAlt (getName dc)
142 toUfCon (LitAlt l) = case maybeLitLit l of
143 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
144 Nothing -> UfLitAlt l
145 toUfCon DEFAULT = UfDefault
147 ---------------------
148 toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
149 | otherwise = UfTyBinder (getName x) (varType x)
151 ---------------------
152 toUfApp (App f a) as = toUfApp f (a:as)
154 = case isDataConId_maybe v of
155 -- We convert the *worker* for tuples into UfTuples
156 Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
158 val_args = dropWhile isTypeArg as
159 saturated = length val_args == idArity v
160 tup_args = map toUfExpr val_args
164 other -> mkUfApps (toUfVar v) as
166 toUfApp e as = mkUfApps (toUfExpr e) as
168 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
170 ---------------------
171 toUfVar v = case isPrimOpId_maybe v of
172 -- Ccalls has special syntax
173 Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
174 other -> UfVar (getName v)
178 %************************************************************************
180 \subsection[HsCore-print]{Printing Core unfoldings}
182 %************************************************************************
185 instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where
186 ppr e = pprUfExpr noParens e
189 -- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
190 -- Important because we want to pretty-print UfExprs, and we have to
191 -- print an '@' before tyvar-binders in a case alternative.
192 instance NamedThing RdrName where
193 getOccName n = rdrNameOcc n
194 getName n = pprPanic "instance NamedThing RdrName" (ppr n)
196 noParens :: SDoc -> SDoc
199 pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc
200 -- The function adds parens in context that need
201 -- an atomic value (e.g. function args)
203 pprUfExpr add_par (UfVar v) = ppr v
204 pprUfExpr add_par (UfLit l) = ppr l
205 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
206 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
207 pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
209 pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
210 <+> ptext SLIT("->") <+> pprUfExpr noParens body)
211 where (bndrs,body) = collectUfBndrs e
212 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
213 pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
215 pprUfExpr add_par (UfCase scrut bndr alts)
216 = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
217 braces (hsep (map pp_alt alts))])
219 pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
220 pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs
222 ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
224 -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type
225 pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v
228 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
229 = add_par (hsep [ptext SLIT("let"),
230 braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
231 ptext SLIT("in"), pprUfExpr noParens body])
233 pprUfExpr add_par (UfLet (UfRec pairs) body)
234 = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
235 ptext SLIT("in"), pprUfExpr noParens body])
237 pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
239 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
242 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
246 go bs (UfLam b e) = go (b:bs) e
247 go bs e = (reverse bs, e)
249 instance Outputable name => Outputable (UfNote name) where
250 ppr (UfSCC cc) = pprCostCentreCore cc
251 ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
252 ppr UfInlineCall = ptext SLIT("__inline_call")
253 ppr UfInlineMe = ptext SLIT("__inline_me")
255 instance Outputable name => Outputable (UfConAlt name) where
256 ppr UfDefault = text "__DEFAULT"
257 ppr (UfLitAlt l) = ppr l
258 ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
259 ppr (UfDataAlt d) = ppr d
261 instance Outputable name => Outputable (UfBinder name) where
262 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
263 ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
267 %************************************************************************
269 \subsection[HsCore-print]{Equality, for interface file checking
271 %************************************************************************
273 ----------------------------------------
275 ----------------------------------------
277 Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
278 those. Reason: this is used when comparing ufoldings in interface files, and the
279 uniques can differ. Converting to RdrNames makes it more like comparing the file
280 contents directly. But this is bad: version numbers can change when only alpha-conversion
283 The hack shows up in eq_ufVar
284 There are corresponding getOccName calls in MkIface.diffDecls
286 ----------------------------------------
288 ----------------------------------------
292 instance (NamedThing name, Ord name) => Eq (UfExpr name) where
293 (==) a b = eq_ufExpr emptyEqHsEnv a b
296 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
297 = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
298 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
299 = k1==k2 && k (extendEqHsEnv env n1 n2)
300 eq_ufBinder _ _ _ _ = False
303 eq_ufBinders env [] [] k = k env
304 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
305 eq_ufBinders env _ _ _ = False
308 eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
309 -- Compare *Rdr* names. A real hack to avoid gratuitous
310 -- differences when comparing interface files
311 eq_ufVar env n1 n2 = case lookupFM env n1 of
312 Just n1 -> toRdrName n1 == toRdrName n2
313 Nothing -> toRdrName n1 == toRdrName n2
317 eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
318 eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
319 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
320 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
321 eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
322 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
323 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
324 eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
325 eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
327 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
328 = eq_ufExpr env s1 s2 &&
329 eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
331 eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
332 = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
334 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
335 = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
337 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
338 = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
340 (bs1,rs1) = unzip as1
341 (bs2,rs2) = unzip as2
343 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
344 = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
346 eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
347 eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
348 eq_ufNote UfInlineCall UfInlineCall = True
349 eq_ufNote UfInlineMe UfInlineMe = True
350 eq_ufNote _ _ = False
352 eq_ufExpr env _ _ = False
355 eq_ufConAlt env UfDefault UfDefault = True
356 eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
357 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
358 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
359 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
360 eq_ufConAlt env _ _ = False
364 %************************************************************************
366 \subsection{Rules in interface files}
368 %************************************************************************
371 pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc
372 pprHsIdInfo [] = empty
373 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
377 | HsStrictness StrictnessInfo
378 | HsUnfold InlinePragInfo (UfExpr name)
381 | HsWorker name -- Worker, if any
383 -- NB: Specialisations and rules come in separately and are
384 -- only later attached to the Id. Partial reason: some are orphans.
386 ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf)
387 ppr_hs_info (HsArity arity) = ppArityInfo arity
388 ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
389 ppr_hs_info HsNoCafRefs = ptext SLIT("__C")
390 ppr_hs_info HsCprInfo = ptext SLIT("__M")
391 ppr_hs_info (HsWorker w) = ptext SLIT("__P") <+> ppr w