2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
7 #include "HsVersions.h"
10 GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..),
11 GenCoreCaseAlternatives(..), GenCoreCaseDefault(..),
12 pprCoreBinding, pprCoreExpr,
14 GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs,
16 -- and to make the interface self-sufficient ...
19 import PrelInfo ( PrimOp, PrimRep
20 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
21 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
23 import Type ( isPrimType, pprParendUniType, TyVar, TyCon, Type
25 import Literal ( Literal )
26 import Id ( getIdUniType, isBottomingId, Id
27 IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
31 import CostCentre ( showCostCentre, CostCentre )
35 %************************************************************************
37 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
39 %************************************************************************
41 Core programs, bindings, expressions, etc., are parameterised with
42 respect to the information kept about binding and bound occurrences of
43 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I
44 don't really like the pair of names; I prefer {\em binder} and {\em
45 bounder}. Or {\em binder} and {\em var}.]
47 A @GenCoreBinding@ is either a single non-recursive binding of a
48 ``binder'' to an expression, or a mutually-recursive blob of same.
50 data GenCoreBinding val_bdr val_occ tyvar uvar
51 = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
52 | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
56 %************************************************************************
58 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
60 %************************************************************************
62 @GenCoreExpr@ is the heart of the ``core'' data types; it is
63 (more-or-less) boiled-down second-order polymorphic lambda calculus.
64 For types in the core world, we just keep using @Types@.
66 data GenCoreExpr val_bdr val_occ tyvar uvar
68 | Lit Literal -- literal constants
71 @Cons@ and @Prims@ are saturated constructor and primitive-op
72 applications (see the comment). Note: @Con@s are only set up by the
73 simplifier (and by the desugarer when it knows what it's doing). The
74 desugarer sets up constructors as applications of global @Vars@s.
77 | Con Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar]
78 -- Saturated constructor application:
79 -- The constructor is a function of the form:
80 -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
81 -- <expr> where "/\" is a type lambda and "\" the
82 -- regular kind; there will be "m" Types and
83 -- "n" bindees in the Con args.
85 -- The type given is the result type of the application;
86 -- you can figure out the argument types from it if you want.
88 | Prim PrimOp Type [GenCoreArg val_occ tyvar uvar]
89 -- saturated primitive operation;
90 -- comment on Cons applies here, too.
91 -- The types work the same way
92 -- (PrimitiveOps may be polymorphic).
95 Ye olde abstraction and application operators.
97 | Lam (GenCoreBinder val_bdr tyvar uvar)
98 (GenCoreExpr val_bdr val_occ tyvar uvar)
100 | App (GenCoreExpr val_bdr val_occ tyvar uvar)
101 (GenCoreArg val_occ tyvar uvar)
104 Case expressions (\tr{case <expr> of <List of alternatives>}): there
105 are really two flavours masquerading here---those for scrutinising
106 {\em algebraic} types and those for {\em primitive} types. Please see
107 under @GenCoreCaseAlternatives@.
109 | Case (GenCoreExpr val_bdr val_occ tyvar uvar)
110 (GenCoreCaseAlternatives val_bdr val_occ tyvar uvar)
113 A Core case expression \tr{case e of v -> ...} implies evaluation of
114 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
117 Non-recursive @Lets@ only have one binding; having more than one
118 doesn't buy you much, and it is an easy way to mess up variable
121 | Let (GenCoreBinding val_bdr val_occ tyvar uvar)
122 (GenCoreExpr binder val_occ tyvar uvar)
123 -- both recursive and non-.
124 -- The "GenCoreBinding" records that information
127 For cost centre scc expressions we introduce a new core construct
128 @SCC@ so transforming passes have to deal with it explicitly. The
129 alternative of using a new PrimativeOp may result in a bad
130 transformations of which we are unaware.
132 | SCC CostCentre -- label of scc
133 (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
137 %************************************************************************
139 \subsection{Case alternatives in @GenCoreExpr@}
141 %************************************************************************
143 We have different kinds of @case@s, the differences being reflected in
144 the kinds of alternatives a case has. We maintain a distinction
145 between cases for scrutinising algebraic datatypes, as opposed to
146 primitive types. In both cases, we carry around a @TyCon@, as a
147 handle with which we can get info about the case (e.g., total number
148 of data constructors for this type).
156 Case e [ BindDefaultAlt x -> b ]
160 data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar
162 = AlgAlts [(Id, -- alts: data constructor,
163 [val_bdr], -- constructor's parameters,
164 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
165 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
167 | PrimAlts [(Literal, -- alts: unboxed literal,
168 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
169 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
171 -- obvious things: if there are no alts in the list, then the default
172 -- can't be NoDefault.
174 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
175 = NoDefault -- small con family: all
176 -- constructor accounted for
177 | BindDefault val_bdr -- form: var -> expr;
178 (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not
182 %************************************************************************
184 \subsection[CoreSyn-arguments]{Core ``argument'' wrapper type}
186 %************************************************************************
189 data GenCoreAtom val_occ tyvar uvar
192 | TyAtom (GenType tyvar)
193 | UsageAtom (Usage uvar)
196 ===+*** fix from here down ****===
197 =================================
199 instance Outputable bindee => Outputable (GenCoreArg bindee) where
200 ppr sty (ValArg atom) = ppr sty atom
201 ppr sty (TypeArg ty) = ppr sty ty
205 applyToArgs :: GenCoreExpr val_bdr bindee
206 -> [GenCoreArg bindee]
207 -> GenCoreExpr val_bdr bindee
209 applyToArgs fun [] = fun
210 applyToArgs fun (ValArg val : args) = applyToArgs (App fun val) args
211 applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args
214 @decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block
215 on the front of the args. Pretty common.
218 decomposeArgs :: [GenCoreArg bindee]
219 -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee])
221 decomposeArgs [] = ([],[],[])
223 decomposeArgs (TypeArg ty : args)
224 = case (decomposeArgs args) of { (tys, vals, rest) ->
225 (ty:tys, vals, rest) }
227 decomposeArgs (ValArg val : args)
228 = case (do_vals args) of { (vals, rest) ->
229 ([], val:vals, rest) }
231 do_vals (ValArg val : args)
232 = case (do_vals args) of { (vals, rest) ->
235 do_vals args = ([], args)
238 @collectArgs@ takes an application expression, returning the function
239 and the arguments to which it is applied.
242 collectArgs :: GenCoreExpr val_bdr bindee
243 -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee])
248 collect (App fun arg) args = collect fun (ValArg arg : args)
249 collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args)
250 collect other_expr args = (other_expr, args)
253 %************************************************************************
255 \subsection[CoreSyn-output]{Instance declarations for output}
257 %************************************************************************
259 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
260 function for ``major'' val_bdrs (those next to equal signs :-),
261 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
262 usually be called through some intermediary.
267 -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
268 -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
269 -> (PprStyle -> bdee -> Pretty) -- to print bindees
270 -> GenCoreBinding bndr bdee
273 pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr)
274 = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
275 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
277 pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds)
278 = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"),
279 ppAboves (map ppr_bind binds),
280 ifPprDebug sty (ppStr "{- end Rec -}")]
282 ppr_bind (val_bdr, expr)
283 = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
284 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
288 instance (Outputable bndr, Outputable bdee)
289 => Outputable (GenCoreBinding bndr bdee) where
290 ppr sty bind = pprCoreBinding sty ppr ppr ppr bind
292 instance (Outputable bndr, Outputable bdee)
293 => Outputable (GenCoreExpr bndr bdee) where
294 ppr sty expr = pprCoreExpr sty ppr ppr ppr expr
296 instance Outputable bdee => Outputable (GenCoreAtom bdee) where
297 ppr sty atom = pprCoreAtom sty ppr atom
303 -> (PprStyle -> bdee -> Pretty) -- to print bindees
307 pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit
308 pprCoreAtom sty pbdee (VarAtom v) = pbdee sty v
312 pprCoreExpr, pprParendCoreExpr
314 -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
315 -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
316 -> (PprStyle -> bdee -> Pretty) -- to print bindees
317 -> GenCoreExpr bndr bdee
320 pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name
322 pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal
324 pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con
326 pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con types args)
327 = ppHang (ppBesides [ppr sty con, ppChar '!'])
328 4 (ppSep ( (map (pprParendUniType sty) types)
329 ++ (map (pprCoreAtom sty pbdee) args)))
331 pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim prim tys args)
332 = ppHang (ppBesides [ppr sty prim, ppChar '!'])
333 4 (ppSep ( (map (pprParendUniType sty) tys)
334 ++ (map (pprCoreAtom sty pbdee) args) ))
336 pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr)
337 = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"])
338 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
340 pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr)
341 = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars),
342 ppStr "->", pp_varss var_lists])
343 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after)
345 (tyvars, var_lists, expr_after) = collect_tyvars expr
347 collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after )
348 where (tyvs, vs, e_after) = collect_tyvars e
349 collect_tyvars e@(Lam _ _) = ( [], vss, e_after )
350 where (vss, e_after) = collect_vars e
351 collect_tyvars other_e = ( [], [], other_e )
353 collect_vars (Lam var e) = ([var]:varss, e_after)
354 where (varss, e_after) = collect_vars e
355 collect_vars other_e = ( [], other_e )
358 pp_varss (vars:varss)
359 = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars),
360 ppStr "->", pp_varss varss]
362 pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App fun_expr atom)
364 (fun, args) = collect_args expr []
366 ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun)
367 4 (ppSep (map (pprCoreAtom sty pbdee) args))
369 collect_args (App fun arg) args = collect_args fun (arg:args)
370 collect_args fun args = (fun, args)
372 pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty)
373 = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr))
374 4 (pprParendUniType sty ty)
376 pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ")
378 pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts)
379 = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),
381 ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts),
384 -- special cases: let ... in let ...
385 -- ("disgusting" SLPJ)
387 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
389 ppCat [ppStr "let {", pbdr1 sty val_bdr, ppEquals],
390 ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
392 pprCoreExpr sty pbdr1 pbdr2 pbdee body ]
394 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
396 (ppHang (ppStr "let {")
397 2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, ppEquals])
398 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs),
400 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
402 -- general case (recursive case, too)
403 pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind expr)
404 = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind),
405 ppHang (ppStr "} in ") 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)]
407 pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC cc expr)
408 = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
409 pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ]
413 pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
414 pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e
415 pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e
416 = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen]
420 instance (Outputable bndr, Outputable bdee)
421 => Outputable (GenCoreCaseAlternatives bndr bdee) where
422 ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts
428 -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
429 -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
430 -> (PprStyle -> bdee -> Pretty) -- to print bindees
431 -> GenCoreCaseAlternatives bndr bdee
434 pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt)
435 = ppAboves [ ppAboves (map ppr_alt alts),
436 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
438 ppr_alt (con, params, expr)
439 = ppHang (ppCat [ppr_con con,
440 ppInterleave ppSP (map (pbdr2 sty) params),
442 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
446 then ppBesides [ppLparen, ppr sty con, ppRparen]
449 pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts alts deflt)
450 = ppAboves [ ppAboves (map ppr_alt alts),
451 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ]
454 = ppHang (ppCat [ppr sty lit, ppStr "->"])
455 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)
459 instance (Outputable bndr, Outputable bdee)
460 => Outputable (GenCoreCaseDefault bndr bdee) where
461 ppr sty deflt = pprCoreCaseDefault sty ppr ppr ppr deflt
467 -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs
468 -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs
469 -> (PprStyle -> bdee -> Pretty) -- to print bindees
470 -> GenCoreCaseDefault bndr bdee
473 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil
475 pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr)
476 = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"])
477 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)