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(..), hsTupParens,
29 emptyEqHsEnv, extendEqHsEnv, eqListBy,
30 eq_hsType, eq_hsVar, eq_hsVars
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, getName )
41 import CostCentre ( pprCostCentreCore )
42 import PrimOp ( PrimOp(CCallOp) )
43 import Demand ( StrictnessInfo )
44 import Literal ( Literal, maybeLitLit )
45 import PrimOp ( CCall, pprCCallOp )
46 import DataCon ( dataConTyCon )
47 import TyCon ( isTupleTyCon, tupleTyConBoxity )
53 %************************************************************************
55 \subsection[HsCore-types]{Types for read/written Core unfoldings}
57 %************************************************************************
62 | UfType (HsType name)
63 | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted
64 | UfLam (UfBinder name) (UfExpr name)
65 | UfApp (UfExpr name) (UfExpr name)
66 | UfCase (UfExpr name) name [UfAlt name]
67 | UfLet (UfBinding name) (UfExpr name)
68 | UfNote (UfNote name) (UfExpr name)
70 | UfLitLit FAST_STRING (HsType name)
71 | UfCCall CCall (HsType name)
73 data UfNote name = UfSCC CostCentre
74 | UfCoerce (HsType name)
78 type UfAlt name = (UfConAlt name, [name], UfExpr name)
80 data UfConAlt name = UfDefault
82 | UfTupleAlt (HsTupCon name)
84 | UfLitLitAlt FAST_STRING (HsType name)
87 = UfNonRec (UfBinder name)
89 | UfRec [(UfBinder name, UfExpr name)]
92 = UfValBinder name (HsType name)
93 | UfTyBinder name Kind
95 ufBinderName :: UfBinder name -> name
96 ufBinderName (UfValBinder n _) = n
97 ufBinderName (UfTyBinder n _) = n
101 %************************************************************************
103 \subsection{Converting from Core to UfCore}
105 %************************************************************************
108 toUfExpr :: CoreExpr -> UfExpr Name
109 toUfExpr (Var v) = toUfVar v
110 toUfExpr (Lit l) = case maybeLitLit l of
111 Just (s,ty) -> UfLitLit s (toHsType ty)
113 toUfExpr (Type ty) = UfType (toHsType ty)
114 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
115 toUfExpr (App f a) = toUfApp f [a]
116 toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
117 toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
118 toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
120 ---------------------
121 toUfNote (SCC cc) = UfSCC cc
122 toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
123 toUfNote InlineCall = UfInlineCall
124 toUfNote InlineMe = UfInlineMe
126 ---------------------
127 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
128 toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
130 ---------------------
131 toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
133 ---------------------
134 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
135 | otherwise = UfDataAlt (getName dc)
139 toUfCon (LitAlt l) = case maybeLitLit l of
140 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
141 Nothing -> UfLitAlt l
142 toUfCon DEFAULT = UfDefault
144 ---------------------
145 toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x))
146 | otherwise = UfTyBinder (getName x) (varType x)
148 ---------------------
149 toUfApp (App f a) as = toUfApp f (a:as)
151 = case isDataConId_maybe v of
152 -- We convert the *worker* for tuples into UfTuples
153 Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
155 val_args = dropWhile isTypeArg as
156 saturated = length val_args == idArity v
157 tup_args = map toUfExpr val_args
161 other -> mkUfApps (toUfVar v) as
163 toUfApp e as = mkUfApps (toUfExpr e) as
165 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
167 ---------------------
168 toUfVar v = case isPrimOpId_maybe v of
169 -- Ccalls has special syntax
170 Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
171 other -> UfVar (getName v)
175 %************************************************************************
177 \subsection[HsCore-print]{Printing Core unfoldings}
179 %************************************************************************
182 instance Outputable name => Outputable (UfExpr name) where
183 ppr e = pprUfExpr noParens e
185 noParens :: SDoc -> SDoc
188 pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
189 -- The function adds parens in context that need
190 -- an atomic value (e.g. function args)
192 pprUfExpr add_par (UfVar v) = ppr v
193 pprUfExpr add_par (UfLit l) = ppr l
194 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
195 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
196 pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
198 pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
199 <+> ptext SLIT("->") <+> pprUfExpr noParens body)
200 where (bndrs,body) = collectUfBndrs e
201 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
202 pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
204 pprUfExpr add_par (UfCase scrut bndr alts)
205 = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
206 braces (hsep (map pp_alt alts))])
208 pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
209 pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs
211 ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
213 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
214 = add_par (hsep [ptext SLIT("let"),
215 braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
216 ptext SLIT("in"), pprUfExpr noParens body])
218 pprUfExpr add_par (UfLet (UfRec pairs) body)
219 = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
220 ptext SLIT("in"), pprUfExpr noParens body])
222 pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
224 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
226 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
230 go bs (UfLam b e) = go (b:bs) e
231 go bs e = (reverse bs, e)
233 instance Outputable name => Outputable (UfNote name) where
234 ppr (UfSCC cc) = pprCostCentreCore cc
235 ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
236 ppr UfInlineCall = ptext SLIT("__inline_call")
237 ppr UfInlineMe = ptext SLIT("__inline_me")
239 instance Outputable name => Outputable (UfConAlt name) where
240 ppr UfDefault = text "__DEFAULT"
241 ppr (UfLitAlt l) = ppr l
242 ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
243 ppr (UfDataAlt d) = ppr d
245 instance Outputable name => Outputable (UfBinder name) where
246 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
247 ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
251 %************************************************************************
253 \subsection[HsCore-print]{Equality, for interface file checking
255 %************************************************************************
258 instance Ord name => Eq (UfExpr name) where
259 (==) a b = eq_ufExpr emptyEqHsEnv a b
262 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
263 = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
264 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
265 = k1==k2 && k (extendEqHsEnv env n1 n2)
266 eq_ufBinder _ _ _ _ = False
269 eq_ufBinders env [] [] k = k env
270 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
271 eq_ufBinders env _ _ _ = False
274 eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2
275 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
276 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
277 eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
278 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
279 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
280 eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
281 eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
283 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
284 = eq_ufExpr env s1 s2 &&
285 eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
287 eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
288 = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
290 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
291 = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
293 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
294 = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
296 (bs1,rs1) = unzip as1
297 (bs2,rs2) = unzip as2
299 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
300 = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
302 eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
303 eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
304 eq_ufNote UfInlineCall UfInlineCall = True
305 eq_ufNote UfInlineMe UfInlineMe = True
306 eq_ufNote _ _ = False
308 eq_ufExpr env _ _ = False
311 eq_ufConAlt env UfDefault UfDefault = True
312 eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
313 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
314 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
315 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
316 eq_ufConAlt env _ _ = False
320 %************************************************************************
322 \subsection{Rules in interface files}
324 %************************************************************************
327 pprHsIdInfo [] = empty
328 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}")
332 | HsStrictness StrictnessInfo
333 | HsUnfold InlinePragInfo (UfExpr name)
336 | HsWorker name -- Worker, if any
338 -- NB: Specialisations and rules come in separately and are
339 -- only later attached to the Id. Partial reason: some are orphans.
341 instance Outputable name => Outputable (HsIdInfo name) where
342 ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf)
343 ppr (HsArity arity) = ppArityInfo arity
344 ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
345 ppr HsNoCafRefs = ptext SLIT("__C")
346 ppr HsCprInfo = ptext SLIT("__M")
347 ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w