2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
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.
14 #include "HsVersions.h"
17 UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
18 UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
19 UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
20 UnfoldingPrimOp(..), UfCostCentre(..)
26 import HsTypes ( MonoType, PolyType )
27 import PrimOp ( PrimOp, tagOf_PrimOp )
30 import Literal ( Literal )
31 import Outputable ( Outputable(..) )
36 %************************************************************************
38 \subsection[HsCore-types]{Types for read/written Core unfoldings}
40 %************************************************************************
43 data UnfoldingCoreExpr name
46 | UfCon name -- must be a "BoringUfId"...
48 [UnfoldingCoreAtom name]
49 | UfPrim (UnfoldingPrimOp name)
51 [UnfoldingCoreAtom name]
52 | UfLam (UfBinder name)
53 (UnfoldingCoreExpr name)
54 | UfApp (UnfoldingCoreExpr name)
55 (UnfoldingCoreAtom name)
56 | UfCase (UnfoldingCoreExpr name)
57 (UnfoldingCoreAlts name)
58 | UfLet (UnfoldingCoreBinding name)
59 (UnfoldingCoreExpr name)
60 | UfSCC (UfCostCentre name)
61 (UnfoldingCoreExpr name)
63 data UnfoldingPrimOp name
64 = UfCCallOp FAST_STRING -- callee
65 Bool -- True <=> casm, rather than ccall
66 Bool -- True <=> might cause GC
67 [UnfoldingType name] -- arg types, incl state token
68 -- (which will be first)
69 (UnfoldingType name) -- return type
72 data UnfoldingCoreAlts name
73 = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)]
74 (UnfoldingCoreDefault name)
75 | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
76 (UnfoldingCoreDefault name)
78 data UnfoldingCoreDefault name
80 | UfCoBindDefault (UfBinder name)
81 (UnfoldingCoreExpr name)
83 data UnfoldingCoreBinding name
84 = UfCoNonRec (UfBinder name)
85 (UnfoldingCoreExpr name)
86 | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)]
88 data UnfoldingCoreAtom name
89 = UfCoVarAtom (UfId name)
92 data UfCostCentre name
94 Bool -- True <=> is dupd
95 | UfAllDictsCC FAST_STRING -- module and group
97 Bool -- True <=> is dupd
98 | UfUserCC FAST_STRING
99 FAST_STRING FAST_STRING -- module and group
100 Bool -- True <=> is dupd
101 Bool -- True <=> is CAF
102 | UfAutoCC (UfId name)
103 FAST_STRING FAST_STRING -- module and group
104 Bool Bool -- as above
105 | UfDictCC (UfId name)
106 FAST_STRING FAST_STRING -- module and group
107 Bool Bool -- as above
109 type UfBinder name = (name, UnfoldingType name)
113 | SuperDictSelUfId name name -- class and superclass
114 | ClassOpUfId name name -- class and class op
115 | DictFunUfId name -- class and type
117 | ConstMethodUfId name name -- class, class op, and type
119 | DefaultMethodUfId name name -- class and class op
120 | SpecUfId (UfId name) -- its unspecialised "parent"
121 [Maybe (MonoType name)]
122 | WorkerUfId (UfId name) -- its non-working "parent"
125 type UnfoldingType name = PolyType name
128 %************************************************************************
130 \subsection[HsCore-print]{Printing Core unfoldings}
132 %************************************************************************
135 instance Outputable name => Outputable (UnfoldingCoreExpr name) where
136 ppr sty (UfVar v) = pprUfId sty v
137 ppr sty (UfLit l) = ppr sty l
139 ppr sty (UfCon c tys as)
140 = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
141 ppr sty (UfPrim o tys as)
142 = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
144 ppr sty (UfLam bs body)
145 = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
147 ppr sty (UfApp fun arg)
148 = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
150 ppr sty (UfCase scrut alts)
151 = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
153 pp_alts (UfCoAlgAlts alts deflt)
154 = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
156 pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
157 pp_alts (UfCoPrimAlts alts deflt)
158 = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
160 pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
162 pp_deflt UfCoNoDefault = ppNil
163 pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
165 ppr sty (UfLet (UfCoNonRec b rhs) body)
166 = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
167 ppr sty (UfLet (UfCoRec pairs) body)
168 = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
170 pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
172 ppr sty (UfSCC uf_cc body)
173 = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
175 instance Outputable name => Outputable (UnfoldingPrimOp name) where
176 ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
178 before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
179 after = if is_casm then ppStr "'' " else ppSP
181 ppBesides [before, ppPStr str, after,
182 ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
183 ppr sty (UfOtherOp op)
186 instance Outputable name => Outputable (UnfoldingCoreAtom name) where
187 ppr sty (UfCoVarAtom v) = pprUfId sty v
188 ppr sty (UfCoLitAtom l) = ppr sty l
190 pprUfId sty (BoringUfId v) = ppr sty v
191 pprUfId sty (SuperDictSelUfId c sc)
192 = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
193 pprUfId sty (ClassOpUfId c op)
194 = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
195 pprUfId sty (DictFunUfId c ty)
196 = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
197 pprUfId sty (ConstMethodUfId c op ty)
198 = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
199 pprUfId sty (DefaultMethodUfId c ty)
200 = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
202 pprUfId sty (SpecUfId unspec ty_maybes)
203 = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
204 ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
206 pp_ty_maybe Nothing = ppStr "_N_"
207 pp_ty_maybe (Just t) = ppr sty t
209 pprUfId sty (WorkerUfId unwrkr)
210 = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]