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_DELOOPER(DsLoop) -- break dsExpr-ish loop
18 import HsSyn -- lots of things
19 hiding ( collectBinders{-also in CoreSyn-} )
20 import CoreSyn -- lots of things
21 import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
22 SYN_IE(TypecheckedBind), SYN_IE(TypecheckedMonoBinds),
23 SYN_IE(TypecheckedPat)
25 import DsHsSyn ( collectTypedBinders, collectTypedPatBinders )
28 import DsGRHSs ( dsGuarded )
30 import Match ( matchWrapper )
32 import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
33 opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
34 import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
35 import Id ( idType, SYN_IE(DictVar), GenId )
36 import ListSetOps ( minusList, intersectLists )
37 import Name ( isExported )
38 import PprType ( GenType )
39 import PprStyle ( PprStyle(..) )
40 import Pretty ( ppShow )
41 import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
42 tyVarsOfType, tyVarsOfTypes, isDictTy
44 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
45 import Util ( isIn, panic{-, pprTrace ToDo:rm-} )
46 --import PprCore--ToDo:rm
47 --import PprType ( GenTyVar ) --ToDo:rm
48 --import Usage--ToDo:rm
49 --import Unique--ToDo:rm
52 %************************************************************************
54 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
56 %************************************************************************
58 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
59 that some of the binders are of unboxed type. This is sorted out when
60 the caller wraps the bindings round an expression.
63 dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
66 All ``real'' bindings are expressed in terms of the
67 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
68 and its desugaring is the subject of section~9.1 in the static
73 AbsBinds [a1, ... ,aj] -- type variables
74 [d1, ... ,dk] -- dict variables
75 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
76 [db1=..., ..., dbn=...] -- dict binds
77 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
79 we want to make, in the general case (non-Fozzie translation):
84 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
86 -- a bunch of selectors:
87 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
89 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
91 But there are lots of special cases.
94 %==============================================
95 \subsubsection{Structure cases}
96 %==============================================
99 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
100 dsBinds EmptyBinds = returnDs []
101 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
103 dsBinds (ThenBinds binds_1 binds_2)
104 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
108 %==============================================
109 \subsubsection{AbsBind case: no overloading}
110 %==============================================
112 Special case: no overloading.
117 We abstract each wrt the type variables, giving
119 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
120 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
122 There are some complications.
124 (i) The @val_binds@ might mention variable not in @local_global_prs@.
125 In this case we need to make up new polymorphic versions of them.
127 (ii) Exactly the same applies to any @inst_binds@ which may be
128 present. However, here we expect that mostly they will be simple constant
129 definitions, which don't mention the type variables at all, so making them
130 polymorphic is really overkill. @dsInstBinds@ deals with this case.
133 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
134 = mapDs mk_poly_private_binder private_binders
135 `thenDs` \ poly_private_binders ->
137 full_local_global_prs = (private_binders `zip` poly_private_binders)
140 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
141 returnDs (local, app)
142 | (local,global) <- full_local_global_prs
145 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
149 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
150 extendEnvDs inst_env (
152 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
155 -- "private_binders" is the list of binders in val_binds
156 -- which don't appear in the local_global_prs list
157 -- These only really show up in stuff produced from compiling
158 -- class and instance declarations.
159 -- We need to add suitable polymorphic versions of them to the
161 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
162 binders = collectTypedBinders val_binds
163 mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
165 tyvar_tys = mkTyVarTys tyvars
169 %==============================================
170 \subsubsection{AbsBind case: overloading}
171 %==============================================
173 If there is overloading we go for the general case.
175 We want the global identifiers to be abstracted wrt all types and
176 dictionaries; and the local identifiers wrt the non-overloaded types.
177 That is, we try to avoid global scoping of type abstraction. Example
179 f :: Eq a => a -> [(a,b)] -> b
182 Here, f is fully polymorphic in b. So we generate
184 f ab d = let ...dict defns...
186 letrec f' b = ...(f' b)...
189 *Notice* that we don't clone type variables, and *do* make use of
190 shadowing. It is possible to do cloning, but it makes the code quite
191 a bit more complicated, and the simplifier will clone it all anyway.
193 Why bother with this gloss? Because it makes it more likely that
194 the defn of f' can get floated out, notably if f gets specialised
195 to a particular type for a.
198 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
199 = -- If there is any non-overloaded polymorphism, make new locals with
200 -- appropriate polymorphism
201 (if null non_overloaded_tyvars
203 -- No non-overloaded polymorphism, so stay with current envt
204 returnDs (id, [], [])
206 -- Some local, non-overloaded polymorphism
207 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
209 mapDs mk_binder binders `thenDs` \ new_binders ->
211 old_new_pairs = binders `zip` new_binders
214 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
216 | (old,new) <- old_new_pairs
217 ] `thenDs` \ extra_env ->
219 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
220 is_elem = isIn "dsBinds"
222 returnDs (lookupId old_new_pairs, extra_env, local_binds)
224 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
226 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
228 extendEnvDs local_env (
230 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
232 extendEnvDs inst_env (
234 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
235 )) `thenDs` \ core_binds ->
238 tuple_rhs = mkCoLetsAny core_binds (
239 mkCoLetsAny local_binds (
240 mkTupleExpr locals ))
242 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
244 returnDs (mk_result_bind core_bind_prs)
246 locals = [local | (local,global) <- local_global_prs]
247 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
249 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
250 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
252 binders = collectTypedBinders val_binds
253 mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
255 is_rec_bind = case val_binds of
257 NonRecBind _ -> False
259 -- Recursion can still be needed if there are type signatures
260 mk_result_bind prs | is_rec_bind = [Rec prs]
261 | otherwise = [NonRec binder rhs | (binder,rhs) <- prs]
264 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
265 However, sometimes id takes more type args than are in tys, and the
266 specialiser hates that, so we have to eta expand, to
267 @(/\ a b -> id tys a b)@.
270 mkSatTyApp :: Id -- Id to apply to the types
271 -> [Type] -- Types to apply it to
274 mkSatTyApp id [] = returnDs (Var id)
278 = returnDs ty_app -- Common case
280 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
281 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
283 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
284 ty_app = mkTyApp (Var id) tys
287 There are several places where we encounter ``inst binds,''
288 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
289 (a var to a var or literal), which we want to substitute away; so we
290 return both some desugared bindings {\em and} a substitution
291 environment for the subbed-away ones.
293 These dictionary bindings are non-recursive, and ordered, so that
294 later ones may mention earlier ones, but not vice versa.
297 dsInstBinds :: [TyVar] -- Abstract wrt these
298 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
299 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
300 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
302 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
303 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
305 dsInstBinds tyvars [] = returnDs do_nothing
307 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
308 = dsExpr expr `thenDs` \ rhs ->
309 let -- Need to apply dsExpr to the variable in case it
310 -- has a substitution in the current environment
311 subst_item = (inst, rhs)
313 extendEnvDs [subst_item] (
314 dsInstBinds tyvars bs
315 ) `thenDs` \ (binds, subst_env) ->
316 returnDs (binds, subst_item : subst_env)
318 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
319 = dsExpr expr `thenDs` \ core_lit ->
321 subst_item = (inst, core_lit)
323 extendEnvDs [subst_item] (
324 dsInstBinds tyvars bs
325 ) `thenDs` \ (binds, subst_env) ->
326 returnDs (binds, subst_item : subst_env)
328 dsInstBinds tyvars ((inst, expr) : bs)
330 = dsExpr expr `thenDs` \ core_expr ->
331 ds_dict_cc core_expr `thenDs` \ dict_expr ->
332 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
333 returnDs ((inst, dict_expr) : core_rest, subst_env)
337 -- The inst mentions the type vars wrt which we are abstracting,
338 -- so we have to invent a new polymorphic version, and substitute
340 -- This can occur in, for example:
341 -- leftPoll :: [FeedBack a] -> FeedBack a
342 -- leftPoll xs = take poll xs
343 -- Here there is an instance of take at the type of elts of xs,
344 -- as well as the type of poll.
346 dsExpr expr `thenDs` \ core_expr ->
347 ds_dict_cc core_expr `thenDs` \ dict_expr ->
348 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
350 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
352 extendEnvDs [subst_item] (
353 dsInstBinds tyvars bs
354 ) `thenDs` \ (core_rest, subst_env) ->
355 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
356 subst_item : subst_env)
358 inst_ty = idType inst
359 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
360 abs_tys = mkTyVarTys abs_tyvars
361 poly_inst_ty = mkForAllTys abs_tyvars inst_ty
363 ------------------------
364 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
365 -- appropriate. Uses "inst"'s type.
367 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
369 | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
370 -- the latter is so that -unprof-auto-scc-all adds dict sccs
371 || not (isDictTy inst_ty)
372 = returnDs expr -- that's easy: do nothing
374 | opt_CompilingGhcInternals
375 = returnDs (SCC prel_dicts_cc expr)
378 = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
380 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
382 returnDs (SCC (mkAllDictsCC mod grp False) expr)
385 %************************************************************************
387 \subsection[dsBind]{Desugaring a @Bind@}
389 %************************************************************************
391 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
392 some of the binders are of unboxed type.
394 For an explanation of the first three args, see @dsMonoBinds@.
397 dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
398 -> (Id -> Id) -- Binder substitution
399 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
403 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
404 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
406 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
407 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
408 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
410 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
411 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
412 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
416 %************************************************************************
418 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
420 %************************************************************************
422 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
423 In addition to desugaring pattern matching, @dsMonoBinds@ takes
424 a list of type variables and dicts, and adds abstractions for these
425 to the front of every binding. That requires that the
426 binders be altered too (their type has changed,
427 so @dsMonoBinds@ also takes a function which maps binders into binders.
428 This mapping gives the binder the correct new type.
430 Remember, there's also a substitution in the monad which maps occurrences
431 of these binders into applications of the new binder to suitable type variables
435 dsMonoBinds :: Bool -- True <=> recursive binding group
436 -> [TyVar] -> [DictVar] -- Abstract wrt these
437 -> (Id -> Id) -- Binder substitution
438 -> TypecheckedMonoBinds
439 -> DsM [(Id,CoreExpr)]
444 %==============================================
445 \subsubsection{Structure cases}
446 %==============================================
449 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
451 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
452 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
453 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
457 %==============================================
458 \subsubsection{Simple base cases: function and variable bindings}
459 %==============================================
462 dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
463 = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
465 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
466 = dsExpr expr `thenDs` \ core_expr ->
467 returnDs [(binder_subst var, mkLam tyvars dicts core_expr)]
469 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
472 new_fun = binder_subst fun
473 error_string = "function " ++ showForErr fun
475 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
477 mkLam tyvars (dicts ++ args) body)]
479 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
481 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
482 returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
485 %==============================================
486 \subsubsection{The general base case}
487 %==============================================
489 Now the general case of a pattern binding. The monomorphism restriction
490 should ensure that if there is a non-simple pattern binding in the
491 group, then there is no overloading involved, so the dictionaries should
492 be empty. (Simple pattern bindings were handled above.)
493 First, the paranoia check.
496 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
497 = panic "Non-empty dict list in for pattern binding"
500 We handle three cases for the binding
504 \item[pat has no binders.]
505 Then all this is dead code and we return an empty binding.
507 \item[pat has exactly one binder, v.]
508 Then we can transform to:
510 v' = /\ tyvars -> case rhs of { pat -> v }
512 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
514 \item[pat has more than one binder.]
515 Then we transform to:
517 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
519 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
524 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
527 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
529 {- KILLED by Sansom. 95/05
530 -- make *sure* there are no primitive types in the pattern
531 if any_con_w_prim_arg pat then
532 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
533 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
534 ++ "(We apologise for not reporting this more `cleanly')\n" )
536 -- Check whether the pattern already is a simple tuple; if so,
537 -- we can just use the rhs directly
540 -- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
542 mkSelectorBinds tyvars pat
543 [(binder, binder_subst binder) | binder <- pat_binders]
546 pat_binders = collectTypedPatBinders pat
547 -- NB For a simple tuple pattern, these binders
548 -- will appear in the right order!
551 Wild-card patterns could be made acceptable here, but it involves some
552 extra work to benefit only rather unusual constructs like
554 let (_,a,b) = ... in ...
556 Better to extend the whole thing for any irrefutable constructor, at least.