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,
21 toUfExpr, toUfBndr, ufBinderName
24 #include "HsVersions.h"
27 import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
28 HsTupCon(..), EqHsEnv, hsTupParens,
29 emptyEqHsEnv, extendEqHsEnv,
34 import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
35 import Var ( varType, isId )
36 import IdInfo ( InlinePragInfo )
37 import Name ( Name, NamedThing(..), eqNameByOcc )
38 import RdrName ( RdrName, rdrNameOcc )
40 import CostCentre ( pprCostCentreCore )
41 import NewDemand ( StrictSig, pprIfaceStrictSig )
42 import Literal ( Literal, maybeLitLit )
43 import ForeignCall ( ForeignCall )
44 import DataCon ( dataConTyCon, dataConSourceArity )
45 import TyCon ( isTupleTyCon, tupleTyConBoxity )
46 import Type ( Kind, eqKind )
47 import BasicTypes ( Arity )
48 import FiniteMap ( lookupFM )
50 import Util ( eqListBy, lengthIs )
55 %************************************************************************
57 \subsection[HsCore-types]{Types for read/written Core unfoldings}
59 %************************************************************************
64 | UfType (HsType name)
65 | UfTuple HsTupCon [UfExpr name] -- Type arguments omitted
66 | UfLam (UfBinder name) (UfExpr name)
67 | UfApp (UfExpr name) (UfExpr name)
68 | UfCase (UfExpr name) name [UfAlt name]
69 | UfLet (UfBinding name) (UfExpr name)
70 | UfNote (UfNote name) (UfExpr name)
72 | UfLitLit FastString (HsType name)
73 | UfFCall ForeignCall (HsType name)
75 data UfNote name = UfSCC CostCentre
76 | UfCoerce (HsType name)
81 type UfAlt name = (UfConAlt name, [name], UfExpr name)
83 data UfConAlt name = UfDefault
87 | UfLitLitAlt FastString (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
128 toUfNote (CoreNote s) = UfCoreNote s
130 ---------------------
131 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
132 toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
134 ---------------------
135 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
137 ---------------------
138 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
139 | otherwise = UfDataAlt (getName dc)
143 toUfCon (LitAlt l) = case maybeLitLit l of
144 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
145 Nothing -> UfLitAlt l
146 toUfCon DEFAULT = UfDefault
148 ---------------------
149 mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
151 ---------------------
152 toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
153 | otherwise = UfTyBinder (getName x) (varType x)
155 ---------------------
156 toUfApp (App f a) as = toUfApp f (a:as)
158 = case isDataConWorkId_maybe v of
159 -- We convert the *worker* for tuples into UfTuples
160 Just dc | isTupleTyCon tc && saturated
161 -> UfTuple (mk_hs_tup_con tc dc) tup_args
163 val_args = dropWhile isTypeArg as
164 saturated = val_args `lengthIs` idArity v
165 tup_args = map toUfExpr val_args
169 other -> mkUfApps (toUfVar v) as
171 toUfApp e as = mkUfApps (toUfExpr e) as
173 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
175 ---------------------
176 toUfVar v = case isFCallId_maybe v of
177 -- Foreign calls have special syntax
178 Just fcall -> UfFCall fcall (toHsType (idType v))
179 other -> UfVar (getName v)
183 %************************************************************************
185 \subsection[HsCore-print]{Printing Core unfoldings}
187 %************************************************************************
190 instance OutputableBndr name => Outputable (UfExpr name) where
191 ppr e = pprUfExpr noParens e
194 -- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
195 -- Important because we want to pretty-print UfExprs, and we have to
196 -- print an '@' before tyvar-binders in a case alternative.
197 instance NamedThing RdrName where
198 getOccName n = rdrNameOcc n
199 getName n = pprPanic "instance NamedThing RdrName" (ppr n)
201 noParens :: SDoc -> SDoc
204 pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
205 -- The function adds parens in context that need
206 -- an atomic value (e.g. function args)
208 pprUfExpr add_par (UfVar v) = ppr v
209 pprUfExpr add_par (UfLit l) = ppr l
210 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
211 pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
212 pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
214 pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
215 <+> ptext SLIT("->") <+> pprUfExpr noParens body)
216 where (bndrs,body) = collectUfBndrs e
217 pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
218 pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
220 pprUfExpr add_par (UfCase scrut bndr alts)
221 = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
222 braces (hsep (map pp_alt alts))])
224 pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
225 pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
227 ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
229 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
230 = add_par (hsep [ptext SLIT("let"),
231 braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
232 ptext SLIT("in"), pprUfExpr noParens body])
234 pprUfExpr add_par (UfLet (UfRec pairs) body)
235 = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
236 ptext SLIT("in"), pprUfExpr noParens body])
238 pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
240 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
242 pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
243 pprUfApp fun = pprUfExpr parens fun
245 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
249 go bs (UfLam b e) = go (b:bs) e
250 go bs e = (reverse bs, e)
252 instance Outputable name => Outputable (UfNote name) where
253 ppr (UfSCC cc) = pprCostCentreCore cc
254 ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
255 ppr UfInlineCall = ptext SLIT("__inline_call")
256 ppr UfInlineMe = ptext SLIT("__inline_me")
257 ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
259 instance Outputable name => Outputable (UfConAlt name) where
260 ppr UfDefault = text "__DEFAULT"
261 ppr (UfLitAlt l) = ppr l
262 ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
263 ppr (UfDataAlt d) = ppr d
265 instance Outputable name => Outputable (UfBinder name) where
266 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
267 ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
269 instance OutputableBndr name => OutputableBndr (UfBinder name) where
270 pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
271 pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
275 %************************************************************************
277 \subsection[HsCore-print]{Equality, for interface file checking
279 %************************************************************************
281 ----------------------------------------
283 ----------------------------------------
285 Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
286 those. Reason: this is used when comparing ufoldings in interface files, and the
287 uniques can differ. Converting to RdrNames makes it more like comparing the file
288 contents directly. But this is bad: version numbers can change when only alpha-conversion
291 The hack shows up in eq_ufVar
292 There are corresponding getOccName calls in MkIface.diffDecls
294 ----------------------------------------
296 ----------------------------------------
300 instance (NamedThing name, Ord name) => Eq (UfExpr name) where
301 (==) a b = eq_ufExpr emptyEqHsEnv a b
304 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
305 = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
306 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
307 = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2)
308 eq_ufBinder _ _ _ _ = False
311 eq_ufBinders env [] [] k = k env
312 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
313 eq_ufBinders env _ _ _ = False
316 eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
317 -- Compare *Rdr* names. A real hack to avoid gratuitous
318 -- differences when comparing interface files
319 eq_ufVar env n1 n2 = case lookupFM env n1 of
323 check n1 = eqNameByOcc (getName n1) (getName n2)
326 eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
327 eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
328 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
329 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
330 eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
331 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
332 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
333 eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
334 eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
336 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
337 = eq_ufExpr env s1 s2 &&
338 eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
340 eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
341 = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
343 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
344 = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
346 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
347 = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
349 (bs1,rs1) = unzip as1
350 (bs2,rs2) = unzip as2
352 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
353 = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
355 eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
356 eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
357 eq_ufNote UfInlineCall UfInlineCall = True
358 eq_ufNote UfInlineMe UfInlineMe = True
359 eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
360 eq_ufNote _ _ = False
362 eq_ufExpr env _ _ = False
365 eq_ufConAlt env UfDefault UfDefault = True
366 eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
367 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
368 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
369 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
370 eq_ufConAlt env _ _ = False
374 %************************************************************************
376 \subsection{Rules in interface files}
378 %************************************************************************
381 pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
382 pprHsIdInfo [] = empty
383 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
387 | HsStrictness StrictSig
388 | HsUnfold InlinePragInfo (UfExpr name)
390 | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
391 -- for why we want arity here.
393 -- NB: Specialisations and rules come in separately and are
394 -- only later attached to the Id. Partial reason: some are orphans.
396 ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf)
397 ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity
398 ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str
399 ppr_hs_info HsNoCafRefs = ptext SLIT("__C")
400 ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a