2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
7 #include "HsVersions.h"
10 GenCoreBinding(..), GenCoreExpr(..),
11 GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
12 GenCoreCaseDefault(..),
15 bindersOf, pairsFromCoreBinds, rhssOfBind,
17 mkGenApp, mkValApp, mkTyApp, mkUseApp,
19 mkValLam, mkTyLam, mkUseLam,
21 collectBinders, collectUsageAndTyBinders, collectValBinders,
22 isValBinder, notValBinder,
24 collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
26 mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
27 mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
28 mkCoLetrecAny, mkCoLetrecNoUnboxed,
32 -- Common type instantiation...
38 SYN_IE(CoreCaseDefault),
40 -- And not-so-common type instantiations...
41 SYN_IE(TaggedCoreBinding),
42 SYN_IE(TaggedCoreExpr),
43 SYN_IE(TaggedCoreBinder),
44 SYN_IE(TaggedCoreArg),
45 SYN_IE(TaggedCoreCaseAlts),
46 SYN_IE(TaggedCoreCaseDefault),
48 SYN_IE(SimplifiableCoreBinding),
49 SYN_IE(SimplifiableCoreExpr),
50 SYN_IE(SimplifiableCoreBinder),
51 SYN_IE(SimplifiableCoreArg),
52 SYN_IE(SimplifiableCoreCaseAlts),
53 SYN_IE(SimplifiableCoreCaseDefault)
58 import CostCentre ( showCostCentre, CostCentre )
59 import Id ( idType, GenId{-instance Eq-} )
60 import Type ( isUnboxedType )
61 import Usage ( SYN_IE(UVar) )
62 import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} )
65 %************************************************************************
67 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
69 %************************************************************************
71 Core programs, bindings, expressions, etc., are parameterised with
72 respect to the information kept about binding and bound occurrences of
73 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I
74 don't really like the pair of names; I prefer {\em binder} and {\em
75 bounder}. Or {\em binder} and {\em var}.]
77 A @GenCoreBinding@ is either a single non-recursive binding of a
78 ``binder'' to an expression, or a mutually-recursive blob of same.
80 data GenCoreBinding val_bdr val_occ tyvar uvar
81 = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
82 | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
86 bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
89 [GenCoreBinding val_bdr val_occ tyvar uvar] ->
90 [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
92 rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
94 bindersOf (NonRec binder _) = [binder]
95 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
97 pairsFromCoreBinds [] = []
98 pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs
99 pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs
101 rhssOfBind (NonRec _ rhs) = [rhs]
102 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
105 %************************************************************************
107 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
109 %************************************************************************
111 @GenCoreExpr@ is the heart of the ``core'' data types; it is
112 (more-or-less) boiled-down second-order polymorphic lambda calculus.
113 For types in the core world, we just keep using @Types@.
115 data GenCoreExpr val_bdr val_occ tyvar uvar
117 | Lit Literal -- literal constants
120 @Cons@ and @Prims@ are saturated constructor and primitive-op
121 applications (see the comment). Note: @Con@s are only set up by the
122 simplifier (and by the desugarer when it knows what it's doing). The
123 desugarer sets up constructors as applications of global @Vars@s.
126 | Con Id [GenCoreArg val_occ tyvar uvar]
127 -- Saturated constructor application:
128 -- The constructor is a function of the form:
129 -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
130 -- <expr> where "/\" is a type lambda and "\" the
131 -- regular kind; there will be "m" Types and
132 -- "n" bindees in the Con args.
134 | Prim PrimOp [GenCoreArg val_occ tyvar uvar]
135 -- saturated primitive operation;
136 -- comment on Cons applies here, too.
139 Ye olde abstraction and application operators.
141 | Lam (GenCoreBinder val_bdr tyvar uvar)
142 (GenCoreExpr val_bdr val_occ tyvar uvar)
144 | App (GenCoreExpr val_bdr val_occ tyvar uvar)
145 (GenCoreArg val_occ tyvar uvar)
148 Case expressions (\tr{case <expr> of <List of alternatives>}): there
149 are really two flavours masquerading here---those for scrutinising
150 {\em algebraic} types and those for {\em primitive} types. Please see
151 under @GenCoreCaseAlts@.
153 | Case (GenCoreExpr val_bdr val_occ tyvar uvar)
154 (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
157 A Core case expression \tr{case e of v -> ...} implies evaluation of
158 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
161 Non-recursive @Lets@ only have one binding; having more than one
162 doesn't buy you much, and it is an easy way to mess up variable
165 | Let (GenCoreBinding val_bdr val_occ tyvar uvar)
166 (GenCoreExpr val_bdr val_occ tyvar uvar)
167 -- both recursive and non-.
168 -- The "GenCoreBinding" records that information
171 For cost centre scc expressions we introduce a new core construct
172 @SCC@ so transforming passes have to deal with it explicitly. The
173 alternative of using a new PrimativeOp may result in a bad
174 transformations of which we are unaware.
176 | SCC CostCentre -- label of scc
177 (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
180 Coercions arise from uses of the constructor of a @newtype@
181 declaration, either in construction (resulting in a @CoreceIn@) or
182 pattern matching (resulting in a @CoerceOut@).
186 (GenType tyvar uvar) -- Type of the whole expression
187 (GenCoreExpr val_bdr val_occ tyvar uvar)
191 data Coercion = CoerceIn Id -- Apply this constructor
192 | CoerceOut Id -- Strip this constructor
196 %************************************************************************
198 \subsection{Core-constructing functions with checking}
200 %************************************************************************
202 When making @Lets@, we may want to take evasive action if the thing
203 being bound has unboxed type. We have different variants ...
205 @mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
206 @mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
207 @mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
208 (unboxed bindings in a letrec are still prohibited)
211 mkCoLetAny :: GenCoreBinding Id Id tyvar uvar
212 -> GenCoreExpr Id Id tyvar uvar
213 -> GenCoreExpr Id Id tyvar uvar
214 mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] ->
215 GenCoreExpr Id Id tyvar uvar ->
216 GenCoreExpr Id Id tyvar uvar
218 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
219 -> GenCoreExpr val_bdr val_occ tyvar uvar
220 -> GenCoreExpr val_bdr val_occ tyvar uvar
222 mkCoLetrecAny [] body = body
223 mkCoLetrecAny binds body = Let (Rec binds) body
225 mkCoLetsAny [] expr = expr
226 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
228 mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
229 mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
233 mkCoLetNoUnboxed bind@(Rec binds) body
234 = mkCoLetrecNoUnboxed binds body
236 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
237 = --ASSERT (not (isUnboxedType (idType binder)))
239 Var binder2 | binder == binder2
240 -> rhs -- hey, I have the rhs
244 mkCoLetsNoUnboxed [] expr = expr
245 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
247 mkCoLetrecNoUnboxed [] body = body
248 mkCoLetrecNoUnboxed binds body
249 = ASSERT (all is_boxed_bind binds)
252 is_boxed_bind (binder, rhs)
253 = (not . isUnboxedType . idType) binder
257 mkCoLetUnboxedToCase bind@(Rec binds) body
258 = mkCoLetrecNoUnboxed binds body
260 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
262 Var binder2 | binder == binder2
263 -> rhs -- hey, I have the rhs
265 -> if (not (isUnboxedType (idType binder))) then
266 Let bind body -- boxed...
268 Case rhs -- unboxed...
270 (BindDefault binder body))
272 mkCoLetsUnboxedToCase [] expr = expr
273 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
276 %************************************************************************
278 \subsection{Case alternatives in @GenCoreExpr@}
280 %************************************************************************
282 We have different kinds of @case@s, the differences being reflected in
283 the kinds of alternatives a case has. We maintain a distinction
284 between cases for scrutinising algebraic datatypes, as opposed to
285 primitive types. In both cases, we carry around a @TyCon@, as a
286 handle with which we can get info about the case (e.g., total number
287 of data constructors for this type).
295 Case e [ BindDefaultAlt x -> b ]
299 data GenCoreCaseAlts val_bdr val_occ tyvar uvar
300 = AlgAlts [(Id, -- alts: data constructor,
301 [val_bdr], -- constructor's parameters,
302 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
303 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
305 | PrimAlts [(Literal, -- alts: unboxed literal,
306 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
307 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
309 -- obvious things: if there are no alts in the list, then the default
310 -- can't be NoDefault.
312 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
313 = NoDefault -- small con family: all
314 -- constructor accounted for
315 | BindDefault val_bdr -- form: var -> expr;
316 (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not
321 rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
322 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
324 rhssOfDeflt NoDefault = []
325 rhssOfDeflt (BindDefault _ rhs) = [rhs]
328 %************************************************************************
330 \subsection{Core binders}
332 %************************************************************************
335 data GenCoreBinder val_bdr tyvar uvar
340 isValBinder (ValBinder _) = True
341 isValBinder _ = False
343 notValBinder = not . isValBinder
346 Clump Lams together if possible.
349 mkValLam :: [val_bdr]
350 -> GenCoreExpr val_bdr val_occ tyvar uvar
351 -> GenCoreExpr val_bdr val_occ tyvar uvar
353 -> GenCoreExpr val_bdr val_occ tyvar uvar
354 -> GenCoreExpr val_bdr val_occ tyvar uvar
356 -> GenCoreExpr val_bdr val_occ tyvar uvar
357 -> GenCoreExpr val_bdr val_occ tyvar uvar
359 mkValLam binders body = foldr (Lam . ValBinder) body binders
360 mkTyLam binders body = foldr (Lam . TyBinder) body binders
361 mkUseLam binders body = foldr (Lam . UsageBinder) body binders
363 mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg...
364 -> GenCoreExpr val_bdr val_occ tyvar uvar
365 -> GenCoreExpr val_bdr val_occ tyvar uvar
367 mkLam tyvars valvars body
368 = mkTyLam tyvars (mkValLam valvars body)
371 We often want to strip off leading lambdas before getting down to
372 business. @collectBinders@ is your friend.
374 We expect (by convention) usage-, type-, and value- lambdas in that
379 GenCoreExpr val_bdr val_occ tyvar uvar ->
380 ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
383 = (usages, tyvars, vals, body)
385 (usages, tyvars, body1) = collectUsageAndTyBinders expr
386 (vals, body) = collectValBinders body1
389 collectUsageAndTyBinders expr
392 usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
394 = case (tyvars other []) of { (tacc, expr) ->
395 (reverse uacc, tacc, expr) }
397 tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
399 = ASSERT(not (usage_lambda other))
400 (reverse tacc, other)
402 ---------------------------------------
403 usage_lambda (Lam (UsageBinder _) _) = True
404 usage_lambda _ = False
406 tyvar_lambda (Lam (TyBinder _) _) = True
407 tyvar_lambda _ = False
410 collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
411 ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
412 collectValBinders expr
415 go acc (Lam (ValBinder v) b) = go (v:acc) b
416 go acc body = (reverse acc, body)
420 %************************************************************************
422 \subsection{Core arguments (atoms)}
424 %************************************************************************
427 data GenCoreArg val_occ tyvar uvar
430 | TyArg (GenType tyvar uvar)
431 | UsageArg (GenUsage uvar)
434 General and specific forms:
436 mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
437 -> [GenCoreArg val_occ tyvar uvar]
438 -> GenCoreExpr val_bdr val_occ tyvar uvar
439 mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar
440 -> [GenType tyvar uvar]
441 -> GenCoreExpr val_bdr val_occ tyvar uvar
442 mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
444 -> GenCoreExpr val_bdr val_occ tyvar uvar
445 mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
446 -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
447 -> GenCoreExpr val_bdr val_occ tyvar uvar
449 mkGenApp f args = foldl App f args
450 mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
451 mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args
452 mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
458 = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
461 isValArg (LitArg _) = True -- often used for sanity-checking
462 isValArg (VarArg _) = True
465 notValArg = not . isValArg -- exists only because it's a common use of isValArg
467 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
471 mkApp fun = mk_thing (mkGenApp fun)
472 mkCon con = mk_thing (Con con)
473 mkPrim op = mk_thing (Prim op)
475 mk_thing thing uses tys vals
476 = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
479 @collectArgs@ takes an application expression, returning the function
480 and the arguments to which it is applied.
483 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
484 -> (GenCoreExpr val_bdr val_occ tyvar uvar,
486 [GenType tyvar uvar],
487 [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
492 valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
494 = case (tyvars fun []) of { (expr, uacc, tacc) ->
495 (expr, uacc, tacc, vacc) }
497 tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
499 = case (usages fun []) of { (expr, uacc) ->
502 usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
509 initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
510 -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
511 initialTyArgs (TyArg ty : args) = (ty:tys, args')
513 (tys, args') = initialTyArgs args
514 initialTyArgs other = ([],other)
516 initialValArgs :: [GenCoreArg val_occ tyvar uvar]
517 -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
518 initialValArgs args = span isValArg args
522 %************************************************************************
524 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
526 %************************************************************************
529 type CoreBinding = GenCoreBinding Id Id TyVar UVar
530 type CoreExpr = GenCoreExpr Id Id TyVar UVar
531 type CoreBinder = GenCoreBinder Id TyVar UVar
532 type CoreArg = GenCoreArg Id TyVar UVar
534 type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar
535 type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
538 %************************************************************************
540 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
542 %************************************************************************
544 Binders are ``tagged'' with a \tr{t}:
546 type Tagged t = (Id, t)
548 type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
549 type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar
550 type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar
551 type TaggedCoreArg t = GenCoreArg Id TyVar UVar
553 type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar
554 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
557 %************************************************************************
559 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
561 %************************************************************************
563 Binders are tagged with @BinderInfo@:
565 type Simplifiable = (Id, BinderInfo)
567 type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
568 type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar
569 type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar
570 type SimplifiableCoreArg = GenCoreArg Id TyVar UVar
572 type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar
573 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar