[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / abstractSyn / HsCore.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
3 %
4 %************************************************************************
5 %*                                                                      *
6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
7 %*                                                                      *
8 %************************************************************************
9
10 We could either use this, or parameterise @CoreExpr@ on @UniTypes@ and
11 @TyVars@ as well.  Currently trying the former.
12
13 \begin{code}
14 #include "HsVersions.h"
15
16 module HsCore (
17         -- types:
18         UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
19         UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
20         UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
21         UnfoldingPrimOp(..), UfCostCentre(..),
22
23         -- function:
24         eqUfExpr
25     ) where
26
27 IMPORT_Trace
28
29 import AbsPrel          ( PrimOp, PrimKind )
30 import AbsSynFuns       ( cmpInstanceTypes )
31 import BasicLit         ( BasicLit )
32 import HsTypes          -- ( cmpPolyType, PolyType(..), MonoType )
33 import Maybes           ( Maybe(..) )
34 import Name             ( Name )
35 import Outputable       -- class for printing, forcing
36 import Pretty           -- pretty-printing utilities
37 import PrimOps          ( tagOf_PrimOp -- HACK
38                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
39                         )
40 import ProtoName        ( cmpProtoName, eqProtoName, ProtoName(..) ) -- .. for pragmas
41 import Util
42 \end{code}
43
44 %************************************************************************
45 %*                                                                      *
46 \subsection[HsCore-types]{Types for read/written Core unfoldings}
47 %*                                                                      *
48 %************************************************************************
49
50 \begin{code}
51 data UnfoldingCoreExpr name
52   = UfCoVar     (UfId name)
53   | UfCoLit     BasicLit
54   | UfCoCon     name -- must be a "BoringUfId"...
55                 [UnfoldingType name]
56                 [UnfoldingCoreAtom name]
57   | UfCoPrim    (UnfoldingPrimOp name)
58                 [UnfoldingType name]
59                 [UnfoldingCoreAtom name]
60   | UfCoLam     [UfBinder name]
61                 (UnfoldingCoreExpr name)
62   | UfCoTyLam   name
63                 (UnfoldingCoreExpr name)
64   | UfCoApp     (UnfoldingCoreExpr name)
65                 (UnfoldingCoreAtom name)
66   | UfCoTyApp   (UnfoldingCoreExpr name)
67                 (UnfoldingType name)
68   | UfCoCase    (UnfoldingCoreExpr name)
69                 (UnfoldingCoreAlts name)
70   | UfCoLet     (UnfoldingCoreBinding name)
71                 (UnfoldingCoreExpr name)
72   | UfCoSCC     (UfCostCentre name)
73                 (UnfoldingCoreExpr name)
74
75 type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName
76
77 data UnfoldingPrimOp name
78   = UfCCallOp   FAST_STRING          -- callee
79                 Bool                 -- True <=> casm, rather than ccall
80                 Bool                 -- True <=> might cause GC
81                 [UnfoldingType name] -- arg types, incl state token
82                                      -- (which will be first)
83                 (UnfoldingType name) -- return type
84   | UfOtherOp   PrimOp
85
86 data UnfoldingCoreAlts name
87   = UfCoAlgAlts  [(name, [UfBinder name], UnfoldingCoreExpr name)]
88                  (UnfoldingCoreDefault name)
89   | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr name)]
90                  (UnfoldingCoreDefault name)
91
92 data UnfoldingCoreDefault name
93   = UfCoNoDefault
94   | UfCoBindDefault (UfBinder name)
95                     (UnfoldingCoreExpr name)
96
97 data UnfoldingCoreBinding name
98   = UfCoNonRec  (UfBinder name)
99                 (UnfoldingCoreExpr name)
100   | UfCoRec     [(UfBinder name, UnfoldingCoreExpr name)]
101
102 data UnfoldingCoreAtom name
103   = UfCoVarAtom (UfId name)
104   | UfCoLitAtom BasicLit
105
106 data UfCostCentre name
107   = UfPreludeDictsCC
108                 Bool    -- True <=> is dupd
109   | UfAllDictsCC FAST_STRING    -- module and group
110                 FAST_STRING
111                 Bool    -- True <=> is dupd
112   | UfUserCC    FAST_STRING
113                 FAST_STRING FAST_STRING -- module and group
114                 Bool    -- True <=> is dupd
115                 Bool    -- True <=> is CAF
116   | UfAutoCC    (UfId name)
117                 FAST_STRING FAST_STRING -- module and group
118                 Bool Bool -- as above
119   | UfDictCC    (UfId name)
120                 FAST_STRING FAST_STRING -- module and group
121                 Bool Bool -- as above
122
123 type UfBinder name = (name, UnfoldingType name)
124
125 data UfId name
126   = BoringUfId          name
127   | SuperDictSelUfId    name name       -- class and superclass
128   | ClassOpUfId         name name       -- class and class op
129   | DictFunUfId         name            -- class and type
130                         (UnfoldingType name)
131   | ConstMethodUfId     name name       -- class, class op, and type
132                         (UnfoldingType name)
133   | DefaultMethodUfId   name name       -- class and class op
134   | SpecUfId            (UfId name)     -- its unspecialised "parent"
135                         [Maybe (MonoType name)]
136   | WorkerUfId          (UfId name)     -- its non-working "parent"
137   -- more to come?
138
139 type UnfoldingType name = PolyType name
140 \end{code}
141
142 %************************************************************************
143 %*                                                                      *
144 \subsection[HsCore-print]{Printing Core unfoldings}
145 %*                                                                      *
146 %************************************************************************
147
148 \begin{code}
149 instance Outputable name => Outputable (UnfoldingCoreExpr name) where
150     ppr sty (UfCoVar v) = pprUfId sty v
151     ppr sty (UfCoLit l) = ppr sty l
152
153     ppr sty (UfCoCon c tys as)
154       = ppCat [ppStr "(UfCoCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
155     ppr sty (UfCoPrim o tys as)
156       = ppCat [ppStr "(UfCoPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
157
158     ppr sty (UfCoLam bs body)
159       = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
160     ppr sty (UfCoTyLam tv body)
161       = ppCat [ppStr "/\\", ppr sty tv, ppStr "->", ppr sty body]
162
163     ppr sty (UfCoApp fun arg)
164       = ppCat [ppStr "(UfCoApp", ppr sty fun, ppr sty arg, ppStr ")"]
165     ppr sty (UfCoTyApp expr ty)
166       = ppCat [ppStr "(UfCoTyApp", ppr sty expr, ppr sty ty, ppStr ")"]
167
168     ppr sty (UfCoCase scrut alts)
169       = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
170       where
171         pp_alts (UfCoAlgAlts alts deflt)
172           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
173           where
174            pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
175         pp_alts (UfCoPrimAlts alts deflt)
176           = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
177           where
178            pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
179
180         pp_deflt UfCoNoDefault = ppNil
181         pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
182
183     ppr sty (UfCoLet (UfCoNonRec b rhs) body)
184       = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
185     ppr sty (UfCoLet (UfCoRec pairs) body)
186       = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
187       where
188         pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
189
190     ppr sty (UfCoSCC uf_cc body)
191       = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
192
193 instance Outputable name => Outputable (UnfoldingPrimOp name) where
194     ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
195       = let
196             before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
197             after  = if is_casm then ppStr "'' " else ppSP
198         in
199         ppBesides [before, ppPStr str, after,
200                 ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
201     ppr sty (UfOtherOp op)
202       = ppr sty op
203
204 instance Outputable name => Outputable (UnfoldingCoreAtom name) where
205     ppr sty (UfCoVarAtom v) = pprUfId sty v
206     ppr sty (UfCoLitAtom l)         = ppr sty l
207
208 pprUfId sty (BoringUfId v) = ppr sty v
209 pprUfId sty (SuperDictSelUfId c sc)
210   = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
211 pprUfId sty (ClassOpUfId c op)
212   = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
213 pprUfId sty (DictFunUfId c ty)
214   = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
215 pprUfId sty (ConstMethodUfId c op ty)
216   = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
217 pprUfId sty (DefaultMethodUfId c ty)
218   = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
219
220 pprUfId sty (SpecUfId unspec ty_maybes)
221   = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
222                 ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
223   where
224     pp_ty_maybe Nothing  = ppStr "_N_"
225     pp_ty_maybe (Just t) = ppr sty t
226
227 pprUfId sty (WorkerUfId unwrkr)
228   = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
229 \end{code}
230
231 %************************************************************************
232 %*                                                                      *
233 \subsection[HsCore-equality]{Comparing Core unfoldings}
234 %*                                                                      *
235 %************************************************************************
236
237 We want to check that they are {\em exactly} the same.
238
239 \begin{code}
240 eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
241
242 eqUfExpr (UfCoVar v1)     (UfCoVar v2)     = eqUfId v1 v2
243 eqUfExpr (UfCoLit l1) (UfCoLit l2) = l1 == l2
244
245 eqUfExpr (UfCoCon c1 tys1 as1) (UfCoCon c2 tys2 as2)
246   = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
247 eqUfExpr (UfCoPrim o1 tys1 as1) (UfCoPrim o2 tys2 as2)
248   = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
249   where
250     eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
251     eq_op (UfOtherOp o1)        (UfOtherOp o2)
252       = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
253
254 eqUfExpr (UfCoLam bs1 body1) (UfCoLam bs2 body2)
255   = eq_lists eq_binder bs1 bs2 && eqUfExpr body1 body2
256 eqUfExpr (UfCoTyLam tv1 body1) (UfCoTyLam tv2 body2)
257   = eq_name tv1 tv2 && eqUfExpr body1 body2
258
259 eqUfExpr (UfCoApp fun1 arg1) (UfCoApp fun2 arg2)
260   = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
261 eqUfExpr (UfCoTyApp expr1 ty1) (UfCoTyApp expr2 ty2)
262   = eqUfExpr expr1 expr2 && eq_type ty1 ty2
263
264 eqUfExpr (UfCoCase scrut1 alts1) (UfCoCase scrut2 alts2)
265   = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
266   where
267     eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
268       = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
269       where
270        eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
271          = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
272
273     eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
274       = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
275       where
276        eq_alt (l1,rhs1) (l2,rhs2)
277          = l1 == l2 && eqUfExpr rhs1 rhs2
278
279     eq_alts _ _ = False -- catch-all
280
281     eq_deflt UfCoNoDefault UfCoNoDefault = True
282     eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
283       = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
284     eq_deflt _ _ = False
285
286 eqUfExpr (UfCoLet (UfCoNonRec b1 rhs1) body1) (UfCoLet (UfCoNonRec b2 rhs2) body2)
287   = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
288
289 eqUfExpr (UfCoLet (UfCoRec pairs1) body1) (UfCoLet (UfCoRec pairs2) body2)
290   = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
291   where
292     eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
293
294 eqUfExpr (UfCoSCC cc1 body1) (UfCoSCC cc2 body2)
295   = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
296
297 eqUfExpr _ _ = False -- Catch-all
298 \end{code}
299
300 \begin{code}
301 eqUfId (BoringUfId n1) (BoringUfId n2)
302   = eq_name n1 n2
303 eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
304   = eq_name a1 a2 && eq_name b1 b2
305 eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
306   = eq_name a1 a2 && eq_name b1 b2
307 eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
308   = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
309   where
310     eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
311       = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
312     eq_tycon ty1 ty2
313       = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
314
315 eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
316   = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
317 eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
318   = eq_name a1 a2 && eq_name b1 b2
319 eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
320   = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
321   where
322     eq_ty_maybe Nothing Nothing = True
323     eq_ty_maybe (Just ty1) (Just ty2)
324       = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
325       -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
326     eq_ty_maybe _ _ = False
327 eqUfId (WorkerUfId id1) (WorkerUfId id2)
328   = eqUfId id1 id2
329 eqUfId _ _ = False -- catch-all
330 \end{code}
331
332 \begin{code}
333 eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
334 eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
335 eq_atom _ _ = False
336
337 eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
338
339 eq_name :: ProtoName -> ProtoName -> Bool
340 eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
341
342 eq_type ty1 ty2
343   = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
344 \end{code}
345
346 \begin{code}
347 eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
348
349 eq_lists eq [] [] = True
350 eq_lists eq [] _  = False
351 eq_lists eq _  [] = False
352 eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
353 \end{code}