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;
137 -- comment on Cons applies here, too.
140 Ye olde abstraction and application operators.
142 | Lam (GenCoreBinder val_bdr tyvar uvar)
143 (GenCoreExpr val_bdr val_occ tyvar uvar)
145 | App (GenCoreExpr val_bdr val_occ tyvar uvar)
146 (GenCoreArg val_occ tyvar uvar)
149 Case expressions (\tr{case <expr> of <List of alternatives>}): there
150 are really two flavours masquerading here---those for scrutinising
151 {\em algebraic} types and those for {\em primitive} types. Please see
152 under @GenCoreCaseAlts@.
154 | Case (GenCoreExpr val_bdr val_occ tyvar uvar)
155 (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
158 A Core case expression \tr{case e of v -> ...} implies evaluation of
159 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
162 Non-recursive @Lets@ only have one binding; having more than one
163 doesn't buy you much, and it is an easy way to mess up variable
166 | Let (GenCoreBinding val_bdr val_occ tyvar uvar)
167 (GenCoreExpr val_bdr val_occ tyvar uvar)
168 -- both recursive and non-.
169 -- The "GenCoreBinding" records that information
172 For cost centre scc expressions we introduce a new core construct
173 @SCC@ so transforming passes have to deal with it explicitly. The
174 alternative of using a new PrimativeOp may result in a bad
175 transformations of which we are unaware.
177 | SCC CostCentre -- label of scc
178 (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
181 Coercions arise from uses of the constructor of a @newtype@
182 declaration, either in construction (resulting in a @CoreceIn@) or
183 pattern matching (resulting in a @CoerceOut@).
187 (GenType tyvar uvar) -- Type of the whole expression
188 (GenCoreExpr val_bdr val_occ tyvar uvar)
192 data Coercion = CoerceIn Id -- Apply this constructor
193 | CoerceOut Id -- Strip this constructor
197 %************************************************************************
199 \subsection{Core-constructing functions with checking}
201 %************************************************************************
203 When making @Lets@, we may want to take evasive action if the thing
204 being bound has unboxed type. We have different variants ...
206 @mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
207 @mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
208 @mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
209 (unboxed bindings in a letrec are still prohibited)
212 mkCoLetAny :: GenCoreBinding Id Id tyvar uvar
213 -> GenCoreExpr Id Id tyvar uvar
214 -> GenCoreExpr Id Id tyvar uvar
215 mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] ->
216 GenCoreExpr Id Id tyvar uvar ->
217 GenCoreExpr Id Id tyvar uvar
219 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
220 -> GenCoreExpr val_bdr val_occ tyvar uvar
221 -> GenCoreExpr val_bdr val_occ tyvar uvar
223 mkCoLetrecAny [] body = body
224 mkCoLetrecAny binds body = Let (Rec binds) body
226 mkCoLetsAny [] expr = expr
227 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
229 mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
230 mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
234 mkCoLetNoUnboxed bind@(Rec binds) body
235 = mkCoLetrecNoUnboxed binds body
237 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
238 = --ASSERT (not (isUnboxedType (idType binder)))
240 Var binder2 | binder == binder2
241 -> rhs -- hey, I have the rhs
245 mkCoLetsNoUnboxed [] expr = expr
246 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
248 mkCoLetrecNoUnboxed [] body = body
249 mkCoLetrecNoUnboxed binds body
250 = ASSERT (all is_boxed_bind binds)
253 is_boxed_bind (binder, rhs)
254 = (not . isUnboxedType . idType) binder
258 mkCoLetUnboxedToCase bind@(Rec binds) body
259 = mkCoLetrecNoUnboxed binds body
261 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
263 Var binder2 | binder == binder2
264 -> rhs -- hey, I have the rhs
266 -> if (not (isUnboxedType (idType binder))) then
267 Let bind body -- boxed...
269 Case rhs -- unboxed...
271 (BindDefault binder body))
273 mkCoLetsUnboxedToCase [] expr = expr
274 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
277 %************************************************************************
279 \subsection{Case alternatives in @GenCoreExpr@}
281 %************************************************************************
283 We have different kinds of @case@s, the differences being reflected in
284 the kinds of alternatives a case has. We maintain a distinction
285 between cases for scrutinising algebraic datatypes, as opposed to
286 primitive types. In both cases, we carry around a @TyCon@, as a
287 handle with which we can get info about the case (e.g., total number
288 of data constructors for this type).
296 Case e [ BindDefaultAlt x -> b ]
300 data GenCoreCaseAlts val_bdr val_occ tyvar uvar
301 = AlgAlts [(Id, -- alts: data constructor,
302 [val_bdr], -- constructor's parameters,
303 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
304 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
306 | PrimAlts [(Literal, -- alts: unboxed literal,
307 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
308 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
310 -- obvious things: if there are no alts in the list, then the default
311 -- can't be NoDefault.
313 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
314 = NoDefault -- small con family: all
315 -- constructor accounted for
316 | BindDefault val_bdr -- form: var -> expr;
317 (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not
322 rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
323 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
325 rhssOfDeflt NoDefault = []
326 rhssOfDeflt (BindDefault _ rhs) = [rhs]
329 %************************************************************************
331 \subsection{Core binders}
333 %************************************************************************
336 data GenCoreBinder val_bdr tyvar uvar
341 isValBinder (ValBinder _) = True
342 isValBinder _ = False
344 notValBinder = not . isValBinder
347 Clump Lams together if possible.
350 mkValLam :: [val_bdr]
351 -> GenCoreExpr val_bdr val_occ tyvar uvar
352 -> GenCoreExpr val_bdr val_occ tyvar uvar
354 -> GenCoreExpr val_bdr val_occ tyvar uvar
355 -> GenCoreExpr val_bdr val_occ tyvar uvar
357 -> GenCoreExpr val_bdr val_occ tyvar uvar
358 -> GenCoreExpr val_bdr val_occ tyvar uvar
360 mkValLam binders body = foldr (Lam . ValBinder) body binders
361 mkTyLam binders body = foldr (Lam . TyBinder) body binders
362 mkUseLam binders body = foldr (Lam . UsageBinder) body binders
364 mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg...
365 -> GenCoreExpr val_bdr val_occ tyvar uvar
366 -> GenCoreExpr val_bdr val_occ tyvar uvar
368 mkLam tyvars valvars body
369 = mkTyLam tyvars (mkValLam valvars body)
372 We often want to strip off leading lambdas before getting down to
373 business. @collectBinders@ is your friend.
375 We expect (by convention) usage-, type-, and value- lambdas in that
380 GenCoreExpr val_bdr val_occ tyvar uvar ->
381 ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
384 = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) }
386 (usages, tyvars, body1) = collectUsageAndTyBinders expr
387 -- (vals, body) = collectValBinders body1
390 collectUsageAndTyBinders expr
391 = case usages expr [] of
392 ([],tyvars,body) -> ([],tyvars,body)
395 usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
397 = case (tyvars other []) of { (tacc, expr) ->
398 (reverse uacc, tacc, expr) }
400 tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
402 = ASSERT(not (usage_lambda other))
403 (reverse tacc, other)
405 ---------------------------------------
406 usage_lambda (Lam (UsageBinder _) _) = True
407 usage_lambda _ = False
409 tyvar_lambda (Lam (TyBinder _) _) = True
410 tyvar_lambda _ = False
413 collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
414 ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
415 collectValBinders expr
417 ([],body) -> ([],body)
420 go acc (Lam (ValBinder v) b) = go (v:acc) b
421 go acc body = (reverse acc, body)
425 %************************************************************************
427 \subsection{Core arguments (atoms)}
429 %************************************************************************
432 data GenCoreArg val_occ tyvar uvar
435 | TyArg (GenType tyvar uvar)
436 | UsageArg (GenUsage uvar)
439 General and specific forms:
441 mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
442 -> [GenCoreArg val_occ tyvar uvar]
443 -> GenCoreExpr val_bdr val_occ tyvar uvar
444 mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar
445 -> [GenType tyvar uvar]
446 -> GenCoreExpr val_bdr val_occ tyvar uvar
447 mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
449 -> GenCoreExpr val_bdr val_occ tyvar uvar
450 mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
451 -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
452 -> GenCoreExpr val_bdr val_occ tyvar uvar
454 mkGenApp f args = foldl App f args
455 mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
456 mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args
457 mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
463 = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
466 isValArg (LitArg _) = True -- often used for sanity-checking
467 isValArg (VarArg _) = True
470 notValArg = not . isValArg -- exists only because it's a common use of isValArg
472 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
476 mkApp fun = mk_thing (mkGenApp fun)
477 mkCon con = mk_thing (Con con)
478 mkPrim op = mk_thing (Prim op)
480 mk_thing thing uses tys vals
481 = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
484 @collectArgs@ takes an application expression, returning the function
485 and the arguments to which it is applied.
488 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
489 -> (GenCoreExpr val_bdr val_occ tyvar uvar,
491 [GenType tyvar uvar],
492 [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
497 valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
499 = case (tyvars fun []) of { (expr, uacc, tacc) ->
500 (expr, uacc, tacc, vacc) }
502 tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
504 = case (usages fun []) of { (expr, uacc) ->
507 usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
514 initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
515 -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
516 initialTyArgs (TyArg ty : args) = (ty:tys, args')
518 (tys, args') = initialTyArgs args
519 initialTyArgs other = ([],other)
521 initialValArgs :: [GenCoreArg val_occ tyvar uvar]
522 -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
523 initialValArgs args = span isValArg args
527 %************************************************************************
529 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
531 %************************************************************************
534 type CoreBinding = GenCoreBinding Id Id TyVar UVar
535 type CoreExpr = GenCoreExpr Id Id TyVar UVar
536 type CoreBinder = GenCoreBinder Id TyVar UVar
537 type CoreArg = GenCoreArg Id TyVar UVar
539 type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar
540 type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
543 %************************************************************************
545 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
547 %************************************************************************
549 Binders are ``tagged'' with a \tr{t}:
551 type Tagged t = (Id, t)
553 type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
554 type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar
555 type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar
556 type TaggedCoreArg t = GenCoreArg Id TyVar UVar
558 type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar
559 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
562 %************************************************************************
564 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
566 %************************************************************************
568 Binders are tagged with @BinderInfo@:
570 type Simplifiable = (Id, BinderInfo)
572 type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
573 type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar
574 type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar
575 type SimplifiableCoreArg = GenCoreArg Id TyVar UVar
577 type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar
578 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar