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(..),
14 bindersOf, pairsFromCoreBinds, rhssOfBind,
16 mkGenApp, mkValApp, mkTyApp, mkUseApp,
18 mkValLam, mkTyLam, mkUseLam,
22 collectArgs, isValArg, notValArg, numValArgs,
24 mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
25 mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
26 mkCoLetrecAny, mkCoLetrecNoUnboxed,
30 -- Common type instantiation...
38 -- And not-so-common type instantiations...
39 TaggedCoreBinding(..),
43 TaggedCoreCaseAlts(..),
44 TaggedCoreCaseDefault(..),
46 SimplifiableCoreBinding(..),
47 SimplifiableCoreExpr(..),
48 SimplifiableCoreBinder(..),
49 SimplifiableCoreArg(..),
50 SimplifiableCoreCaseAlts(..),
51 SimplifiableCoreCaseDefault(..)
53 -- and to make the interface self-sufficient ...
59 import CostCentre ( showCostCentre, CostCentre )
61 import Usage ( UVar(..) )
62 import Util ( panic, assertPanic )
64 isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
65 --eqId :: Id -> Id -> Bool
66 eqId = panic "CoreSyn.eqId"
69 %************************************************************************
71 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
73 %************************************************************************
75 Core programs, bindings, expressions, etc., are parameterised with
76 respect to the information kept about binding and bound occurrences of
77 variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I
78 don't really like the pair of names; I prefer {\em binder} and {\em
79 bounder}. Or {\em binder} and {\em var}.]
81 A @GenCoreBinding@ is either a single non-recursive binding of a
82 ``binder'' to an expression, or a mutually-recursive blob of same.
84 data GenCoreBinding val_bdr val_occ tyvar uvar
85 = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar)
86 | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
90 bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
93 [GenCoreBinding val_bdr val_occ tyvar uvar] ->
94 [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
96 rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
98 bindersOf (NonRec binder _) = [binder]
99 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
101 pairsFromCoreBinds [] = []
102 pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) : pairsFromCoreBinds bs
103 pairsFromCoreBinds ((Rec pairs) : bs) = pairs ++ pairsFromCoreBinds bs
105 rhssOfBind (NonRec _ rhs) = [rhs]
106 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
109 %************************************************************************
111 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
113 %************************************************************************
115 @GenCoreExpr@ is the heart of the ``core'' data types; it is
116 (more-or-less) boiled-down second-order polymorphic lambda calculus.
117 For types in the core world, we just keep using @Types@.
119 data GenCoreExpr val_bdr val_occ tyvar uvar
121 | Lit Literal -- literal constants
124 @Cons@ and @Prims@ are saturated constructor and primitive-op
125 applications (see the comment). Note: @Con@s are only set up by the
126 simplifier (and by the desugarer when it knows what it's doing). The
127 desugarer sets up constructors as applications of global @Vars@s.
130 | Con Id [GenCoreArg val_occ tyvar uvar]
131 -- Saturated constructor application:
132 -- The constructor is a function of the form:
133 -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn ->
134 -- <expr> where "/\" is a type lambda and "\" the
135 -- regular kind; there will be "m" Types and
136 -- "n" bindees in the Con args.
138 | Prim PrimOp [GenCoreArg val_occ tyvar uvar]
139 -- saturated primitive operation;
140 -- comment on Cons applies here, too.
143 Ye olde abstraction and application operators.
145 | Lam (GenCoreBinder val_bdr tyvar uvar)
146 (GenCoreExpr val_bdr val_occ tyvar uvar)
148 | App (GenCoreExpr val_bdr val_occ tyvar uvar)
149 (GenCoreArg val_occ tyvar uvar)
152 Case expressions (\tr{case <expr> of <List of alternatives>}): there
153 are really two flavours masquerading here---those for scrutinising
154 {\em algebraic} types and those for {\em primitive} types. Please see
155 under @GenCoreCaseAlts@.
157 | Case (GenCoreExpr val_bdr val_occ tyvar uvar)
158 (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
161 A Core case expression \tr{case e of v -> ...} implies evaluation of
162 \tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell
165 Non-recursive @Lets@ only have one binding; having more than one
166 doesn't buy you much, and it is an easy way to mess up variable
169 | Let (GenCoreBinding val_bdr val_occ tyvar uvar)
170 (GenCoreExpr val_bdr val_occ tyvar uvar)
171 -- both recursive and non-.
172 -- The "GenCoreBinding" records that information
175 For cost centre scc expressions we introduce a new core construct
176 @SCC@ so transforming passes have to deal with it explicitly. The
177 alternative of using a new PrimativeOp may result in a bad
178 transformations of which we are unaware.
180 | SCC CostCentre -- label of scc
181 (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
185 %************************************************************************
187 \subsection{Core-constructing functions with checking}
189 %************************************************************************
191 When making @Lets@, we may want to take evasive action if the thing
192 being bound has unboxed type. We have different variants ...
194 @mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
195 @mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
196 @mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
197 (unboxed bindings in a letrec are still prohibited)
200 mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar
201 -> GenCoreExpr val_bdr val_occ tyvar uvar
202 -> GenCoreExpr val_bdr val_occ tyvar uvar
203 mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] ->
204 GenCoreExpr val_bdr val_occ tyvar uvar ->
205 GenCoreExpr val_bdr val_occ tyvar uvar
206 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
207 -> GenCoreExpr val_bdr val_occ tyvar uvar
208 -> GenCoreExpr val_bdr val_occ tyvar uvar
210 mkCoLetrecAny [] body = body
211 mkCoLetrecAny binds body = Let (Rec binds) body
213 mkCoLetsAny [] expr = expr
214 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
216 mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
217 mkCoLetAny bind@(NonRec binder rhs) body
219 Var binder2 | binder `eqId` binder2
220 -> rhs -- hey, I have the rhs
226 --mkCoLetNoUnboxed ::
227 -- GenCoreBinding val_bdr val_occ tyvar uvar ->
228 -- GenCoreExpr val_bdr val_occ tyvar uvar ->
229 -- GenCoreExpr val_bdr val_occ tyvar uvar
231 mkCoLetNoUnboxed bind@(Rec binds) body
232 = mkCoLetrecNoUnboxed binds body
233 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
234 = --ASSERT (not (isUnboxedDataType (idType binder)))
236 Var binder2 | binder `eqId` binder2
237 -> rhs -- hey, I have the rhs
241 mkCoLetsNoUnboxed [] expr = expr
242 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
244 --mkCoLetrecNoUnboxed :: [(Id, CoreExpr)] -- bindings
245 -- -> CoreExpr -- body
246 -- -> CoreExpr -- result
248 mkCoLetrecNoUnboxed [] body = body
249 mkCoLetrecNoUnboxed binds body
250 = ASSERT (all is_boxed_bind binds)
253 is_boxed_bind (binder, rhs)
254 = (not . isUnboxedDataType . idType) binder
258 --mkCoLetUnboxedToCase ::
259 -- GenCoreBinding val_bdr val_occ tyvar uvar ->
260 -- GenCoreExpr val_bdr val_occ tyvar uvar ->
261 -- GenCoreExpr val_bdr val_occ tyvar uvar
263 mkCoLetUnboxedToCase bind@(Rec binds) body
264 = mkCoLetrecNoUnboxed binds body
265 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
267 Var binder2 | binder `eqId` binder2
268 -> rhs -- hey, I have the rhs
270 -> if (not (isUnboxedDataType (idType binder))) then
271 Let bind body -- boxed...
273 Case rhs -- unboxed...
275 (BindDefault binder body))
277 mkCoLetsUnboxedToCase [] expr = expr
278 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
281 %************************************************************************
283 \subsection{Case alternatives in @GenCoreExpr@}
285 %************************************************************************
287 We have different kinds of @case@s, the differences being reflected in
288 the kinds of alternatives a case has. We maintain a distinction
289 between cases for scrutinising algebraic datatypes, as opposed to
290 primitive types. In both cases, we carry around a @TyCon@, as a
291 handle with which we can get info about the case (e.g., total number
292 of data constructors for this type).
300 Case e [ BindDefaultAlt x -> b ]
304 data GenCoreCaseAlts val_bdr val_occ tyvar uvar
305 = AlgAlts [(Id, -- alts: data constructor,
306 [val_bdr], -- constructor's parameters,
307 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
308 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
310 | PrimAlts [(Literal, -- alts: unboxed literal,
311 GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs.
312 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
314 -- obvious things: if there are no alts in the list, then the default
315 -- can't be NoDefault.
317 data GenCoreCaseDefault val_bdr val_occ tyvar uvar
318 = NoDefault -- small con family: all
319 -- constructor accounted for
320 | BindDefault val_bdr -- form: var -> expr;
321 (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not
326 rhssOfAlts (AlgAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
327 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs) <- alts]
329 rhssOfDeflt NoDefault = []
330 rhssOfDeflt (BindDefault _ rhs) = [rhs]
333 %************************************************************************
335 \subsection{Core binders}
337 %************************************************************************
340 data GenCoreBinder val_bdr tyvar uvar
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)
382 collectBinders (Lam (UsageBinder u) body)
384 (uvars, tyvars, args, final_body) = collectBinders body
386 (u:uvars, tyvars, args, final_body)
390 (tyvars, args, body) = dig_for_tyvars other
392 ([], tyvars, args, body)
394 dig_for_tyvars (Lam (TyBinder tv) body)
396 (tyvars, args, body2) = dig_for_tyvars body
398 (tv : tyvars, args, body2)
401 = ASSERT(not (usage_lambda body))
403 (args, body2) = dig_for_valvars body
407 ---------------------------------------
408 dig_for_valvars (Lam (ValBinder v) body)
410 (args, body2) = dig_for_valvars body
415 = ASSERT(not (usage_lambda body))
416 ASSERT(not (tyvar_lambda body))
419 ---------------------------------------
420 usage_lambda (Lam (UsageBinder _) _) = True
421 usage_lambda _ = False
423 tyvar_lambda (Lam (TyBinder _) _) = True
424 tyvar_lambda _ = False
427 %************************************************************************
429 \subsection{Core arguments (atoms)}
431 %************************************************************************
434 data GenCoreArg val_occ tyvar uvar
437 | TyArg (GenType tyvar uvar)
438 | UsageArg (GenUsage uvar)
441 General and specific forms:
443 mkGenApp :: GenCoreExpr val_bdr val_occ tyvar uvar
444 -> [GenCoreArg val_occ tyvar uvar]
445 -> GenCoreExpr val_bdr val_occ tyvar uvar
446 mkTyApp :: GenCoreExpr val_bdr val_occ tyvar uvar
447 -> [GenType tyvar uvar]
448 -> GenCoreExpr val_bdr val_occ tyvar uvar
449 mkUseApp :: GenCoreExpr val_bdr val_occ tyvar uvar
451 -> GenCoreExpr val_bdr val_occ tyvar uvar
452 mkValApp :: GenCoreExpr val_bdr val_occ tyvar uvar
453 -> [GenCoreArg val_occ tyvar uvar] -- but we ASSERT they are LitArg or VarArg
454 -> GenCoreExpr val_bdr val_occ tyvar uvar
456 mkGenApp f args = foldl App f args
457 mkTyApp f args = foldl (\ e a -> App e (TyArg a)) f args
458 mkUseApp f args = foldl (\ e a -> App e (UsageArg a)) f args
459 mkValApp f args = foldl (\ e a -> App e (is_Lit_or_Var a)) f args
465 = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
468 isValArg (LitArg _) = True -- often used for sanity-checking
469 isValArg (VarArg _) = True
472 notValArg = not . isValArg -- exists only because it's a common use of isValArg
474 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
478 mkApp fun = mk_thing (mkGenApp fun)
479 mkCon con = mk_thing (Con con)
480 mkPrim op = mk_thing (Prim op)
482 mk_thing thing uses tys vals
483 = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
486 @collectArgs@ takes an application expression, returning the function
487 and the arguments to which it is applied.
490 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
491 -> (GenCoreExpr val_bdr val_occ tyvar uvar,
492 [GenCoreArg val_occ tyvar uvar])
497 collect (App fun arg) args = collect fun (arg : args)
498 collect fun args = (fun, args)
501 %************************************************************************
503 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
505 %************************************************************************
508 type CoreBinding = GenCoreBinding Id Id TyVar UVar
509 type CoreExpr = GenCoreExpr Id Id TyVar UVar
510 type CoreBinder = GenCoreBinder Id TyVar UVar
511 type CoreArg = GenCoreArg Id TyVar UVar
513 type CoreCaseAlts = GenCoreCaseAlts Id Id TyVar UVar
514 type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
517 %************************************************************************
519 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
521 %************************************************************************
523 Binders are ``tagged'' with a \tr{t}:
525 type Tagged t = (Id, t)
527 type TaggedCoreBinding t = GenCoreBinding (Tagged t) Id TyVar UVar
528 type TaggedCoreExpr t = GenCoreExpr (Tagged t) Id TyVar UVar
529 type TaggedCoreBinder t = GenCoreBinder (Tagged t) TyVar UVar
530 type TaggedCoreArg t = GenCoreArg Id TyVar UVar
532 type TaggedCoreCaseAlts t = GenCoreCaseAlts (Tagged t) Id TyVar UVar
533 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
536 %************************************************************************
538 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
540 %************************************************************************
542 Binders are tagged with @BinderInfo@:
544 type Simplifiable = (Id, BinderInfo)
546 type SimplifiableCoreBinding = GenCoreBinding Simplifiable Id TyVar UVar
547 type SimplifiableCoreExpr = GenCoreExpr Simplifiable Id TyVar UVar
548 type SimplifiableCoreBinder = GenCoreBinder Simplifiable TyVar UVar
549 type SimplifiableCoreArg = GenCoreArg Id TyVar UVar
551 type SimplifiableCoreCaseAlts = GenCoreCaseAlts Simplifiable Id TyVar UVar
552 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar