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
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
48 import Unique--ToDo:rm
50 isDictTy = panic "DsBinds.isDictTy"
53 %************************************************************************
55 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
57 %************************************************************************
59 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
60 that some of the binders are of unboxed type. This is sorted out when
61 the caller wraps the bindings round an expression.
64 dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
67 All ``real'' bindings are expressed in terms of the
68 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
69 and its desugaring is the subject of section~9.1 in the static
74 AbsBinds [a1, ... ,aj] -- type variables
75 [d1, ... ,dk] -- dict variables
76 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
77 [db1=..., ..., dbn=...] -- dict binds
78 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
80 we want to make, in the general case (non-Fozzie translation):
85 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
87 -- a bunch of selectors:
88 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
90 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
92 But there are lots of special cases.
95 %==============================================
96 \subsubsection{Structure cases}
97 %==============================================
100 dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith"
101 dsBinds auto_scc EmptyBinds = returnDs []
102 dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind
104 dsBinds auto_scc (ThenBinds binds_1 binds_2)
105 = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2)
109 %==============================================
110 \subsubsection{AbsBind case: no overloading}
111 %==============================================
113 Special case: no overloading.
118 We abstract each wrt the type variables, giving
120 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
121 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
123 There are some complications.
125 (i) The @val_binds@ might mention variable not in @local_global_prs@.
126 In this case we need to make up new polymorphic versions of them.
128 (ii) Exactly the same applies to any @inst_binds@ which may be
129 present. However, here we expect that mostly they will be simple constant
130 definitions, which don't mention the type variables at all, so making them
131 polymorphic is really overkill. @dsInstBinds@ deals with this case.
134 dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
135 = mapDs mk_poly_private_binder private_binders
136 `thenDs` \ poly_private_binders ->
138 full_local_global_prs = (private_binders `zip` poly_private_binders)
141 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
142 returnDs (local, app)
143 | (local,global) <- full_local_global_prs
146 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
150 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
151 extendEnvDs inst_env (
153 dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
156 -- "private_binders" is the list of binders in val_binds
157 -- which don't appear in the local_global_prs list
158 -- These only really show up in stuff produced from compiling
159 -- class and instance declarations.
160 -- We need to add suitable polymorphic versions of them to the
162 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
163 binders = collectTypedBinders val_binds
164 mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
166 tyvar_tys = mkTyVarTys tyvars
170 %==============================================
171 \subsubsection{AbsBind case: overloading}
172 %==============================================
174 If there is overloading we go for the general case.
176 We want the global identifiers to be abstracted wrt all types and
177 dictionaries; and the local identifiers wrt the non-overloaded types.
178 That is, we try to avoid global scoping of type abstraction. Example
180 f :: Eq a => a -> [(a,b)] -> b
183 Here, f is fully polymorphic in b. So we generate
185 f ab d = let ...dict defns...
187 letrec f' b = ...(f' b)...
190 *Notice* that we don't clone type variables, and *do* make use of
191 shadowing. It is possible to do cloning, but it makes the code quite
192 a bit more complicated, and the simplifier will clone it all anyway.
194 Why bother with this gloss? Because it makes it more likely that
195 the defn of f' can get floated out, notably if f gets specialised
196 to a particular type for a.
199 dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
200 = -- If there is any non-overloaded polymorphism, make new locals with
201 -- appropriate polymorphism
202 (if null non_overloaded_tyvars
204 -- No non-overloaded polymorphism, so stay with current envt
205 returnDs (id, [], [])
207 -- Some local, non-overloaded polymorphism
208 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
210 mapDs mk_binder binders `thenDs` \ new_binders ->
212 old_new_pairs = binders `zip` new_binders
215 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
217 | (old,new) <- old_new_pairs
218 ] `thenDs` \ extra_env ->
220 local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
221 is_elem = isIn "dsBinds"
223 returnDs (lookupId old_new_pairs, extra_env, local_binds)
225 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
227 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
229 extendEnvDs local_env (
231 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
233 extendEnvDs inst_env (
235 dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
236 )) `thenDs` \ core_binds ->
239 tuple_rhs = mkCoLetsAny core_binds (
240 mkCoLetsAny local_binds (
241 mkTupleExpr locals ))
243 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
245 returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
247 locals = [local | (local,global) <- local_global_prs]
248 non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
250 overloaded_tyvars = tyVarsOfTypes (map idType dicts)
251 non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
253 binders = collectTypedBinders val_binds
254 mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
257 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
258 However, sometimes id takes more type args than are in tys, and the
259 specialiser hates that, so we have to eta expand, to
260 @(/\ a b -> id tys a b)@.
263 mkSatTyApp :: Id -- Id to apply to the types
264 -> [Type] -- Types to apply it to
267 mkSatTyApp id [] = returnDs (Var id)
271 = returnDs ty_app -- Common case
273 = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
274 returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
276 (tvs, theta, tau_ty) = splitSigmaTy (idType id)
277 ty_app = mkTyApp (Var id) tys
280 There are several places where we encounter ``inst binds,''
281 @(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
282 (a var to a var or literal), which we want to substitute away; so we
283 return both some desugared bindings {\em and} a substitution
284 environment for the subbed-away ones.
286 These dictionary bindings are non-recursive, and ordered, so that
287 later ones may mention earlier ones, but not vice versa.
290 dsInstBinds :: [TyVar] -- Abstract wrt these
291 -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
292 -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
293 [(Id,CoreExpr)]) -- Trivial ones to be substituted away
295 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
296 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
298 dsInstBinds tyvars [] = returnDs do_nothing
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)
311 dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
312 = dsExpr expr `thenDs` \ core_lit ->
314 subst_item = (inst, core_lit)
316 extendEnvDs [subst_item] (
317 dsInstBinds tyvars bs
318 ) `thenDs` \ (binds, subst_env) ->
319 returnDs (binds, subst_item : subst_env)
321 dsInstBinds tyvars ((inst, expr) : bs)
323 = dsExpr expr `thenDs` \ core_expr ->
324 ds_dict_cc core_expr `thenDs` \ dict_expr ->
325 dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
326 returnDs ((inst, dict_expr) : core_rest, subst_env)
330 -- The inst mentions the type vars wrt which we are abstracting,
331 -- so we have to invent a new polymorphic version, and substitute
333 -- This can occur in, for example:
334 -- leftPoll :: [FeedBack a] -> FeedBack a
335 -- leftPoll xs = take poll xs
336 -- Here there is an instance of take at the type of elts of xs,
337 -- as well as the type of poll.
339 dsExpr expr `thenDs` \ core_expr ->
340 ds_dict_cc core_expr `thenDs` \ dict_expr ->
341 newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
343 subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
345 extendEnvDs [subst_item] (
346 dsInstBinds tyvars bs
347 ) `thenDs` \ (core_rest, subst_env) ->
348 returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
349 subst_item : subst_env)
351 inst_ty = idType inst
352 abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
353 abs_tys = mkTyVarTys abs_tyvars
354 poly_inst_ty = mkForAllTys abs_tyvars inst_ty
356 ------------------------
357 -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
358 -- appropriate. Uses "inst"'s type.
360 -- if profiling, wrap the dict in "_scc_ DICT <dict>":
362 | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
363 -- the latter is so that -unprof-auto-scc-all adds dict sccs
364 || not (isDictTy inst_ty)
365 = returnDs expr -- that's easy: do nothing
367 | opt_CompilingGhcInternals
368 = returnDs (SCC prel_dicts_cc expr)
371 = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
373 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
375 returnDs (SCC (mkAllDictsCC mod grp False) expr)
378 %************************************************************************
380 \subsection[dsBind]{Desugaring a @Bind@}
382 %************************************************************************
384 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
385 some of the binders are of unboxed type.
387 For an explanation of the first three args, see @dsMonoBinds@.
390 dsBind :: Bool -- Add auto sccs to binds
391 -> [TyVar] -> [DictVar] -- Abstract wrt these
392 -> (Id -> Id) -- Binder substitution
393 -> [(Id,CoreExpr)] -- Inst bindings already dealt with
397 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind
398 = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
400 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
401 = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
402 returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs]
404 dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
405 = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs ->
406 returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)]
410 %************************************************************************
412 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
414 %************************************************************************
416 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @CoreBinds@.
417 In addition to desugaring pattern matching, @dsMonoBinds@ takes
418 a list of type variables and dicts, and adds abstractions for these
419 to the front of every binding. That requires that the
420 binders be altered too (their type has changed,
421 so @dsMonoBinds@ also takes a function which maps binders into binders.
422 This mapping gives the binder the correct new type.
424 Remember, there's also a substitution in the monad which maps occurrences
425 of these binders into applications of the new binder to suitable type variables
429 dsMonoBinds :: Bool -- True <=> add auto sccs
430 -> Bool -- True <=> recursive binding group
431 -> [TyVar] -> [DictVar] -- Abstract wrt these
432 -> (Id -> Id) -- Binder substitution
433 -> TypecheckedMonoBinds
434 -> DsM [(Id,CoreExpr)]
439 %==============================================
440 \subsubsection{Structure cases}
441 %==============================================
444 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
446 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
447 = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1)
448 (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2)
452 %==============================================
453 \subsubsection{Simple base cases: function and variable bindings}
454 %==============================================
457 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
458 = dsExpr expr `thenDs` \ core_expr ->
459 doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
460 returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
462 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
465 new_fun = binder_subst fun
466 error_string = "function " ++ showForErr fun
468 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
469 doSccAuto auto_scc [fun] body `thenDs` \ sccd_body ->
471 mkLam tyvars (dicts ++ args) sccd_body)]
473 dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
475 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
476 doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr ->
477 returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)]
480 %==============================================
481 \subsubsection{The general base case}
482 %==============================================
484 Now the general case of a pattern binding. The monomorphism restriction
485 should ensure that if there is a non-simple pattern binding in the
486 group, then there is no overloading involved, so the dictionaries should
487 be empty. (Simple pattern bindings were handled above.)
488 First, the paranoia check.
491 dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
492 = panic "Non-empty dict list in for pattern binding"
495 We handle three cases for the binding
499 \item[pat has no binders.]
500 Then all this is dead code and we return an empty binding.
502 \item[pat has exactly one binder, v.]
503 Then we can transform to:
505 v' = /\ tyvars -> case rhs of { pat -> v }
507 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
509 \item[pat has more than one binder.]
510 Then we transform to:
512 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
514 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
519 dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
522 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
523 doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr ->
525 {- KILLED by Sansom. 95/05
526 -- make *sure* there are no primitive types in the pattern
527 if any_con_w_prim_arg pat then
528 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
529 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
530 ++ "(We apologise for not reporting this more `cleanly')\n" )
532 -- Check whether the pattern already is a simple tuple; if so,
533 -- we can just use the rhs directly
536 -- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $
538 mkSelectorBinds tyvars pat
539 [(binder, binder_subst binder) | binder <- pat_binders]
542 pat_binders = collectTypedPatBinders pat
543 -- NB For a simple tuple pattern, these binders
544 -- will appear in the right order!
547 Wild-card patterns could be made acceptable here, but it involves some
548 extra work to benefit only rather unusual constructs like
550 let (_,a,b) = ... in ...
552 Better to extend the whole thing for any irrefutable constructor, at least.
554 %************************************************************************
556 \subsection[doSccAuto]{Adding automatic sccs}
558 %************************************************************************
561 doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr
563 doSccAuto False binders core_expr
566 doSccAuto True [] core_expr -- no binders
569 doSccAuto True _ core_expr@(SCC _ _) -- already sccd
572 doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con
575 doSccAuto True binders core_expr
577 scc_all = opt_AutoSccsOnAllToplevs
578 scc_export = not (null export_binders)
580 export_binders = filter isExported binders
582 scc_binder = head (if scc_all then binders else export_binders)
584 if scc_all || scc_export then
585 getModuleAndGroupDs `thenDs` \ (mod,grp) ->
586 returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr)