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, opt_CompilingGhcInternals )
33 import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
34 import Id ( idType, SYN_IE(DictVar), GenId )
35 import ListSetOps ( minusList, intersectLists )
36 import Name ( isExported )
37 import PprType ( GenType )
38 import PprStyle ( PprStyle(..) )
39 import Pretty ( ppShow )
40 import Type ( mkTyVarTys, mkForAllTys, splitSigmaTy,
41 tyVarsOfType, tyVarsOfTypes, isDictTy
43 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
44 import Util ( isIn, panic{-, pprTrace ToDo:rm-} )
45 --import PprCore--ToDo:rm
46 --import PprType ( GenTyVar ) --ToDo:rm
47 --import Usage--ToDo:rm
48 --import Unique--ToDo:rm
51 %************************************************************************
53 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
55 %************************************************************************
57 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
58 that some of the binders are of unboxed type. This is sorted out when
59 the caller wraps the bindings round an expression.
62 dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
65 All ``real'' bindings are expressed in terms of the
66 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
67 and its desugaring is the subject of section~9.1 in the static
72 AbsBinds [a1, ... ,aj] -- type variables
73 [d1, ... ,dk] -- dict variables
74 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
75 [db1=..., ..., dbn=...] -- dict binds
76 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
78 we want to make, in the general case (non-Fozzie translation):
83 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
85 -- a bunch of selectors:
86 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
88 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
90 But there are lots of special cases.
93 %==============================================
94 \subsubsection{Structure cases}
95 %==============================================
98 dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith"
99 dsBinds auto_scc EmptyBinds = returnDs []
100 dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind
102 dsBinds auto_scc (ThenBinds binds_1 binds_2)
103 = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
107 %==============================================
108 \subsubsection{AbsBind case: no overloading}
109 %==============================================
111 Special case: no overloading.
116 We abstract each wrt the type variables, giving
118 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
119 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
121 There are some complications.
123 (i) The @val_binds@ might mention variable not in @local_global_prs@.
124 In this case we need to make up new polymorphic versions of them.
126 (ii) Exactly the same applies to any @inst_binds@ which may be
127 present. However, here we expect that mostly they will be simple constant
128 definitions, which don't mention the type variables at all, so making them
129 polymorphic is really overkill. @dsInstBinds@ deals with this case.
132 dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
133 = mapDs mk_poly_private_binder private_binders
134 `thenDs` \ poly_private_binders ->
136 full_local_global_prs = (private_binders `zip` poly_private_binders)
139 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
140 returnDs (local, app)
141 | (local,global) <- full_local_global_prs
144 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
148 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
149 extendEnvDs inst_env (
151 dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
154 -- "private_binders" is the list of binders in val_binds
155 -- which don't appear in the local_global_prs list
156 -- These only really show up in stuff produced from compiling
157 -- class and instance declarations.
158 -- We need to add suitable polymorphic versions of them to the
160 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
161 binders = collectTypedBinders val_binds
162 mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
164 tyvar_tys = mkTyVarTys tyvars
168 %==============================================
169 \subsubsection{AbsBind case: overloading}
170 %==============================================
172 If there is overloading we go for the general case.
174 We want the global identifiers to be abstracted wrt all types and
175 dictionaries; and the local identifiers wrt the non-overloaded types.
176 That is, we try to avoid global scoping of type abstraction. Example
178 f :: Eq a => a -> [(a,b)] -> b
181 Here, f is fully polymorphic in b. So we generate
183 f ab d = let ...dict defns...
185 letrec f' b = ...(f' b)...
188 *Notice* that we don't clone type variables, and *do* make use of
189 shadowing. It is possible to do cloning, but it makes the code quite
190 a bit more complicated, and the simplifier will clone it all anyway.
192 Why bother with this gloss? Because it makes it more likely that
193 the defn of f' can get floated out, notably if f gets specialised
194 to a particular type for a.
197 dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
198 = -- If there is any non-overloaded polymorphism, make new locals with
199 -- appropriate polymorphism
200 (if null non_overloaded_tyvars
202 -- No non-overloaded polymorphism, so stay with current envt
203 returnDs (id, [], [])
205 -- Some local, non-overloaded polymorphism
206 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
208 mapDs mk_binder binders `thenDs` \ new_binders ->
210 old_new_pairs = binders `zip` new_binders
213 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
215 | (old,new) <- old_new_pairs
216 ] `thenDs` \ extra_env ->
218 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
219 is_elem = isIn "dsBinds"
221 returnDs (lookupId old_new_pairs, extra_env, local_binds)
223 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
225 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
227 extendEnvDs local_env (
229 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
231 extendEnvDs inst_env (
233 dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
234 )) `thenDs` \ core_binds ->
237 tuple_rhs = mkCoLetsAny core_binds (
238 mkCoLetsAny local_binds (
239 mkTupleExpr locals ))
241 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
243 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
245 locals = [local | (local,global) <- local_global_prs]
246 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
248 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
249 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
251 binders = collectTypedBinders val_binds
252 mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
255 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
256 However, sometimes id takes more type args than are in tys, and the
257 specialiser hates that, so we have to eta expand, to
258 @(/\ a b -> id tys a b)@.
261 mkSatTyApp :: Id -- Id to apply to the types
262 -> [Type] -- Types to apply it to
265 mkSatTyApp id [] = returnDs (Var id)
269 = returnDs ty_app -- Common case
271 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
272 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
274 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
275 ty_app = mkTyApp (Var id) tys
278 There are several places where we encounter ``inst binds,''
279 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
280 (a var to a var or literal), which we want to substitute away; so we
281 return both some desugared bindings {\em and} a substitution
282 environment for the subbed-away ones.
284 These dictionary bindings are non-recursive, and ordered, so that
285 later ones may mention earlier ones, but not vice versa.
288 dsInstBinds :: [TyVar] -- Abstract wrt these
289 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
290 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
291 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
293 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
294 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
296 dsInstBinds tyvars [] = returnDs do_nothing
298 dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
299 = dsExpr expr `thenDs` \ rhs ->
300 let -- Need to apply dsExpr to the variable in case it
301 -- has a substitution in the current environment
302 subst_item = (inst, rhs)
304 extendEnvDs [subst_item] (
305 dsInstBinds tyvars bs
306 ) `thenDs` \ (binds, subst_env) ->
307 returnDs (binds, subst_item : subst_env)
309 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
310 = dsExpr expr `thenDs` \ core_lit ->
312 subst_item = (inst, core_lit)
314 extendEnvDs [subst_item] (
315 dsInstBinds tyvars bs
316 ) `thenDs` \ (binds, subst_env) ->
317 returnDs (binds, subst_item : subst_env)
319 dsInstBinds tyvars ((inst, expr) : bs)
321 = dsExpr expr `thenDs` \ core_expr ->
322 ds_dict_cc core_expr `thenDs` \ dict_expr ->
323 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
324 returnDs ((inst, dict_expr) : core_rest, subst_env)
328 -- The inst mentions the type vars wrt which we are abstracting,
329 -- so we have to invent a new polymorphic version, and substitute
331 -- This can occur in, for example:
332 -- leftPoll :: [FeedBack a] -> FeedBack a
333 -- leftPoll xs = take poll xs
334 -- Here there is an instance of take at the type of elts of xs,
335 -- as well as the type of poll.
337 dsExpr expr `thenDs` \ core_expr ->
338 ds_dict_cc core_expr `thenDs` \ dict_expr ->
339 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
341 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
343 extendEnvDs [subst_item] (
344 dsInstBinds tyvars bs
345 ) `thenDs` \ (core_rest, subst_env) ->
346 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
347 subst_item : subst_env)
349 inst_ty = idType inst
350 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
351 abs_tys = mkTyVarTys abs_tyvars
352 poly_inst_ty = mkForAllTys abs_tyvars inst_ty
354 ------------------------
355 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
356 -- appropriate. Uses "inst"'s type.
358 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
360 | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
361 -- the latter is so that -unprof-auto-scc-all adds dict sccs
362 || not (isDictTy inst_ty)
363 = returnDs expr -- that's easy: do nothing
365 | opt_CompilingGhcInternals
366 = returnDs (SCC prel_dicts_cc expr)
369 = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
371 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
373 returnDs (SCC (mkAllDictsCC mod grp False) expr)
376 %************************************************************************
378 \subsection[dsBind]{Desugaring a @Bind@}
380 %************************************************************************
382 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
383 some of the binders are of unboxed type.
385 For an explanation of the first three args, see @dsMonoBinds@.
388 dsBind :: Bool -- Add auto sccs to binds
389 -> [TyVar] -> [DictVar] -- Abstract wrt these
390 -> (Id -> Id) -- Binder substitution
391 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
395 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind
396 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
398 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
399 = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
400 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
402 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
403 = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
404 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
408 %************************************************************************
410 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
412 %************************************************************************
414 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
415 In addition to desugaring pattern matching, @dsMonoBinds@ takes
416 a list of type variables and dicts, and adds abstractions for these
417 to the front of every binding. That requires that the
418 binders be altered too (their type has changed,
419 so @dsMonoBinds@ also takes a function which maps binders into binders.
420 This mapping gives the binder the correct new type.
422 Remember, there's also a substitution in the monad which maps occurrences
423 of these binders into applications of the new binder to suitable type variables
427 dsMonoBinds :: Bool -- True <=> add auto sccs
428 -> Bool -- True <=> recursive binding group
429 -> [TyVar] -> [DictVar] -- Abstract wrt these
430 -> (Id -> Id) -- Binder substitution
431 -> TypecheckedMonoBinds
432 -> DsM [(Id,CoreExpr)]
437 %==============================================
438 \subsubsection{Structure cases}
439 %==============================================
442 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
444 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
445 = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1)
446 (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2)
450 %==============================================
451 \subsubsection{Simple base cases: function and variable bindings}
452 %==============================================
455 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
456 = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
457 returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
459 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
460 = dsExpr expr `thenDs` \ core_expr ->
461 doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
462 returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
464 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
467 new_fun = binder_subst fun
468 error_string = "function " ++ showForErr fun
470 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
471 doSccAuto auto_scc [fun] body `thenDs` \ sccd_body ->
473 mkLam tyvars (dicts ++ args) sccd_body)]
475 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
477 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
478 doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr ->
479 returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)]
482 %==============================================
483 \subsubsection{The general base case}
484 %==============================================
486 Now the general case of a pattern binding. The monomorphism restriction
487 should ensure that if there is a non-simple pattern binding in the
488 group, then there is no overloading involved, so the dictionaries should
489 be empty. (Simple pattern bindings were handled above.)
490 First, the paranoia check.
493 dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
494 = panic "Non-empty dict list in for pattern binding"
497 We handle three cases for the binding
501 \item[pat has no binders.]
502 Then all this is dead code and we return an empty binding.
504 \item[pat has exactly one binder, v.]
505 Then we can transform to:
507 v' = /\ tyvars -> case rhs of { pat -> v }
509 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
511 \item[pat has more than one binder.]
512 Then we transform to:
514 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
516 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
521 dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
524 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
525 doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr ->
527 {- KILLED by Sansom. 95/05
528 -- make *sure* there are no primitive types in the pattern
529 if any_con_w_prim_arg pat then
530 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
531 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
532 ++ "(We apologise for not reporting this more `cleanly')\n" )
534 -- Check whether the pattern already is a simple tuple; if so,
535 -- we can just use the rhs directly
538 -- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $
540 mkSelectorBinds tyvars pat
541 [(binder, binder_subst binder) | binder <- pat_binders]
544 pat_binders = collectTypedPatBinders pat
545 -- NB For a simple tuple pattern, these binders
546 -- will appear in the right order!
549 Wild-card patterns could be made acceptable here, but it involves some
550 extra work to benefit only rather unusual constructs like
552 let (_,a,b) = ... in ...
554 Better to extend the whole thing for any irrefutable constructor, at least.
556 %************************************************************************
558 \subsection[doSccAuto]{Adding automatic sccs}
560 %************************************************************************
563 doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr
565 doSccAuto False binders core_expr
568 doSccAuto True [] core_expr -- no binders
571 doSccAuto True _ core_expr@(SCC _ _) -- already sccd
574 doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con
577 doSccAuto True binders core_expr
579 scc_all = opt_AutoSccsOnAllToplevs
580 scc_export = not (null export_binders)
582 export_binders = filter isExported binders
584 scc_binder = head (if scc_all then binders else export_binders)
586 if scc_all || scc_export then
587 getModuleAndGroupDs `thenDs` \ (mod,grp) ->
588 returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr)