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(..),
20 eq_ufExpr, eq_ufBinders, pprUfExpr,
25 #include "HsVersions.h"
28 import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
29 HsTupCon(..), hsTupParens,
30 emptyEqHsEnv, extendEqHsEnv, eqListBy,
31 eq_hsType, eq_hsVar, eq_hsVars
35 import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
36 import Var ( varType, isId )
37 import IdInfo ( ArityInfo, InlinePragInfo,
38 pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
40 import RdrName ( RdrName )
41 import Name ( toRdrName )
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 )
52 import SrcLoc ( SrcLoc )
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
100 %************************************************************************
102 \subsection{Converting from Core to UfCore}
104 %************************************************************************
107 toUfExpr :: CoreExpr -> UfExpr RdrName
108 toUfExpr (Var v) = toUfVar v
109 toUfExpr (Lit l) = case maybeLitLit l of
110 Just (s,ty) -> UfLitLit s (toHsType ty)
112 toUfExpr (Type ty) = UfType (toHsType ty)
113 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
114 toUfExpr (App f a) = toUfApp f [a]
115 toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
116 toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e)
117 toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e)
119 ---------------------
120 toUfNote (SCC cc) = UfSCC cc
121 toUfNote (Coerce t1 _) = UfCoerce (toHsType t1)
122 toUfNote InlineCall = UfInlineCall
123 toUfNote InlineMe = UfInlineMe
125 ---------------------
126 toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
127 toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
129 ---------------------
130 toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
132 ---------------------
133 toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
134 | otherwise = UfDataAlt (toRdrName dc)
138 toUfCon (LitAlt l) = case maybeLitLit l of
139 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
140 Nothing -> UfLitAlt l
141 toUfCon DEFAULT = UfDefault
143 ---------------------
144 toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x))
145 | otherwise = UfTyBinder (toRdrName x) (varType x)
147 ---------------------
148 toUfApp (App f a) as = toUfApp f (a:as)
150 = case isDataConId_maybe v of
151 -- We convert the *worker* for tuples into UfTuples
152 Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
154 val_args = dropWhile isTypeArg as
155 saturated = length val_args == idArity v
156 tup_args = map toUfExpr val_args
160 other -> mkUfApps (toUfVar v) as
162 toUfApp e as = mkUfApps (toUfExpr e) as
164 mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
166 ---------------------
167 toUfVar v = case isPrimOpId_maybe v of
168 -- Ccalls has special syntax
169 Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
170 other -> UfVar (toRdrName v)
174 %************************************************************************
176 \subsection[HsCore-print]{Printing Core unfoldings}
178 %************************************************************************
181 instance Outputable name => Outputable (UfExpr name) where
182 ppr e = pprUfExpr noParens e
184 noParens :: SDoc -> SDoc
187 pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
188 -- The function adds parens in context that need
189 -- an atomic value (e.g. function args)
191 pprUfExpr add_par (UfVar v) = ppr v
192 pprUfExpr add_par (UfLit l) = ppr l
193 pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
194 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
195 pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
197 pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs)
198 <+> ptext SLIT("->") <+> pprUfExpr noParens body)
199 where (bndrs,body) = collectUfBndrs e
200 pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg)
201 pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as)
203 pprUfExpr add_par (UfCase scrut bndr alts)
204 = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
205 braces (hsep (map pp_alt alts))])
207 pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
208 pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs
210 ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
212 pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
213 = add_par (hsep [ptext SLIT("let"),
214 braces (ppr b <+> equals <+> pprUfExpr noParens rhs),
215 ptext SLIT("in"), pprUfExpr noParens body])
217 pprUfExpr add_par (UfLet (UfRec pairs) body)
218 = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)),
219 ptext SLIT("in"), pprUfExpr noParens body])
221 pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
223 pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
225 collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
229 go bs (UfLam b e) = go (b:bs) e
230 go bs e = (reverse bs, e)
232 instance Outputable name => Outputable (UfNote name) where
233 ppr (UfSCC cc) = pprCostCentreCore cc
234 ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
235 ppr UfInlineCall = ptext SLIT("__inline_call")
236 ppr UfInlineMe = ptext SLIT("__inline_me")
238 instance Outputable name => Outputable (UfConAlt name) where
239 ppr UfDefault = text "__DEFAULT"
240 ppr (UfLitAlt l) = ppr l
241 ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
242 ppr (UfDataAlt d) = ppr d
244 instance Outputable name => Outputable (UfBinder name) where
245 ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty]
246 ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
250 %************************************************************************
252 \subsection[HsCore-print]{Equality, for interface file checking
254 %************************************************************************
257 instance Ord name => Eq (UfExpr name) where
258 (==) a b = eq_ufExpr emptyEqHsEnv a b
261 eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
262 = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
263 eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
264 = k1==k2 && k (extendEqHsEnv env n1 n2)
265 eq_ufBinder _ _ _ _ = False
268 eq_ufBinders env [] [] k = k env
269 eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
270 eq_ufBinders env _ _ _ = False
273 eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2
274 eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
275 eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
276 eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
277 eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
278 eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
279 eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
280 eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2
282 eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
283 = eq_ufExpr env s1 s2 &&
284 eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
286 eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
287 = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)
289 eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
290 = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)
292 eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
293 = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
295 (bs1,rs1) = unzip as1
296 (bs2,rs2) = unzip as2
298 eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
299 = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
301 eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2
302 eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
303 eq_ufNote UfInlineCall UfInlineCall = True
304 eq_ufNote UfInlineMe UfInlineMe = True
305 eq_ufNote _ _ = False
307 eq_ufExpr env _ _ = False
310 eq_ufConAlt env UfDefault UfDefault = True
311 eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
312 eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
313 eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
314 eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
315 eq_ufConAlt env _ _ = False
319 %************************************************************************
321 \subsection{Signatures in interface files}
323 %************************************************************************
326 data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc
328 instance Ord name => Eq (IfaceSig name) where
329 (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
331 instance (Outputable name) => Outputable (IfaceSig name) where
332 ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
336 %************************************************************************
338 \subsection{Rules in interface files}
340 %************************************************************************
343 pprHsIdInfo [] = empty
344 pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}")
348 | HsStrictness StrictnessInfo
349 | HsUnfold InlinePragInfo (UfExpr name)
352 | HsWorker name -- Worker, if any
354 -- NB: Specialisations and rules come in separately and are
355 -- only later attached to the Id. Partial reason: some are orphans.
357 instance Outputable name => Outputable (HsIdInfo name) where
358 ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf)
359 ppr (HsArity arity) = ppArityInfo arity
360 ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
361 ppr HsNoCafRefs = ptext SLIT("__C")
362 ppr HsCprInfo = ptext SLIT("__M")
363 ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w