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 CoreUtils ( escErrorMsg )
31 import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
32 import Id ( idType, DictVar(..), GenId )
33 import ListSetOps ( minusList, intersectLists )
34 import PprType ( GenType, GenTyVar )
35 import PprStyle ( PprStyle(..) )
36 import Pretty ( ppShow )
37 import Type ( mkTyVarTys, splitSigmaTy,
38 tyVarsOfType, tyVarsOfTypes
40 import TyVar ( tyVarSetToList, GenTyVar )
41 import Unique ( Unique )
42 import Util ( isIn, panic )
44 isDictTy = panic "DsBinds.isDictTy"
45 quantifyTy = panic "DsBinds.quantifyTy"
48 %************************************************************************
50 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
52 %************************************************************************
54 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
55 that some of the binders are of unboxed type. This is sorted out when
56 the caller wraps the bindings round an expression.
59 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
62 All ``real'' bindings are expressed in terms of the
63 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
64 and its desugaring is the subject of section~9.1 in the static
69 AbsBinds [a1, ... ,aj] -- type variables
70 [d1, ... ,dk] -- dict variables
71 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
72 [db1=..., ..., dbn=...] -- dict binds
73 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
75 we want to make, in the general case (non-Fozzie translation):
80 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
82 -- a bunch of selectors:
83 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
85 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
87 But there are lots of special cases.
90 %==============================================
91 \subsubsection{Structure cases}
92 %==============================================
95 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
96 dsBinds EmptyBinds = returnDs []
97 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
99 dsBinds (ThenBinds binds_1 binds_2)
100 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
104 %==============================================
105 \subsubsection{AbsBind case: no overloading}
106 %==============================================
108 Special case: no overloading.
113 We abstract each wrt the type variables, giving
115 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
116 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
118 There are some complications.
120 (i) The @val_binds@ might mention variable not in @local_global_prs@.
121 In this case we need to make up new polymorphic versions of them.
123 (ii) Exactly the same applies to any @inst_binds@ which may be
124 present. However, here we expect that mostly they will be simple constant
125 definitions, which don't mention the type variables at all, so making them
126 polymorphic is really overkill. @dsInstBinds@ deals with this case.
129 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
130 = mapDs mk_poly_private_binder private_binders
131 `thenDs` \ poly_private_binders ->
133 full_local_global_prs = (private_binders `zip` poly_private_binders)
136 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
137 returnDs (local, app)
138 | (local,global) <- full_local_global_prs
141 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
145 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
146 extendEnvDs inst_env (
148 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
151 -- "private_binders" is the list of binders in val_binds
152 -- which don't appear in the local_global_prs list
153 -- These only really show up in stuff produced from compiling
154 -- class and instance declarations.
155 -- We need to add suitable polymorphic versions of them to the
157 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
158 binders = collectTypedBinders val_binds
159 mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
161 tyvar_tys = mkTyVarTys tyvars
165 %==============================================
166 \subsubsection{AbsBind case: overloading}
167 %==============================================
169 If there is overloading we go for the general case.
171 We want the global identifiers to be abstracted wrt all types and
172 dictionaries; and the local identifiers wrt the non-overloaded types.
173 That is, we try to avoid global scoping of type abstraction. Example
175 f :: Eq a => a -> [(a,b)] -> b
178 Here, f is fully polymorphic in b. So we generate
180 f ab d = let ...dict defns...
182 letrec f' b = ...(f' b)...
185 *Notice* that we don't clone type variables, and *do* make use of
186 shadowing. It is possible to do cloning, but it makes the code quite
187 a bit more complicated, and the simplifier will clone it all anyway.
189 Why bother with this gloss? Because it makes it more likely that
190 the defn of f' can get floated out, notably if f gets specialised
191 to a particular type for a.
194 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
195 = -- If there is any non-overloaded polymorphism, make new locals with
196 -- appropriate polymorphism
197 (if null non_overloaded_tyvars
199 -- No non-overloaded polymorphism, so stay with current envt
200 returnDs (id, [], [])
202 -- Some local, non-overloaded polymorphism
203 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
205 mapDs mk_binder binders `thenDs` \ new_binders ->
207 old_new_pairs = binders `zip` new_binders
210 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
212 | (old,new) <- old_new_pairs
213 ] `thenDs` \ extra_env ->
215 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
216 is_elem = isIn "dsBinds"
218 returnDs (lookupId old_new_pairs, extra_env, local_binds)
220 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
222 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
224 extendEnvDs local_env (
226 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
228 extendEnvDs inst_env (
230 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
231 )) `thenDs` \ core_binds ->
234 tuple_rhs = mkCoLetsAny core_binds (
235 mkCoLetsAny local_binds (
236 mkTupleExpr locals ))
238 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
240 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
242 locals = [local | (local,global) <- local_global_prs]
243 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
245 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
246 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
248 binders = collectTypedBinders val_binds
249 mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
252 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
253 However, sometimes id takes more type args than are in tys, and the
254 specialiser hates that, so we have to eta expand, to
255 @(/\ a b -> id tys a b)@.
258 mkSatTyApp :: Id -- Id to apply to the types
259 -> [Type] -- Types to apply it to
262 mkSatTyApp id [] = returnDs (Var id)
266 = returnDs ty_app -- Common case
268 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
269 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
271 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
272 ty_app = mkTyApp (Var id) tys
275 There are several places where we encounter ``inst binds,''
276 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
277 (a var to a var or literal), which we want to substitute away; so we
278 return both some desugared bindings {\em and} a substitution
279 environment for the subbed-away ones.
281 These dictionary bindings are non-recursive, and ordered, so that
282 later ones may mention earlier ones, but not vice versa.
285 dsInstBinds :: [TyVar] -- Abstract wrt these
286 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
287 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
288 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
290 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
291 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
293 dsInstBinds tyvars []
294 = returnDs do_nothing
296 dsInstBinds _ _ = panic "DsBinds.dsInstBinds:maybe we want something different?"
300 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
301 = dsExpr expr `thenDs` ( \ rhs ->
302 let -- Need to apply dsExpr to the variable in case it
303 -- has a substitution in the current environment
304 subst_item = (inst, rhs)
306 extendEnvDs [subst_item] (
307 dsInstBinds tyvars bs
308 ) `thenDs` (\ (binds, subst_env) ->
309 returnDs (binds, subst_item : subst_env)
312 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
313 = dsExpr expr `thenDs` ( \ core_lit ->
315 subst_item = (inst, core_lit)
317 extendEnvDs [subst_item] (
318 dsInstBinds tyvars bs
319 ) `thenDs` (\ (binds, subst_env) ->
320 returnDs (binds, subst_item : subst_env)
323 dsInstBinds tyvars ((inst, expr) : bs)
325 = dsExpr expr `thenDs` \ core_expr ->
326 ds_dict_cc core_expr `thenDs` \ dict_expr ->
327 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
328 returnDs ((inst, dict_expr) : core_rest, subst_env)
332 -- The inst mentions the type vars wrt which we are abstracting,
333 -- so we have to invent a new polymorphic version, and substitute
335 -- This can occur in, for example:
336 -- leftPoll :: [FeedBack a] -> FeedBack a
337 -- leftPoll xs = take poll xs
338 -- Here there is an instance of take at the type of elts of xs,
339 -- as well as the type of poll.
341 dsExpr expr `thenDs` \ core_expr ->
342 ds_dict_cc core_expr `thenDs` \ dict_expr ->
343 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
345 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
347 extendEnvDs [subst_item] (
348 dsInstBinds tyvars bs
349 ) `thenDs` \ (core_rest, subst_env) ->
350 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
351 subst_item : subst_env)
353 inst_ty = idType inst
354 abs_tyvars = tyVarsOfType inst_ty `intersectLists` tyvars
355 abs_tys = mkTyVarTys abs_tyvars
356 (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
358 ------------------------
359 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
360 -- appropriate. Uses "inst"'s type.
363 = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
365 doing_profiling = opt_SccProfilingOn
366 compiling_prelude = opt_CompilingPrelude
368 if not doing_profiling
369 || not (isDictTy inst_ty) then -- that's easy: do nothing
371 else if compiling_prelude then
372 returnDs (SCC prel_dicts_cc expr)
374 getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
375 -- ToDo: do -dicts-all flag (mark dict things
376 -- with individual CCs)
378 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
380 returnDs (SCC dict_cc expr)
384 %************************************************************************
386 \subsection[dsBind]{Desugaring a @Bind@}
388 %************************************************************************
390 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
391 some of the binders are of unboxed type.
393 For an explanation of the first three args, see @dsMonoBinds@.
396 dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
397 -> (Id -> Id) -- Binder substitution
398 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
402 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
403 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
405 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
406 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
407 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
409 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
410 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
411 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
415 %************************************************************************
417 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
419 %************************************************************************
421 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
422 In addition to desugaring pattern matching, @dsMonoBinds@ takes
423 a list of type variables and dicts, and adds abstractions for these
424 to the front of every binding. That requires that the
425 binders be altered too (their type has changed,
426 so @dsMonoBinds@ also takes a function which maps binders into binders.
427 This mapping gives the binder the correct new type.
429 Remember, there's also a substitution in the monad which maps occurrences
430 of these binders into applications of the new binder to suitable type variables
434 dsMonoBinds :: Bool -- True <=> recursive binding group
435 -> [TyVar] -> [DictVar] -- Abstract wrt these
436 -> (Id -> Id) -- Binder substitution
437 -> TypecheckedMonoBinds
438 -> DsM [(Id,CoreExpr)]
443 %==============================================
444 \subsubsection{Structure cases}
445 %==============================================
448 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
450 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
451 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
452 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
456 %==============================================
457 \subsubsection{Simple base cases: function and variable bindings}
458 %==============================================
460 For the simplest bindings, we just heave them in the substitution env:
463 {- THESE TWO ARE PLAIN WRONG.
464 The extendEnvDs only scopes over the nested call!
465 Let the simplifier do this.
467 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
468 | not (is_rec || isExported was_var)
469 = extendEnvDs [(was_var, Var new_var)] (
472 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
473 | not (isExported was_var)
474 = dsExpr expr `thenDs` ( \ core_lit ->
475 extendEnvDs [(was_var, core_lit)] (
479 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
480 = dsExpr expr `thenDs` \ core_expr ->
481 returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
485 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
488 new_fun = binder_subst fun
490 matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
492 mkLam tyvars (dicts ++ args) body)]
495 error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
496 ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
498 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
500 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
501 returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
505 %==============================================
506 \subsubsection{The general base case}
507 %==============================================
509 Now the general case of a pattern binding. The monomorphism restriction
510 should ensure that if there is a non-simple pattern binding in the
511 group, then there is no overloading involved, so the dictionaries should
512 be empty. (Simple pattern bindings were handled above.)
513 First, the paranoia check.
516 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
517 = panic "Non-empty dict list in for pattern binding"
520 We handle three cases for the binding
524 \item[pat has no binders.]
525 Then all this is dead code and we return an empty binding.
527 \item[pat has exactly one binder, v.]
528 Then we can transform to:
530 v' = /\ tyvars -> case rhs of { pat -> v }
532 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
534 \item[pat has more than one binder.]
535 Then we transform to:
537 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
539 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
544 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
547 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
549 {- KILLED by Sansom. 95/05
550 -- make *sure* there are no primitive types in the pattern
551 if any_con_w_prim_arg pat then
552 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
553 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
554 ++ "(We apologise for not reporting this more `cleanly')\n" )
556 -- Check whether the pattern already is a simple tuple; if so,
557 -- we can just use the rhs directly
560 mkSelectorBinds tyvars pat
561 [(binder, binder_subst binder) | binder <- pat_binders]
565 pat_binders = collectTypedPatBinders pat
566 -- NB For a simple tuple pattern, these binders
567 -- will appear in the right order!
570 Wild-card patterns could be made acceptable here, but it involves some
571 extra work to benefit only rather unusual constructs like
573 let (_,a,b) = ... in ...
575 Better to extend the whole thing for any irrefutable constructor, at least.