2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
6 Handles @HsBinds@; those at the top level require different handling,
7 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
8 lower levels it is preserved with @let@/@letrec@s).
11 #include "HsVersions.h"
13 module DsBinds ( dsBinds, dsInstBinds ) where
16 import DsLoop -- break dsExpr-ish loop
18 import HsSyn -- lots of things
19 import CoreSyn -- lots of things
20 import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
21 TypecheckedBind(..), TypecheckedMonoBinds(..) )
22 import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
25 import DsGRHSs ( dsGuarded )
27 import Match ( matchWrapper )
29 import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude )
30 import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
31 import Id ( idType, DictVar(..), GenId )
32 import ListSetOps ( minusList, intersectLists )
33 import PprType ( GenType )
34 import PprStyle ( PprStyle(..) )
35 import Pretty ( ppShow )
36 import Type ( mkTyVarTys, splitSigmaTy,
37 tyVarsOfType, tyVarsOfTypes
39 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
40 import Util ( isIn, panic )
42 isDictTy = panic "DsBinds.isDictTy"
43 quantifyTy = panic "DsBinds.quantifyTy"
46 %************************************************************************
48 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
50 %************************************************************************
52 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
53 that some of the binders are of unboxed type. This is sorted out when
54 the caller wraps the bindings round an expression.
57 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
60 All ``real'' bindings are expressed in terms of the
61 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
62 and its desugaring is the subject of section~9.1 in the static
67 AbsBinds [a1, ... ,aj] -- type variables
68 [d1, ... ,dk] -- dict variables
69 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
70 [db1=..., ..., dbn=...] -- dict binds
71 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
73 we want to make, in the general case (non-Fozzie translation):
78 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
80 -- a bunch of selectors:
81 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
83 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
85 But there are lots of special cases.
88 %==============================================
89 \subsubsection{Structure cases}
90 %==============================================
93 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
94 dsBinds EmptyBinds = returnDs []
95 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
97 dsBinds (ThenBinds binds_1 binds_2)
98 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
102 %==============================================
103 \subsubsection{AbsBind case: no overloading}
104 %==============================================
106 Special case: no overloading.
111 We abstract each wrt the type variables, giving
113 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
114 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
116 There are some complications.
118 (i) The @val_binds@ might mention variable not in @local_global_prs@.
119 In this case we need to make up new polymorphic versions of them.
121 (ii) Exactly the same applies to any @inst_binds@ which may be
122 present. However, here we expect that mostly they will be simple constant
123 definitions, which don't mention the type variables at all, so making them
124 polymorphic is really overkill. @dsInstBinds@ deals with this case.
127 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
128 = mapDs mk_poly_private_binder private_binders
129 `thenDs` \ poly_private_binders ->
131 full_local_global_prs = (private_binders `zip` poly_private_binders)
134 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
135 returnDs (local, app)
136 | (local,global) <- full_local_global_prs
139 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
143 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
144 extendEnvDs inst_env (
146 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
149 -- "private_binders" is the list of binders in val_binds
150 -- which don't appear in the local_global_prs list
151 -- These only really show up in stuff produced from compiling
152 -- class and instance declarations.
153 -- We need to add suitable polymorphic versions of them to the
155 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
156 binders = collectTypedBinders val_binds
157 mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
159 tyvar_tys = mkTyVarTys tyvars
163 %==============================================
164 \subsubsection{AbsBind case: overloading}
165 %==============================================
167 If there is overloading we go for the general case.
169 We want the global identifiers to be abstracted wrt all types and
170 dictionaries; and the local identifiers wrt the non-overloaded types.
171 That is, we try to avoid global scoping of type abstraction. Example
173 f :: Eq a => a -> [(a,b)] -> b
176 Here, f is fully polymorphic in b. So we generate
178 f ab d = let ...dict defns...
180 letrec f' b = ...(f' b)...
183 *Notice* that we don't clone type variables, and *do* make use of
184 shadowing. It is possible to do cloning, but it makes the code quite
185 a bit more complicated, and the simplifier will clone it all anyway.
187 Why bother with this gloss? Because it makes it more likely that
188 the defn of f' can get floated out, notably if f gets specialised
189 to a particular type for a.
192 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
193 = -- If there is any non-overloaded polymorphism, make new locals with
194 -- appropriate polymorphism
195 (if null non_overloaded_tyvars
197 -- No non-overloaded polymorphism, so stay with current envt
198 returnDs (id, [], [])
200 -- Some local, non-overloaded polymorphism
201 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
203 mapDs mk_binder binders `thenDs` \ new_binders ->
205 old_new_pairs = binders `zip` new_binders
208 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
210 | (old,new) <- old_new_pairs
211 ] `thenDs` \ extra_env ->
213 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
214 is_elem = isIn "dsBinds"
216 returnDs (lookupId old_new_pairs, extra_env, local_binds)
218 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
220 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
222 extendEnvDs local_env (
224 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
226 extendEnvDs inst_env (
228 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
229 )) `thenDs` \ core_binds ->
232 tuple_rhs = mkCoLetsAny core_binds (
233 mkCoLetsAny local_binds (
234 mkTupleExpr locals ))
236 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
238 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
240 locals = [local | (local,global) <- local_global_prs]
241 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
243 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
244 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
246 binders = collectTypedBinders val_binds
247 mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
250 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
251 However, sometimes id takes more type args than are in tys, and the
252 specialiser hates that, so we have to eta expand, to
253 @(/\ a b -> id tys a b)@.
256 mkSatTyApp :: Id -- Id to apply to the types
257 -> [Type] -- Types to apply it to
260 mkSatTyApp id [] = returnDs (Var id)
264 = returnDs ty_app -- Common case
266 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
267 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
269 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
270 ty_app = mkTyApp (Var id) tys
273 There are several places where we encounter ``inst binds,''
274 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
275 (a var to a var or literal), which we want to substitute away; so we
276 return both some desugared bindings {\em and} a substitution
277 environment for the subbed-away ones.
279 These dictionary bindings are non-recursive, and ordered, so that
280 later ones may mention earlier ones, but not vice versa.
283 dsInstBinds :: [TyVar] -- Abstract wrt these
284 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
285 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
286 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
288 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
289 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
291 dsInstBinds tyvars [] = returnDs do_nothing
293 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
294 = dsExpr expr `thenDs` \ rhs ->
295 let -- Need to apply dsExpr to the variable in case it
296 -- has a substitution in the current environment
297 subst_item = (inst, rhs)
299 extendEnvDs [subst_item] (
300 dsInstBinds tyvars bs
301 ) `thenDs` \ (binds, subst_env) ->
302 returnDs (binds, subst_item : subst_env)
304 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
305 = dsExpr expr `thenDs` \ core_lit ->
307 subst_item = (inst, core_lit)
309 extendEnvDs [subst_item] (
310 dsInstBinds tyvars bs
311 ) `thenDs` \ (binds, subst_env) ->
312 returnDs (binds, subst_item : subst_env)
314 dsInstBinds tyvars ((inst, expr) : bs)
316 = dsExpr expr `thenDs` \ core_expr ->
317 ds_dict_cc core_expr `thenDs` \ dict_expr ->
318 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
319 returnDs ((inst, dict_expr) : core_rest, subst_env)
323 -- The inst mentions the type vars wrt which we are abstracting,
324 -- so we have to invent a new polymorphic version, and substitute
326 -- This can occur in, for example:
327 -- leftPoll :: [FeedBack a] -> FeedBack a
328 -- leftPoll xs = take poll xs
329 -- Here there is an instance of take at the type of elts of xs,
330 -- as well as the type of poll.
332 dsExpr expr `thenDs` \ core_expr ->
333 ds_dict_cc core_expr `thenDs` \ dict_expr ->
334 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
336 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
338 extendEnvDs [subst_item] (
339 dsInstBinds tyvars bs
340 ) `thenDs` \ (core_rest, subst_env) ->
341 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
342 subst_item : subst_env)
344 inst_ty = idType inst
345 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
346 abs_tys = mkTyVarTys abs_tyvars
347 (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
349 ------------------------
350 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
351 -- appropriate. Uses "inst"'s type.
353 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
355 | not opt_SccProfilingOn ||
356 not (isDictTy inst_ty)
357 = returnDs expr -- that's easy: do nothing
359 | opt_CompilingPrelude
360 = returnDs (SCC prel_dicts_cc expr)
363 = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
364 -- ToDo: do -dicts-all flag (mark dict things
365 -- with individual CCs)
367 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
369 returnDs (SCC dict_cc expr)
372 %************************************************************************
374 \subsection[dsBind]{Desugaring a @Bind@}
376 %************************************************************************
378 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
379 some of the binders are of unboxed type.
381 For an explanation of the first three args, see @dsMonoBinds@.
384 dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
385 -> (Id -> Id) -- Binder substitution
386 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
390 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
391 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
393 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
394 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
395 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
397 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
398 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
399 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
403 %************************************************************************
405 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
407 %************************************************************************
409 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
410 In addition to desugaring pattern matching, @dsMonoBinds@ takes
411 a list of type variables and dicts, and adds abstractions for these
412 to the front of every binding. That requires that the
413 binders be altered too (their type has changed,
414 so @dsMonoBinds@ also takes a function which maps binders into binders.
415 This mapping gives the binder the correct new type.
417 Remember, there's also a substitution in the monad which maps occurrences
418 of these binders into applications of the new binder to suitable type variables
422 dsMonoBinds :: Bool -- True <=> recursive binding group
423 -> [TyVar] -> [DictVar] -- Abstract wrt these
424 -> (Id -> Id) -- Binder substitution
425 -> TypecheckedMonoBinds
426 -> DsM [(Id,CoreExpr)]
431 %==============================================
432 \subsubsection{Structure cases}
433 %==============================================
436 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
438 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
439 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
440 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
444 %==============================================
445 \subsubsection{Simple base cases: function and variable bindings}
446 %==============================================
448 For the simplest bindings, we just heave them in the substitution env:
451 {- THESE TWO ARE PLAIN WRONG.
452 The extendEnvDs only scopes over the nested call!
453 Let the simplifier do this.
455 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
456 | not (is_rec || isExported was_var)
457 = extendEnvDs [(was_var, Var new_var)] (
460 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
461 | not (isExported was_var)
462 = dsExpr expr `thenDs` ( \ core_lit ->
463 extendEnvDs [(was_var, core_lit)] (
467 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
468 = dsExpr expr `thenDs` \ core_expr ->
469 returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
473 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
476 new_fun = binder_subst fun
477 error_string = "function " ++ showForErr fun
479 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
481 mkLam tyvars (dicts ++ args) body)]
483 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
485 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
486 returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
489 %==============================================
490 \subsubsection{The general base case}
491 %==============================================
493 Now the general case of a pattern binding. The monomorphism restriction
494 should ensure that if there is a non-simple pattern binding in the
495 group, then there is no overloading involved, so the dictionaries should
496 be empty. (Simple pattern bindings were handled above.)
497 First, the paranoia check.
500 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
501 = panic "Non-empty dict list in for pattern binding"
504 We handle three cases for the binding
508 \item[pat has no binders.]
509 Then all this is dead code and we return an empty binding.
511 \item[pat has exactly one binder, v.]
512 Then we can transform to:
514 v' = /\ tyvars -> case rhs of { pat -> v }
516 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
518 \item[pat has more than one binder.]
519 Then we transform to:
521 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
523 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
528 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
531 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
533 {- KILLED by Sansom. 95/05
534 -- make *sure* there are no primitive types in the pattern
535 if any_con_w_prim_arg pat then
536 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
537 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
538 ++ "(We apologise for not reporting this more `cleanly')\n" )
540 -- Check whether the pattern already is a simple tuple; if so,
541 -- we can just use the rhs directly
544 mkSelectorBinds tyvars pat
545 [(binder, binder_subst binder) | binder <- pat_binders]
548 pat_binders = collectTypedPatBinders pat
549 -- NB For a simple tuple pattern, these binders
550 -- will appear in the right order!
553 Wild-card patterns could be made acceptable here, but it involves some
554 extra work to benefit only rather unusual constructs like
556 let (_,a,b) = ... in ...
558 Better to extend the whole thing for any irrefutable constructor, at least.