[project @ 1996-07-15 16:16:46 by partain]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreSyn.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[CoreSyn]{A data type for the Haskell compiler midsection}
5
6 \begin{code}
7 #include "HsVersions.h"
8
9 module CoreSyn (
10         GenCoreBinding(..), GenCoreExpr(..),
11         GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
12         GenCoreCaseDefault(..),
13         Coercion(..),
14
15         bindersOf, pairsFromCoreBinds, rhssOfBind,
16
17         mkGenApp, mkValApp, mkTyApp, mkUseApp,
18         mkApp, mkCon, mkPrim,
19         mkValLam, mkTyLam, mkUseLam,
20         mkLam,
21         collectBinders, collectUsageAndTyBinders, collectValBinders, 
22         isValBinder, notValBinder,
23         
24         collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
25
26         mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
27         mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
28         mkCoLetrecAny, mkCoLetrecNoUnboxed,
29
30         rhssOfAlts,
31
32         -- Common type instantiation...
33         SYN_IE(CoreBinding),
34         SYN_IE(CoreExpr),
35         SYN_IE(CoreBinder),
36         SYN_IE(CoreArg),
37         SYN_IE(CoreCaseAlts),
38         SYN_IE(CoreCaseDefault),
39
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),
47
48         SYN_IE(SimplifiableCoreBinding),
49         SYN_IE(SimplifiableCoreExpr),
50         SYN_IE(SimplifiableCoreBinder),
51         SYN_IE(SimplifiableCoreArg),
52         SYN_IE(SimplifiableCoreCaseAlts),
53         SYN_IE(SimplifiableCoreCaseDefault)
54     ) where
55
56 IMP_Ubiq(){-uitous-}
57
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-} )
63 \end{code}
64
65 %************************************************************************
66 %*                                                                      *
67 \subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@}
68 %*                                                                      *
69 %************************************************************************
70
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}.]
76
77 A @GenCoreBinding@ is either a single non-recursive binding of a
78 ``binder'' to an expression, or a mutually-recursive blob of same.
79 \begin{code}
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)]
83 \end{code}
84
85 \begin{code}
86 bindersOf :: GenCoreBinding val_bdr val_occ tyvar uvar -> [val_bdr]
87
88 pairsFromCoreBinds ::
89   [GenCoreBinding val_bdr val_occ tyvar uvar] ->
90   [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
91
92 rhssOfBind :: GenCoreBinding val_bdr val_occ tyvar uvar -> [GenCoreExpr val_bdr val_occ tyvar uvar]
93
94 bindersOf (NonRec binder _) = [binder]
95 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
96
97 pairsFromCoreBinds []                  = []
98 pairsFromCoreBinds ((NonRec b e) : bs) = (b,e) :  pairsFromCoreBinds bs
99 pairsFromCoreBinds ((Rec  pairs) : bs) = pairs ++ pairsFromCoreBinds bs
100
101 rhssOfBind (NonRec _ rhs) = [rhs]
102 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
103 \end{code}
104
105 %************************************************************************
106 %*                                                                      *
107 \subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@}
108 %*                                                                      *
109 %************************************************************************
110
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@.
114 \begin{code}
115 data GenCoreExpr val_bdr val_occ tyvar uvar
116      = Var    val_occ
117      | Lit    Literal   -- literal constants
118 \end{code}
119
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.
124
125 \begin{code}
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.
133
134      | Prim     PrimOp [GenCoreArg val_occ tyvar uvar]
135                 -- saturated primitive operation;
136                 -- comment on Cons applies here, too.
137 \end{code}
138
139 Ye olde abstraction and application operators.
140 \begin{code}
141      | Lam      (GenCoreBinder val_bdr tyvar uvar)
142                 (GenCoreExpr   val_bdr val_occ tyvar uvar)
143
144      | App      (GenCoreExpr val_bdr val_occ tyvar uvar)
145                 (GenCoreArg  val_occ tyvar uvar)
146 \end{code}
147
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@.
152 \begin{code}
153      | Case     (GenCoreExpr val_bdr val_occ tyvar uvar)
154                 (GenCoreCaseAlts val_bdr val_occ tyvar uvar)
155 \end{code}
156
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
159 \tr{case}).
160
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
163 scoping.
164 \begin{code}
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
169 \end{code}
170
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.
175 \begin{code}
176      | SCC      CostCentre                                  -- label of scc
177                 (GenCoreExpr val_bdr val_occ tyvar uvar)    -- scc expression
178 \end{code}
179
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@).
183
184 \begin{code}
185     | Coerce    Coercion
186                 (GenType tyvar uvar)            -- Type of the whole expression
187                 (GenCoreExpr val_bdr val_occ tyvar uvar)
188 \end{code}
189
190 \begin{code}
191 data Coercion   = CoerceIn Id           -- Apply this constructor
192                 | CoerceOut Id          -- Strip this constructor
193 \end{code}
194
195
196 %************************************************************************
197 %*                                                                      *
198 \subsection{Core-constructing functions with checking}
199 %*                                                                      *
200 %************************************************************************
201
202 When making @Lets@, we may want to take evasive action if the thing
203 being bound has unboxed type. We have different variants ...
204
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)
209
210 \begin{code}
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
217
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
221
222 mkCoLetrecAny []    body = body
223 mkCoLetrecAny binds body = Let (Rec binds) body
224
225 mkCoLetsAny []    expr = expr
226 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
227
228 mkCoLetAny bind@(Rec binds)         body = mkCoLetrecAny binds body
229 mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
230 \end{code}
231
232 \begin{code}
233 mkCoLetNoUnboxed bind@(Rec binds) body
234   = mkCoLetrecNoUnboxed binds body
235
236 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
237   = --ASSERT (not (isUnboxedType (idType binder)))
238     case body of
239       Var binder2 | binder == binder2
240          -> rhs   -- hey, I have the rhs
241       other
242          -> Let bind body
243
244 mkCoLetsNoUnboxed []    expr = expr
245 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
246
247 mkCoLetrecNoUnboxed []    body = body
248 mkCoLetrecNoUnboxed binds body
249   = ASSERT (all is_boxed_bind binds)
250     Let (Rec binds) body
251   where
252     is_boxed_bind (binder, rhs)
253       = (not . isUnboxedType . idType) binder
254 \end{code}
255
256 \begin{code}
257 mkCoLetUnboxedToCase bind@(Rec binds) body
258   = mkCoLetrecNoUnboxed binds body
259
260 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
261   = case body of
262       Var binder2 | binder == binder2
263          -> rhs   -- hey, I have the rhs
264       other
265          -> if (not (isUnboxedType (idType binder))) then
266                 Let bind body            -- boxed...
267             else
268                 Case rhs                  -- unboxed...
269                   (PrimAlts []
270                     (BindDefault binder body))
271
272 mkCoLetsUnboxedToCase []    expr = expr
273 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
274 \end{code}
275
276 %************************************************************************
277 %*                                                                      *
278 \subsection{Case alternatives in @GenCoreExpr@}
279 %*                                                                      *
280 %************************************************************************
281
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).
288
289 For example:
290 \begin{verbatim}
291 let# x=e in b
292 \end{verbatim}
293 becomes
294 \begin{verbatim}
295 Case e [ BindDefaultAlt x -> b ]
296 \end{verbatim}
297
298 \begin{code}
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)
304
305   | PrimAlts    [(Literal,                      -- alts: unboxed literal,
306                   GenCoreExpr val_bdr val_occ tyvar uvar)]      -- rhs.
307                 (GenCoreCaseDefault val_bdr val_occ tyvar uvar)
308
309 -- obvious things: if there are no alts in the list, then the default
310 -- can't be NoDefault.
311
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
317                                                 -- be used in RHS.
318 \end{code}
319
320 \begin{code}
321 rhssOfAlts (AlgAlts alts deflt)  = rhssOfDeflt deflt ++ [rhs | (_,_,rhs) <- alts]
322 rhssOfAlts (PrimAlts alts deflt) = rhssOfDeflt deflt ++ [rhs | (_,rhs)   <- alts]
323
324 rhssOfDeflt NoDefault           = []
325 rhssOfDeflt (BindDefault _ rhs) = [rhs]
326 \end{code}
327
328 %************************************************************************
329 %*                                                                      *
330 \subsection{Core binders}
331 %*                                                                      *
332 %************************************************************************
333
334 \begin{code}
335 data GenCoreBinder val_bdr tyvar uvar
336   = ValBinder   val_bdr
337   | TyBinder    tyvar
338   | UsageBinder uvar
339
340 isValBinder (ValBinder _) = True
341 isValBinder _             = False
342
343 notValBinder = not . isValBinder
344 \end{code}
345
346 Clump Lams together if possible.
347
348 \begin{code}
349 mkValLam :: [val_bdr]
350          -> GenCoreExpr val_bdr val_occ tyvar uvar
351          -> GenCoreExpr val_bdr val_occ tyvar uvar
352 mkTyLam  :: [tyvar]
353          -> GenCoreExpr val_bdr val_occ tyvar uvar
354          -> GenCoreExpr val_bdr val_occ tyvar uvar
355 mkUseLam :: [uvar]
356          -> GenCoreExpr val_bdr val_occ tyvar uvar
357          -> GenCoreExpr val_bdr val_occ tyvar uvar
358
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
362
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
366
367 mkLam tyvars valvars body
368   = mkTyLam tyvars (mkValLam valvars body)
369 \end{code}
370
371 We often want to strip off leading lambdas before getting down to
372 business.  @collectBinders@ is your friend.
373
374 We expect (by convention) usage-, type-, and value- lambdas in that
375 order.
376
377 \begin{code}
378 collectBinders ::
379   GenCoreExpr val_bdr val_occ tyvar uvar ->
380   ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
381
382 collectBinders expr
383   = (usages, tyvars, vals, body)
384   where
385     (usages, tyvars, body1) = collectUsageAndTyBinders expr
386     (vals, body)            = collectValBinders body1
387
388
389 collectUsageAndTyBinders expr
390   = usages expr []
391   where
392     usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
393     usages other uacc
394       = case (tyvars other []) of { (tacc, expr) ->
395         (reverse uacc, tacc, expr) }
396
397     tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
398     tyvars other tacc
399       = ASSERT(not (usage_lambda other))
400         (reverse tacc, other)
401
402     ---------------------------------------
403     usage_lambda (Lam (UsageBinder _) _) = True
404     usage_lambda _                       = False
405
406     tyvar_lambda (Lam (TyBinder _) _)    = True
407     tyvar_lambda _                       = False
408
409
410 collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
411                      ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
412 collectValBinders expr
413   = go [] expr
414   where
415     go acc (Lam (ValBinder v) b) = go (v:acc) b
416     go acc body                  = (reverse acc, body)
417
418 \end{code}
419
420 %************************************************************************
421 %*                                                                      *
422 \subsection{Core arguments (atoms)}
423 %*                                                                      *
424 %************************************************************************
425
426 \begin{code}
427 data GenCoreArg val_occ tyvar uvar
428   = LitArg      Literal
429   | VarArg      val_occ
430   | TyArg       (GenType tyvar uvar)
431   | UsageArg    (GenUsage uvar)
432 \end{code}
433
434 General and specific forms:
435 \begin{code}
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
443          -> [GenUsage 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
448
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
453
454 #ifndef DEBUG
455 is_Lit_or_Var a = a
456 #else
457 is_Lit_or_Var a
458   = if isValArg a then a else panic "CoreSyn.mkValApps:not LitArg or VarArg"
459 #endif
460
461 isValArg (LitArg _) = True  -- often used for sanity-checking
462 isValArg (VarArg _) = True
463 isValArg _          = False
464
465 notValArg = not . isValArg -- exists only because it's a common use of isValArg
466
467 numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
468 \end{code}
469
470 \begin{code}
471 mkApp  fun = mk_thing (mkGenApp fun)
472 mkCon  con = mk_thing (Con      con)
473 mkPrim op  = mk_thing (Prim     op)
474
475 mk_thing thing uses tys vals
476   = thing (map UsageArg uses ++ map TyArg tys ++ map is_Lit_or_Var vals)
477 \end{code}
478
479 @collectArgs@ takes an application expression, returning the function
480 and the arguments to which it is applied.
481
482 \begin{code}
483 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
484             -> (GenCoreExpr val_bdr val_occ tyvar uvar,
485                 [GenUsage uvar],
486                 [GenType tyvar uvar],
487                 [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
488
489 collectArgs expr
490   = valvars expr []
491   where
492     valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
493     valvars fun vacc
494       = case (tyvars fun []) of { (expr, uacc, tacc) ->
495         (expr, uacc, tacc, vacc) }
496
497     tyvars (App fun (TyArg t))    tacc = tyvars fun (t:tacc)
498     tyvars fun tacc
499       = case (usages fun []) of { (expr, uacc) ->
500         (expr, uacc, tacc) }
501
502     usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
503     usages fun uacc
504       = (fun,uacc)
505 \end{code}
506
507
508 \begin{code}
509 initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
510               -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
511 initialTyArgs (TyArg ty : args) = (ty:tys, args') 
512                                 where
513                                   (tys, args') = initialTyArgs args
514 initialTyArgs other             = ([],other)
515
516 initialValArgs :: [GenCoreArg val_occ tyvar uvar]
517               -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
518 initialValArgs args = span isValArg args
519 \end{code}
520
521
522 %************************************************************************
523 %*                                                                      *
524 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}
525 %*                                                                      *
526 %************************************************************************
527
528 \begin{code}
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
533
534 type CoreCaseAlts    = GenCoreCaseAlts    Id Id TyVar UVar
535 type CoreCaseDefault = GenCoreCaseDefault Id Id TyVar UVar
536 \end{code}
537
538 %************************************************************************
539 %*                                                                      *
540 \subsection{The @TaggedCore*@ instantiation of the @GenCore*@ types}
541 %*                                                                      *
542 %************************************************************************
543
544 Binders are ``tagged'' with a \tr{t}:
545 \begin{code}
546 type Tagged t = (Id, t)
547
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
552
553 type TaggedCoreCaseAlts    t = GenCoreCaseAlts    (Tagged t) Id TyVar UVar
554 type TaggedCoreCaseDefault t = GenCoreCaseDefault (Tagged t) Id TyVar UVar
555 \end{code}
556
557 %************************************************************************
558 %*                                                                      *
559 \subsection{The @SimplifiableCore*@ instantiation of the @GenCore*@ types}
560 %*                                                                      *
561 %************************************************************************
562
563 Binders are tagged with @BinderInfo@:
564 \begin{code}
565 type Simplifiable = (Id, BinderInfo)
566
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
571
572 type SimplifiableCoreCaseAlts    = GenCoreCaseAlts    Simplifiable Id TyVar UVar
573 type SimplifiableCoreCaseDefault = GenCoreCaseDefault Simplifiable Id TyVar UVar
574 \end{code}