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 )
35 import PprStyle ( PprStyle(..) )
36 import Pretty ( ppShow )
37 import Type ( mkTyVarTys, splitSigmaTy,
38 tyVarsOfType, tyVarsOfTypes
40 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
41 import Util ( isIn, panic )
43 isDictTy = panic "DsBinds.isDictTy"
44 quantifyTy = panic "DsBinds.quantifyTy"
47 %************************************************************************
49 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
51 %************************************************************************
53 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
54 that some of the binders are of unboxed type. This is sorted out when
55 the caller wraps the bindings round an expression.
58 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
61 All ``real'' bindings are expressed in terms of the
62 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
63 and its desugaring is the subject of section~9.1 in the static
68 AbsBinds [a1, ... ,aj] -- type variables
69 [d1, ... ,dk] -- dict variables
70 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
71 [db1=..., ..., dbn=...] -- dict binds
72 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
74 we want to make, in the general case (non-Fozzie translation):
79 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
81 -- a bunch of selectors:
82 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
84 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
86 But there are lots of special cases.
89 %==============================================
90 \subsubsection{Structure cases}
91 %==============================================
94 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
95 dsBinds EmptyBinds = returnDs []
96 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
98 dsBinds (ThenBinds binds_1 binds_2)
99 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
103 %==============================================
104 \subsubsection{AbsBind case: no overloading}
105 %==============================================
107 Special case: no overloading.
112 We abstract each wrt the type variables, giving
114 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
115 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
117 There are some complications.
119 (i) The @val_binds@ might mention variable not in @local_global_prs@.
120 In this case we need to make up new polymorphic versions of them.
122 (ii) Exactly the same applies to any @inst_binds@ which may be
123 present. However, here we expect that mostly they will be simple constant
124 definitions, which don't mention the type variables at all, so making them
125 polymorphic is really overkill. @dsInstBinds@ deals with this case.
128 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
129 = mapDs mk_poly_private_binder private_binders
130 `thenDs` \ poly_private_binders ->
132 full_local_global_prs = (private_binders `zip` poly_private_binders)
135 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
136 returnDs (local, app)
137 | (local,global) <- full_local_global_prs
140 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
144 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
145 extendEnvDs inst_env (
147 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
150 -- "private_binders" is the list of binders in val_binds
151 -- which don't appear in the local_global_prs list
152 -- These only really show up in stuff produced from compiling
153 -- class and instance declarations.
154 -- We need to add suitable polymorphic versions of them to the
156 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
157 binders = collectTypedBinders val_binds
158 mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
160 tyvar_tys = mkTyVarTys tyvars
164 %==============================================
165 \subsubsection{AbsBind case: overloading}
166 %==============================================
168 If there is overloading we go for the general case.
170 We want the global identifiers to be abstracted wrt all types and
171 dictionaries; and the local identifiers wrt the non-overloaded types.
172 That is, we try to avoid global scoping of type abstraction. Example
174 f :: Eq a => a -> [(a,b)] -> b
177 Here, f is fully polymorphic in b. So we generate
179 f ab d = let ...dict defns...
181 letrec f' b = ...(f' b)...
184 *Notice* that we don't clone type variables, and *do* make use of
185 shadowing. It is possible to do cloning, but it makes the code quite
186 a bit more complicated, and the simplifier will clone it all anyway.
188 Why bother with this gloss? Because it makes it more likely that
189 the defn of f' can get floated out, notably if f gets specialised
190 to a particular type for a.
193 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
194 = -- If there is any non-overloaded polymorphism, make new locals with
195 -- appropriate polymorphism
196 (if null non_overloaded_tyvars
198 -- No non-overloaded polymorphism, so stay with current envt
199 returnDs (id, [], [])
201 -- Some local, non-overloaded polymorphism
202 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
204 mapDs mk_binder binders `thenDs` \ new_binders ->
206 old_new_pairs = binders `zip` new_binders
209 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
211 | (old,new) <- old_new_pairs
212 ] `thenDs` \ extra_env ->
214 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
215 is_elem = isIn "dsBinds"
217 returnDs (lookupId old_new_pairs, extra_env, local_binds)
219 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
221 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
223 extendEnvDs local_env (
225 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
227 extendEnvDs inst_env (
229 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
230 )) `thenDs` \ core_binds ->
233 tuple_rhs = mkCoLetsAny core_binds (
234 mkCoLetsAny local_binds (
235 mkTupleExpr locals ))
237 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
239 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
241 locals = [local | (local,global) <- local_global_prs]
242 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
244 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
245 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
247 binders = collectTypedBinders val_binds
248 mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
251 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
252 However, sometimes id takes more type args than are in tys, and the
253 specialiser hates that, so we have to eta expand, to
254 @(/\ a b -> id tys a b)@.
257 mkSatTyApp :: Id -- Id to apply to the types
258 -> [Type] -- Types to apply it to
261 mkSatTyApp id [] = returnDs (Var id)
265 = returnDs ty_app -- Common case
267 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
268 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
270 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
271 ty_app = mkTyApp (Var id) tys
274 There are several places where we encounter ``inst binds,''
275 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
276 (a var to a var or literal), which we want to substitute away; so we
277 return both some desugared bindings {\em and} a substitution
278 environment for the subbed-away ones.
280 These dictionary bindings are non-recursive, and ordered, so that
281 later ones may mention earlier ones, but not vice versa.
284 dsInstBinds :: [TyVar] -- Abstract wrt these
285 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
286 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
287 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
289 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
290 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
292 dsInstBinds tyvars [] = returnDs do_nothing
294 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
295 = dsExpr expr `thenDs` \ rhs ->
296 let -- Need to apply dsExpr to the variable in case it
297 -- has a substitution in the current environment
298 subst_item = (inst, rhs)
300 extendEnvDs [subst_item] (
301 dsInstBinds tyvars bs
302 ) `thenDs` \ (binds, subst_env) ->
303 returnDs (binds, subst_item : subst_env)
305 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
306 = dsExpr expr `thenDs` \ core_lit ->
308 subst_item = (inst, core_lit)
310 extendEnvDs [subst_item] (
311 dsInstBinds tyvars bs
312 ) `thenDs` \ (binds, subst_env) ->
313 returnDs (binds, subst_item : subst_env)
315 dsInstBinds tyvars ((inst, expr) : bs)
317 = dsExpr expr `thenDs` \ core_expr ->
318 ds_dict_cc core_expr `thenDs` \ dict_expr ->
319 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
320 returnDs ((inst, dict_expr) : core_rest, subst_env)
324 -- The inst mentions the type vars wrt which we are abstracting,
325 -- so we have to invent a new polymorphic version, and substitute
327 -- This can occur in, for example:
328 -- leftPoll :: [FeedBack a] -> FeedBack a
329 -- leftPoll xs = take poll xs
330 -- Here there is an instance of take at the type of elts of xs,
331 -- as well as the type of poll.
333 dsExpr expr `thenDs` \ core_expr ->
334 ds_dict_cc core_expr `thenDs` \ dict_expr ->
335 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
337 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
339 extendEnvDs [subst_item] (
340 dsInstBinds tyvars bs
341 ) `thenDs` \ (core_rest, subst_env) ->
342 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
343 subst_item : subst_env)
345 inst_ty = idType inst
346 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
347 abs_tys = mkTyVarTys abs_tyvars
348 (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
350 ------------------------
351 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
352 -- appropriate. Uses "inst"'s type.
354 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
356 | not opt_SccProfilingOn ||
357 not (isDictTy inst_ty)
358 = returnDs expr -- that's easy: do nothing
360 | opt_CompilingPrelude
361 = returnDs (SCC prel_dicts_cc expr)
364 = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
365 -- ToDo: do -dicts-all flag (mark dict things
366 -- with individual CCs)
368 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
370 returnDs (SCC dict_cc expr)
373 %************************************************************************
375 \subsection[dsBind]{Desugaring a @Bind@}
377 %************************************************************************
379 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
380 some of the binders are of unboxed type.
382 For an explanation of the first three args, see @dsMonoBinds@.
385 dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
386 -> (Id -> Id) -- Binder substitution
387 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
391 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
392 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
394 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
395 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
396 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
398 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
399 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
400 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
404 %************************************************************************
406 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
408 %************************************************************************
410 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
411 In addition to desugaring pattern matching, @dsMonoBinds@ takes
412 a list of type variables and dicts, and adds abstractions for these
413 to the front of every binding. That requires that the
414 binders be altered too (their type has changed,
415 so @dsMonoBinds@ also takes a function which maps binders into binders.
416 This mapping gives the binder the correct new type.
418 Remember, there's also a substitution in the monad which maps occurrences
419 of these binders into applications of the new binder to suitable type variables
423 dsMonoBinds :: Bool -- True <=> recursive binding group
424 -> [TyVar] -> [DictVar] -- Abstract wrt these
425 -> (Id -> Id) -- Binder substitution
426 -> TypecheckedMonoBinds
427 -> DsM [(Id,CoreExpr)]
432 %==============================================
433 \subsubsection{Structure cases}
434 %==============================================
437 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
439 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
440 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
441 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
445 %==============================================
446 \subsubsection{Simple base cases: function and variable bindings}
447 %==============================================
449 For the simplest bindings, we just heave them in the substitution env:
452 {- THESE TWO ARE PLAIN WRONG.
453 The extendEnvDs only scopes over the nested call!
454 Let the simplifier do this.
456 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
457 | not (is_rec || isExported was_var)
458 = extendEnvDs [(was_var, Var new_var)] (
461 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
462 | not (isExported was_var)
463 = dsExpr expr `thenDs` ( \ core_lit ->
464 extendEnvDs [(was_var, core_lit)] (
468 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
469 = dsExpr expr `thenDs` \ core_expr ->
470 returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
474 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
477 new_fun = binder_subst fun
479 matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
481 mkLam tyvars (dicts ++ args) body)]
484 error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
485 ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
487 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
489 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
490 returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
494 %==============================================
495 \subsubsection{The general base case}
496 %==============================================
498 Now the general case of a pattern binding. The monomorphism restriction
499 should ensure that if there is a non-simple pattern binding in the
500 group, then there is no overloading involved, so the dictionaries should
501 be empty. (Simple pattern bindings were handled above.)
502 First, the paranoia check.
505 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
506 = panic "Non-empty dict list in for pattern binding"
509 We handle three cases for the binding
513 \item[pat has no binders.]
514 Then all this is dead code and we return an empty binding.
516 \item[pat has exactly one binder, v.]
517 Then we can transform to:
519 v' = /\ tyvars -> case rhs of { pat -> v }
521 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
523 \item[pat has more than one binder.]
524 Then we transform to:
526 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
528 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
533 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
536 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
538 {- KILLED by Sansom. 95/05
539 -- make *sure* there are no primitive types in the pattern
540 if any_con_w_prim_arg pat then
541 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
542 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
543 ++ "(We apologise for not reporting this more `cleanly')\n" )
545 -- Check whether the pattern already is a simple tuple; if so,
546 -- we can just use the rhs directly
549 mkSelectorBinds tyvars pat
550 [(binder, binder_subst binder) | binder <- pat_binders]
554 pat_binders = collectTypedPatBinders pat
555 -- NB For a simple tuple pattern, these binders
556 -- will appear in the right order!
559 Wild-card patterns could be made acceptable here, but it involves some
560 extra work to benefit only rather unusual constructs like
562 let (_,a,b) = ... in ...
564 Better to extend the whole thing for any irrefutable constructor, at least.