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, mkForAllTys, splitSigmaTy,
37 tyVarsOfType, tyVarsOfTypes
39 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
40 import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
41 import PprCore--ToDo:rm
42 import PprType--ToDo:rm
44 import Unique--ToDo:rm
46 isDictTy = panic "DsBinds.isDictTy"
49 %************************************************************************
51 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
53 %************************************************************************
55 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
56 that some of the binders are of unboxed type. This is sorted out when
57 the caller wraps the bindings round an expression.
60 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
63 All ``real'' bindings are expressed in terms of the
64 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
65 and its desugaring is the subject of section~9.1 in the static
70 AbsBinds [a1, ... ,aj] -- type variables
71 [d1, ... ,dk] -- dict variables
72 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
73 [db1=..., ..., dbn=...] -- dict binds
74 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
76 we want to make, in the general case (non-Fozzie translation):
81 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
83 -- a bunch of selectors:
84 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
86 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
88 But there are lots of special cases.
91 %==============================================
92 \subsubsection{Structure cases}
93 %==============================================
96 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
97 dsBinds EmptyBinds = returnDs []
98 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
100 dsBinds (ThenBinds binds_1 binds_2)
101 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
105 %==============================================
106 \subsubsection{AbsBind case: no overloading}
107 %==============================================
109 Special case: no overloading.
114 We abstract each wrt the type variables, giving
116 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
117 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
119 There are some complications.
121 (i) The @val_binds@ might mention variable not in @local_global_prs@.
122 In this case we need to make up new polymorphic versions of them.
124 (ii) Exactly the same applies to any @inst_binds@ which may be
125 present. However, here we expect that mostly they will be simple constant
126 definitions, which don't mention the type variables at all, so making them
127 polymorphic is really overkill. @dsInstBinds@ deals with this case.
130 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
131 = mapDs mk_poly_private_binder private_binders
132 `thenDs` \ poly_private_binders ->
134 full_local_global_prs = (private_binders `zip` poly_private_binders)
137 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
138 returnDs (local, app)
139 | (local,global) <- full_local_global_prs
142 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
146 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
147 extendEnvDs inst_env (
149 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
152 -- "private_binders" is the list of binders in val_binds
153 -- which don't appear in the local_global_prs list
154 -- These only really show up in stuff produced from compiling
155 -- class and instance declarations.
156 -- We need to add suitable polymorphic versions of them to the
158 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
159 binders = collectTypedBinders val_binds
160 mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
162 tyvar_tys = mkTyVarTys tyvars
166 %==============================================
167 \subsubsection{AbsBind case: overloading}
168 %==============================================
170 If there is overloading we go for the general case.
172 We want the global identifiers to be abstracted wrt all types and
173 dictionaries; and the local identifiers wrt the non-overloaded types.
174 That is, we try to avoid global scoping of type abstraction. Example
176 f :: Eq a => a -> [(a,b)] -> b
179 Here, f is fully polymorphic in b. So we generate
181 f ab d = let ...dict defns...
183 letrec f' b = ...(f' b)...
186 *Notice* that we don't clone type variables, and *do* make use of
187 shadowing. It is possible to do cloning, but it makes the code quite
188 a bit more complicated, and the simplifier will clone it all anyway.
190 Why bother with this gloss? Because it makes it more likely that
191 the defn of f' can get floated out, notably if f gets specialised
192 to a particular type for a.
195 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
196 = -- If there is any non-overloaded polymorphism, make new locals with
197 -- appropriate polymorphism
198 (if null non_overloaded_tyvars
200 -- No non-overloaded polymorphism, so stay with current envt
201 returnDs (id, [], [])
203 -- Some local, non-overloaded polymorphism
204 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
206 mapDs mk_binder binders `thenDs` \ new_binders ->
208 old_new_pairs = binders `zip` new_binders
211 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
213 | (old,new) <- old_new_pairs
214 ] `thenDs` \ extra_env ->
216 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
217 is_elem = isIn "dsBinds"
219 returnDs (lookupId old_new_pairs, extra_env, local_binds)
221 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
223 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
225 extendEnvDs local_env (
227 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
229 extendEnvDs inst_env (
231 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
232 )) `thenDs` \ core_binds ->
235 tuple_rhs = mkCoLetsAny core_binds (
236 mkCoLetsAny local_binds (
237 mkTupleExpr locals ))
239 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
241 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
243 locals = [local | (local,global) <- local_global_prs]
244 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
246 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
247 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
249 binders = collectTypedBinders val_binds
250 mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
253 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
254 However, sometimes id takes more type args than are in tys, and the
255 specialiser hates that, so we have to eta expand, to
256 @(/\ a b -> id tys a b)@.
259 mkSatTyApp :: Id -- Id to apply to the types
260 -> [Type] -- Types to apply it to
263 mkSatTyApp id [] = returnDs (Var id)
267 = returnDs ty_app -- Common case
269 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
270 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
272 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
273 ty_app = mkTyApp (Var id) tys
276 There are several places where we encounter ``inst binds,''
277 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
278 (a var to a var or literal), which we want to substitute away; so we
279 return both some desugared bindings {\em and} a substitution
280 environment for the subbed-away ones.
282 These dictionary bindings are non-recursive, and ordered, so that
283 later ones may mention earlier ones, but not vice versa.
286 dsInstBinds :: [TyVar] -- Abstract wrt these
287 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
288 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
289 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
291 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
292 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
294 dsInstBinds tyvars [] = returnDs do_nothing
296 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
297 = dsExpr expr `thenDs` \ rhs ->
298 let -- Need to apply dsExpr to the variable in case it
299 -- has a substitution in the current environment
300 subst_item = (inst, rhs)
302 extendEnvDs [subst_item] (
303 dsInstBinds tyvars bs
304 ) `thenDs` \ (binds, subst_env) ->
305 returnDs (binds, subst_item : subst_env)
307 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
308 = dsExpr expr `thenDs` \ core_lit ->
310 subst_item = (inst, core_lit)
312 extendEnvDs [subst_item] (
313 dsInstBinds tyvars bs
314 ) `thenDs` \ (binds, subst_env) ->
315 returnDs (binds, subst_item : subst_env)
317 dsInstBinds tyvars ((inst, expr) : bs)
319 = dsExpr expr `thenDs` \ core_expr ->
320 ds_dict_cc core_expr `thenDs` \ dict_expr ->
321 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
322 returnDs ((inst, dict_expr) : core_rest, subst_env)
326 -- The inst mentions the type vars wrt which we are abstracting,
327 -- so we have to invent a new polymorphic version, and substitute
329 -- This can occur in, for example:
330 -- leftPoll :: [FeedBack a] -> FeedBack a
331 -- leftPoll xs = take poll xs
332 -- Here there is an instance of take at the type of elts of xs,
333 -- as well as the type of poll.
335 dsExpr expr `thenDs` \ core_expr ->
336 ds_dict_cc core_expr `thenDs` \ dict_expr ->
337 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
339 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
341 extendEnvDs [subst_item] (
342 dsInstBinds tyvars bs
343 ) `thenDs` \ (core_rest, subst_env) ->
344 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
345 subst_item : subst_env)
347 inst_ty = idType inst
348 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
349 abs_tys = mkTyVarTys abs_tyvars
350 poly_inst_ty = mkForAllTys abs_tyvars inst_ty
352 ------------------------
353 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
354 -- appropriate. Uses "inst"'s type.
356 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
358 | not opt_SccProfilingOn ||
359 not (isDictTy inst_ty)
360 = returnDs expr -- that's easy: do nothing
362 | opt_CompilingPrelude
363 = returnDs (SCC prel_dicts_cc expr)
366 = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
367 -- ToDo: do -dicts-all flag (mark dict things
368 -- with individual CCs)
370 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
372 returnDs (SCC dict_cc expr)
375 %************************************************************************
377 \subsection[dsBind]{Desugaring a @Bind@}
379 %************************************************************************
381 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
382 some of the binders are of unboxed type.
384 For an explanation of the first three args, see @dsMonoBinds@.
387 dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
388 -> (Id -> Id) -- Binder substitution
389 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
393 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
394 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
396 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
397 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
398 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
400 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
401 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
402 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )
406 %************************************************************************
408 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
410 %************************************************************************
412 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
413 In addition to desugaring pattern matching, @dsMonoBinds@ takes
414 a list of type variables and dicts, and adds abstractions for these
415 to the front of every binding. That requires that the
416 binders be altered too (their type has changed,
417 so @dsMonoBinds@ also takes a function which maps binders into binders.
418 This mapping gives the binder the correct new type.
420 Remember, there's also a substitution in the monad which maps occurrences
421 of these binders into applications of the new binder to suitable type variables
425 dsMonoBinds :: Bool -- True <=> recursive binding group
426 -> [TyVar] -> [DictVar] -- Abstract wrt these
427 -> (Id -> Id) -- Binder substitution
428 -> TypecheckedMonoBinds
429 -> DsM [(Id,CoreExpr)]
434 %==============================================
435 \subsubsection{Structure cases}
436 %==============================================
439 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
441 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
442 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
443 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
447 %==============================================
448 \subsubsection{Simple base cases: function and variable bindings}
449 %==============================================
451 For the simplest bindings, we just heave them in the substitution env:
454 {- THESE TWO ARE PLAIN WRONG.
455 The extendEnvDs only scopes over the nested call!
456 Let the simplifier do this.
458 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var))
459 | not (is_rec || isExported was_var)
460 = extendEnvDs [(was_var, Var new_var)] (
463 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
464 | not (isExported was_var)
465 = dsExpr expr `thenDs` ( \ core_lit ->
466 extendEnvDs [(was_var, core_lit)] (
470 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
471 = dsExpr expr `thenDs` \ core_expr ->
472 returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
476 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
479 new_fun = binder_subst fun
480 error_string = "function " ++ showForErr fun
482 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
484 mkLam tyvars (dicts ++ args) body)]
486 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
488 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
489 returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
492 %==============================================
493 \subsubsection{The general base case}
494 %==============================================
496 Now the general case of a pattern binding. The monomorphism restriction
497 should ensure that if there is a non-simple pattern binding in the
498 group, then there is no overloading involved, so the dictionaries should
499 be empty. (Simple pattern bindings were handled above.)
500 First, the paranoia check.
503 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
504 = panic "Non-empty dict list in for pattern binding"
507 We handle three cases for the binding
511 \item[pat has no binders.]
512 Then all this is dead code and we return an empty binding.
514 \item[pat has exactly one binder, v.]
515 Then we can transform to:
517 v' = /\ tyvars -> case rhs of { pat -> v }
519 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
521 \item[pat has more than one binder.]
522 Then we transform to:
524 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
526 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
531 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
534 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
536 {- KILLED by Sansom. 95/05
537 -- make *sure* there are no primitive types in the pattern
538 if any_con_w_prim_arg pat then
539 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
540 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
541 ++ "(We apologise for not reporting this more `cleanly')\n" )
543 -- Check whether the pattern already is a simple tuple; if so,
544 -- we can just use the rhs directly
547 pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
549 mkSelectorBinds tyvars pat
550 [(binder, binder_subst binder) | binder <- pat_binders]
553 pat_binders = collectTypedPatBinders pat
554 -- NB For a simple tuple pattern, these binders
555 -- will appear in the right order!
558 Wild-card patterns could be made acceptable here, but it involves some
559 extra work to benefit only rather unusual constructs like
561 let (_,a,b) = ... in ...
563 Better to extend the whole thing for any irrefutable constructor, at least.