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-}, SYN_IE(Id) )
60 import Type ( isUnboxedType,GenType, SYN_IE(Type) )
61 import TyVar ( GenTyVar, SYN_IE(TyVar) )
62 import Usage ( SYN_IE(UVar),GenUsage,SYN_IE(Usage) )
63 import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} )
64 #if __GLASGOW_HASKELL__ >= 202
65 import Literal ( Literal )
66 import BinderInfo ( BinderInfo )
67 import PrimOp ( PrimOp )
71 %************************************************************************
73 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
75 %************************************************************************
77 Core programs, bindings, expressions, etc., are parameterised with
78 respect to the information kept about binding and bound occurrences of
79 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I
80 don't really like the pair of names; I prefer {\em binder} and {\em
81 bounder}. Or {\em binder} and {\em var}.]
83 A @GenCoreBinding@ is either a single non-recursive binding of a
84 ``binder'' to an expression, or a mutually-recursive blob of same.
86 data GenCoreBinding val_bdr val_occ tyvar uvar
87 = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
88 | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
92 bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
95 [GenCoreBinding val_bdr val_occ tyvar uvar] ->
96 [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
98 rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
100 bindersOf (NonRec binder _) = [binder]
101 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
103 pairsFromCoreBinds [] = []
104 pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs
105 pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs
107 rhssOfBind (NonRec _ rhs) = [rhs]
108 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
111 %************************************************************************
113 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
115 %************************************************************************
117 @GenCoreExpr@ is the heart of the ``core'' data types; it is
118 (more-or-less) boiled-down second-order polymorphic lambda calculus.
119 For types in the core world, we just keep using @Types@.
121 data GenCoreExpr val_bdr val_occ tyvar uvar
123 | Lit Literal -- literal constants
126 @Cons@ and @Prims@ are saturated constructor and primitive-op
127 applications (see the comment). Note: @Con@s are only set up by the
128 simplifier (and by the desugarer when it knows what it's doing). The
129 desugarer sets up constructors as applications of global @Vars@s.
132 | Con Id [GenCoreArg val_occ tyvar uvar]
133 -- Saturated constructor application:
134 -- The constructor is a function of the form:
135 -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
136 -- <expr> where "/\" is a type lambda and "\" the
137 -- regular kind; there will be "m" Types and
138 -- "n" bindees in the Con args.
140 | Prim PrimOp [GenCoreArg val_occ tyvar uvar]
141 -- saturated primitive operation;
143 -- comment on Cons applies here, too.
146 Ye olde abstraction and application operators.
148 | Lam (GenCoreBinder val_bdr tyvar uvar)
149 (GenCoreExpr val_bdr val_occ tyvar uvar)
151 | App (GenCoreExpr val_bdr val_occ tyvar uvar)
152 (GenCoreArg val_occ tyvar uvar)
155 Case expressions (\tr{case <expr> of <List of alternatives>}): there
156 are really two flavours masquerading here---those for scrutinising
157 {\em algebraic} types and those for {\em primitive} types. Please see
158 under @GenCoreCaseAlts@.
160 | Case (GenCoreExpr val_bdr val_occ tyvar uvar)
161 (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
164 A Core case expression \tr{case e of v -> ...} implies evaluation of
165 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
168 Non-recursive @Lets@ only have one binding; having more than one
169 doesn't buy you much, and it is an easy way to mess up variable
172 | Let (GenCoreBinding val_bdr val_occ tyvar uvar)
173 (GenCoreExpr val_bdr val_occ tyvar uvar)
174 -- both recursive and non-.
175 -- The "GenCoreBinding" records that information
178 For cost centre scc expressions we introduce a new core construct
179 @SCC@ so transforming passes have to deal with it explicitly. The
180 alternative of using a new PrimativeOp may result in a bad
181 transformations of which we are unaware.
183 | SCC CostCentre -- label of scc
184 (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
187 Coercions arise from uses of the constructor of a @newtype@
188 declaration, either in construction (resulting in a @CoreceIn@) or
189 pattern matching (resulting in a @CoerceOut@).
193 (GenType tyvar uvar) -- Type of the whole expression
194 (GenCoreExpr val_bdr val_occ tyvar uvar)
198 data Coercion = CoerceIn Id -- Apply this constructor
199 | CoerceOut Id -- Strip this constructor
203 %************************************************************************
205 \subsection{Core-constructing functions with checking}
207 %************************************************************************
209 When making @Lets@, we may want to take evasive action if the thing
210 being bound has unboxed type. We have different variants ...
212 @mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
213 @mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
214 @mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
215 (unboxed bindings in a letrec are still prohibited)
218 mkCoLetAny :: GenCoreBinding Id Id tyvar uvar
219 -> GenCoreExpr Id Id tyvar uvar
220 -> GenCoreExpr Id Id tyvar uvar
221 mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] ->
222 GenCoreExpr Id Id tyvar uvar ->
223 GenCoreExpr Id Id tyvar uvar
225 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
226 -> GenCoreExpr val_bdr val_occ tyvar uvar
227 -> GenCoreExpr val_bdr val_occ tyvar uvar
229 mkCoLetrecAny [] body = body
230 mkCoLetrecAny binds body = Let (Rec binds) body
232 mkCoLetsAny [] expr = expr
233 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
235 mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
236 mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
240 mkCoLetNoUnboxed bind@(Rec binds) body
241 = mkCoLetrecNoUnboxed binds body
243 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
244 = --ASSERT (not (isUnboxedType (idType binder)))
246 Var binder2 | binder == binder2
247 -> rhs -- hey, I have the rhs
251 mkCoLetsNoUnboxed [] expr = expr
252 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
254 mkCoLetrecNoUnboxed [] body = body
255 mkCoLetrecNoUnboxed binds body
256 = ASSERT (all is_boxed_bind binds)
259 is_boxed_bind (binder, rhs)
260 = (not . isUnboxedType . idType) binder
264 mkCoLetUnboxedToCase bind@(Rec binds) body
265 = mkCoLetrecNoUnboxed binds body
267 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
269 Var binder2 | binder == binder2
270 -> rhs -- hey, I have the rhs
272 -> if (not (isUnboxedType (idType binder))) then
273 Let bind body -- boxed...
275 Case rhs -- unboxed...
277 (BindDefault binder body))
279 mkCoLetsUnboxedToCase [] expr = expr
280 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
283 %************************************************************************
285 \subsection{Case alternatives in @GenCoreExpr@}
287 %************************************************************************
289 We have different kinds of @case@s, the differences being reflected in
290 the kinds of alternatives a case has. We maintain a distinction
291 between cases for scrutinising algebraic datatypes, as opposed to
292 primitive types. In both cases, we carry around a @TyCon@, as a
293 handle with which we can get info about the case (e.g., total number
294 of data constructors for this type).
302 Case e [ BindDefaultAlt x -> b ]
306 data GenCoreCaseAlts val_bdr val_occ tyvar uvar
307 = AlgAlts [(Id, -- alts: data constructor,
308 [val_bdr], -- constructor's parameters,
309 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
310 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
312 | PrimAlts [(Literal, -- alts: unboxed literal,
313 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
314 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
316 -- obvious things: if there are no alts in the list, then the default
317 -- can't be NoDefault.
319 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
320 = NoDefault -- small con family: all
321 -- constructor accounted for
322 | BindDefault val_bdr -- form: var -> expr;
323 (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not
328 rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
329 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
331 rhssOfDeflt NoDefault = []
332 rhssOfDeflt (BindDefault _ rhs) = [rhs]
335 %************************************************************************
337 \subsection{Core binders}
339 %************************************************************************
342 data GenCoreBinder val_bdr tyvar uvar
347 isValBinder (ValBinder _) = True
348 isValBinder _ = False
350 notValBinder = not . isValBinder
353 Clump Lams together if possible.
356 mkValLam :: [val_bdr]
357 -> GenCoreExpr val_bdr val_occ tyvar uvar
358 -> GenCoreExpr val_bdr val_occ tyvar uvar
360 -> GenCoreExpr val_bdr val_occ tyvar uvar
361 -> GenCoreExpr val_bdr val_occ tyvar uvar
363 -> GenCoreExpr val_bdr val_occ tyvar uvar
364 -> GenCoreExpr val_bdr val_occ tyvar uvar
366 mkValLam binders body = foldr (Lam . ValBinder) body binders
367 mkTyLam binders body = foldr (Lam . TyBinder) body binders
368 mkUseLam binders body = foldr (Lam . UsageBinder) body binders
370 mkLam :: [tyvar] -> [val_bdr] -- ToDo: could add a [uvar] arg...
371 -> GenCoreExpr val_bdr val_occ tyvar uvar
372 -> GenCoreExpr val_bdr val_occ tyvar uvar
374 mkLam tyvars valvars body
375 = mkTyLam tyvars (mkValLam valvars body)
378 We often want to strip off leading lambdas before getting down to
379 business. @collectBinders@ is your friend.
381 We expect (by convention) usage-, type-, and value- lambdas in that
386 GenCoreExpr val_bdr val_occ tyvar uvar ->
387 ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
390 = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) }
392 (usages, tyvars, body1) = collectUsageAndTyBinders expr
393 -- (vals, body) = collectValBinders body1
396 collectUsageAndTyBinders expr
397 = case usages expr [] of
398 ([],tyvars,body) -> ([],tyvars,body)
401 usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
403 = case (tyvars other []) of { (tacc, expr) ->
404 (reverse uacc, tacc, expr) }
406 tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
408 = ASSERT(not (usage_lambda other))
409 (reverse tacc, other)
411 ---------------------------------------
412 usage_lambda (Lam (UsageBinder _) _) = True
413 usage_lambda _ = False
415 tyvar_lambda (Lam (TyBinder _) _) = True
416 tyvar_lambda _ = False
419 collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
420 ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
421 collectValBinders expr
423 ([],body) -> ([],body)
426 go acc (Lam (ValBinder v) b) = go (v:acc) b
427 go acc body = (reverse acc, body)
431 %************************************************************************
433 \subsection{Core arguments (atoms)}
435 %************************************************************************
438 data GenCoreArg val_occ tyvar uvar
441 | TyArg (GenType tyvar uvar)
442 | UsageArg (GenUsage uvar)
445 General and specific forms:
447 mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
448 -> [GenCoreArg val_occ tyvar uvar]
449 -> GenCoreExpr val_bdr val_occ tyvar uvar
450 mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar
451 -> [GenType tyvar uvar]
452 -> GenCoreExpr val_bdr val_occ tyvar uvar
453 mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
455 -> GenCoreExpr val_bdr val_occ tyvar uvar
456 mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
457 -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
458 -> GenCoreExpr val_bdr val_occ tyvar uvar
460 mkGenApp f args = foldl App f args
461 mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
462 mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args
463 mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
469 = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
472 isValArg (LitArg _) = True -- often used for sanity-checking
473 isValArg (VarArg _) = True
476 notValArg = not . isValArg -- exists only because it's a common use of isValArg
478 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
482 mkApp fun = mk_thing (mkGenApp fun)
483 mkCon con = mk_thing (Con con)
484 mkPrim op = mk_thing (Prim op)
486 mk_thing thing uses tys vals
487 = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
490 @collectArgs@ takes an application expression, returning the function
491 and the arguments to which it is applied.
494 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
495 -> (GenCoreExpr val_bdr val_occ tyvar uvar,
497 [GenType tyvar uvar],
498 [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
503 valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
505 = case (tyvars fun []) of { (expr, uacc, tacc) ->
506 (expr, uacc, tacc, vacc) }
508 tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
510 = case (usages fun []) of { (expr, uacc) ->
513 usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
520 initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
521 -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
522 initialTyArgs (TyArg ty : args) = (ty:tys, args')
524 (tys, args') = initialTyArgs args
525 initialTyArgs other = ([],other)
527 initialValArgs :: [GenCoreArg val_occ tyvar uvar]
528 -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
529 initialValArgs args = span isValArg args
533 %************************************************************************
535 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
537 %************************************************************************
540 type CoreBinding = GenCoreBinding Id Id TyVar UVar
541 type CoreExpr = GenCoreExpr Id Id TyVar UVar
542 type CoreBinder = GenCoreBinder Id TyVar UVar
543 type CoreArg = GenCoreArg Id TyVar UVar
545 type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar
546 type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
549 %************************************************************************
551 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
553 %************************************************************************
555 Binders are ``tagged'' with a \tr{t}:
557 type Tagged t = (Id, t)
559 type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
560 type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar
561 type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar
562 type TaggedCoreArg t = GenCoreArg Id TyVar UVar
564 type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar
565 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
568 %************************************************************************
570 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
572 %************************************************************************
574 Binders are tagged with @BinderInfo@:
576 type Simplifiable = (Id, BinderInfo)
578 type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
579 type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar
580 type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar
581 type SimplifiableCoreArg = GenCoreArg Id TyVar UVar
583 type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar
584 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar