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, isDataConId_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)
80 type UfAlt name = (UfConAlt name, [name], UfExpr name)
82 data UfConAlt name = UfDefault
86 | UfLitLitAlt FastString (HsType name)
89 = UfNonRec (UfBinder name)
91 | UfRec [(UfBinder name, UfExpr name)]
94 = UfValBinder name (HsType name)
95 | UfTyBinder name Kind
97 ufBinderName :: UfBinder name -> name
98 ufBinderName (UfValBinder n _) = n
99 ufBinderName (UfTyBinder n _) = n
103 %************************************************************************
105 \subsection{Converting from Core to UfCore}
107 %************************************************************************
110 toUfExpr :: CoreExpr -> UfExpr Name
111 toUfExpr (Var v) = toUfVar v
112 toUfExpr (Lit l) = case maybeLitLit l of
113 Just (s,ty) -> UfLitLit s (toHsType ty)
115 toUfExpr (Type ty) = UfType (toHsType ty)
116 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
117 toUfExpr (App f a) = toUfApp f [a]
118 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
119 toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
120 toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
122 ---------------------
123 toUfNote (SCC cc) = UfSCC cc
124 toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
125 toUfNote InlineCall = UfInlineCall
126 toUfNote InlineMe = UfInlineMe
128 ---------------------
129 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
130 toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
132 ---------------------
133 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
135 ---------------------
136 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
137 | otherwise = UfDataAlt (getName dc)
141 toUfCon (LitAlt l) = case maybeLitLit l of
142 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
143 Nothing -> UfLitAlt l
144 toUfCon DEFAULT = UfDefault
146 ---------------------
147 mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
149 ---------------------
150 toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
151 | otherwise = UfTyBinder (getName x) (varType x)
153 ---------------------
154 toUfApp (App f a) as = toUfApp f (a:as)
156 = case isDataConId_maybe v of
157 -- We convert the *worker* for tuples into UfTuples
158 Just dc | isTupleTyCon tc && saturated
159 -> UfTuple (mk_hs_tup_con tc dc) tup_args
161 val_args = dropWhile isTypeArg as
162 saturated = val_args `lengthIs` idArity v
163 tup_args = map toUfExpr val_args
167 other -> mkUfApps (toUfVar v) as
169 toUfApp e as = mkUfApps (toUfExpr e) as
171 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
173 ---------------------
174 toUfVar v = case isFCallId_maybe v of
175 -- Foreign calls have special syntax
176 Just fcall -> UfFCall fcall (toHsType (idType v))
177 other -> UfVar (getName v)
181 %************************************************************************
183 \subsection[HsCore-print]{Printing Core unfoldings}
185 %************************************************************************
188 instance OutputableBndr name => Outputable (UfExpr name) where
189 ppr e = pprUfExpr noParens e
192 -- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
193 -- Important because we want to pretty-print UfExprs, and we have to
194 -- print an '@' before tyvar-binders in a case alternative.
195 instance NamedThing RdrName where
196 getOccName n = rdrNameOcc n
197 getName n = pprPanic "instance NamedThing RdrName" (ppr n)
199 noParens :: SDoc -> SDoc
202 pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
203 -- The function adds parens in context that need
204 -- an atomic value (e.g. function args)
206 pprUfExpr add_par (UfVar v) = ppr v
207 pprUfExpr add_par (UfLit l) = ppr l
208 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
209 pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
210 pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
212 pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
213 <+> ptext SLIT("->") <+> pprUfExpr noParens body)
214 where (bndrs,body) = collectUfBndrs e
215 pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
216 pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
218 pprUfExpr add_par (UfCase scrut bndr alts)
219 = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
220 braces (hsep (map pp_alt alts))])
222 pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
223 pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
225 ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
227 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
228 = add_par (hsep [ptext SLIT("let"),
229 braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs),
230 ptext SLIT("in"), pprUfExpr noParens body])
232 pprUfExpr add_par (UfLet (UfRec pairs) body)
233 = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
234 ptext SLIT("in"), pprUfExpr noParens body])
236 pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
238 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
240 pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
241 pprUfApp fun = pprUfExpr parens fun
243 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
247 go bs (UfLam b e) = go (b:bs) e
248 go bs e = (reverse bs, e)
250 instance Outputable name => Outputable (UfNote name) where
251 ppr (UfSCC cc) = pprCostCentreCore cc
252 ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
253 ppr UfInlineCall = ptext SLIT("__inline_call")
254 ppr UfInlineMe = ptext SLIT("__inline_me")
256 instance Outputable name => Outputable (UfConAlt name) where
257 ppr UfDefault = text "__DEFAULT"
258 ppr (UfLitAlt l) = ppr l
259 ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
260 ppr (UfDataAlt d) = ppr d
262 instance Outputable name => Outputable (UfBinder name) where
263 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
264 ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
266 instance OutputableBndr name => OutputableBndr (UfBinder name) where
267 pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
268 pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
272 %************************************************************************
274 \subsection[HsCore-print]{Equality, for interface file checking
276 %************************************************************************
278 ----------------------------------------
280 ----------------------------------------
282 Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
283 those. Reason: this is used when comparing ufoldings in interface files, and the
284 uniques can differ. Converting to RdrNames makes it more like comparing the file
285 contents directly. But this is bad: version numbers can change when only alpha-conversion
288 The hack shows up in eq_ufVar
289 There are corresponding getOccName calls in MkIface.diffDecls
291 ----------------------------------------
293 ----------------------------------------
297 instance (NamedThing name, Ord name) => Eq (UfExpr name) where
298 (==) a b = eq_ufExpr emptyEqHsEnv a b
301 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
302 = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
303 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
304 = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2)
305 eq_ufBinder _ _ _ _ = False
308 eq_ufBinders env [] [] k = k env
309 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
310 eq_ufBinders env _ _ _ = False
313 eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
314 -- Compare *Rdr* names. A real hack to avoid gratuitous
315 -- differences when comparing interface files
316 eq_ufVar env n1 n2 = case lookupFM env n1 of
320 check n1 = eqNameByOcc (getName n1) (getName n2)
323 eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
324 eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
325 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
326 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
327 eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
328 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
329 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
330 eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
331 eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
333 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
334 = eq_ufExpr env s1 s2 &&
335 eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
337 eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
338 = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
340 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
341 = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
343 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
344 = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
346 (bs1,rs1) = unzip as1
347 (bs2,rs2) = unzip as2
349 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
350 = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
352 eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
353 eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
354 eq_ufNote UfInlineCall UfInlineCall = True
355 eq_ufNote UfInlineMe UfInlineMe = True
356 eq_ufNote _ _ = False
358 eq_ufExpr env _ _ = False
361 eq_ufConAlt env UfDefault UfDefault = True
362 eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
363 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
364 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
365 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
366 eq_ufConAlt env _ _ = False
370 %************************************************************************
372 \subsection{Rules in interface files}
374 %************************************************************************
377 pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
378 pprHsIdInfo [] = empty
379 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
383 | HsStrictness StrictSig
384 | HsUnfold InlinePragInfo (UfExpr name)
386 | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
387 -- for why we want arity here.
389 -- NB: Specialisations and rules come in separately and are
390 -- only later attached to the Id. Partial reason: some are orphans.
392 ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf)
393 ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity
394 ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str
395 ppr_hs_info HsNoCafRefs = ptext SLIT("__C")
396 ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a