2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[DsBinds]{Pattern-matching bindings (Binds and MonoBinds)}
6 Handles @Binds@; those at the top level require different handling, in
7 that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower
8 levels it is preserved with @let@/@letrec@s).
11 #include "HsVersions.h"
17 IMPORT_Trace -- ToDo: rm (debugging only)
19 import AbsSyn -- the stuff being desugared
20 import PlainCore -- the output of desugaring;
21 -- importing this module also gets all the
22 -- CoreSyn utility functions
23 import DsMonad -- the monadery used in the desugarer
26 import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn )
27 import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
28 import Inst ( getInstUniType )
29 import DsExpr ( dsExpr )
30 import DsGRHSs ( dsGuarded )
32 import Id ( getIdUniType, mkInstId, Inst, Id, DictVar(..) )
33 import Match ( matchWrapper )
34 import Maybes ( Maybe(..),assocMaybe )
38 import ListSetOps ( minusList, intersectLists )
42 %************************************************************************
44 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
46 %************************************************************************
48 Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be
49 that some of the binders are of unboxed type. This is sorted out when
50 the caller wraps the bindings round an expression.
53 dsBinds :: TypecheckedBinds -> DsM [PlainCoreBinding]
56 All ``real'' bindings are expressed in terms of the
57 @AbsBinds@ construct, which is a massively-complicated ``shorthand'',
58 and its desugaring is the subject of section~9.1 in the static
63 AbsBinds [a1, ... ,aj] -- type variables
64 [d1, ... ,dk] -- dict variables
65 [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
66 [db1=..., ..., dbn=...] -- dict binds
67 [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
69 we want to make, in the general case (non-Fozzie translation):
74 let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
76 -- a bunch of selectors:
77 g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
79 gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
81 But there are lots of special cases.
84 %==============================================
85 \subsubsection{Structure cases}
86 %==============================================
89 dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
90 dsBinds EmptyBinds = returnDs []
91 dsBinds (SingleBind bind) = dsBind [] [] id [] bind
93 dsBinds (ThenBinds binds_1 binds_2)
94 = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
98 %==============================================
99 \subsubsection{AbsBind case: no overloading}
100 %==============================================
102 Special case: no overloading.
107 We abstract each wrt the type variables, giving
109 x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
110 x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
112 There are some complications.
114 (i) The @val_binds@ might mention variable not in @local_global_prs@.
115 In this case we need to make up new polymorphic versions of them.
117 (ii) Exactly the same applies to any @inst_binds@ which may be
118 present. However, here we expect that mostly they will be simple constant
119 definitions, which don't mention the type variables at all, so making them
120 polymorphic is really overkill. @dsInstBinds@ deals with this case.
123 dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
124 = mapDs mk_poly_private_binder private_binders
125 `thenDs` \ poly_private_binders ->
127 full_local_global_prs = (private_binders `zip` poly_private_binders)
130 listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
131 returnDs (local, app)
132 | (local,global) <- full_local_global_prs
135 -- pprTrace "AbsBinds1:" (ppr PprDebug env) $
139 dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
140 extendEnvDs inst_env (
142 dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
145 -- "private_binders" is the list of binders in val_binds
146 -- which don't appear in the local_global_prs list
147 -- These only really show up in stuff produced from compiling
148 -- class and instance declarations.
149 -- We need to add suitable polymorphic versions of them to the
151 private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
152 binders = collectTypedBinders val_binds
153 mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (getIdUniType id)))
155 tyvar_tys = map mkTyVarTy tyvars
159 %==============================================
160 \subsubsection{AbsBind case: overloading}
161 %==============================================
163 If there is overloading we go for the general case.
165 We want the global identifiers to be abstracted wrt all types and
166 dictionaries; and the local identifiers wrt the non-overloaded types.
167 That is, we try to avoid global scoping of type abstraction. Example
169 f :: Eq a => a -> [(a,b)] -> b
172 Here, f is fully polymorphic in b. So we generate
174 f ab d = let ...dict defns...
176 letrec f' b = ...(f' b)...
179 *Notice* that we don't clone type variables, and *do* make use of
180 shadowing. It is possible to do cloning, but it makes the code quite
181 a bit more complicated, and the simplifier will clone it all anyway.
183 Why bother with this gloss? Because it makes it more likely that
184 the defn of f' can get floated out, notably if f gets specialised
185 to a particular type for a.
188 dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
189 = -- If there is any non-overloaded polymorphism, make new locals with
190 -- appropriate polymorphism
191 (if null non_overloaded_tyvars
193 -- No non-overloaded polymorphism, so stay with current envt
194 returnDs (id, [], [])
196 -- Some local, non-overloaded polymorphism
197 cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
199 mapDs mk_binder binders `thenDs` \ new_binders ->
201 old_new_pairs = binders `zip` new_binders
204 listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
206 | (old,new) <- old_new_pairs
207 ] `thenDs` \ extra_env ->
209 local_binds = [CoNonRec old app | (old,app) <- extra_env, old `is_elem` locals]
210 is_elem = isIn "dsBinds"
212 returnDs (lookupId old_new_pairs, extra_env, local_binds)
214 `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
216 -- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
218 extendEnvDs local_env (
220 dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
222 extendEnvDs inst_env (
224 dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
225 )) `thenDs` \ core_binds ->
228 tuple_rhs = mkCoLetsAny core_binds (
229 mkCoLetsAny local_binds (
230 mkTupleExpr locals ))
232 mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
234 returnDs [ CoNonRec binder rhs | (binder,rhs) <- core_bind_prs ]
236 locals = [local | (local,global) <- local_global_prs]
237 non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars
239 overloaded_tyvars = extractTyVarsFromTys (map getIdUniType dicts)
240 non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars
242 binders = collectTypedBinders val_binds
243 mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (getIdUniType id)))
246 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
247 However, sometimes id takes more type args than are in tys, and the
248 specialiser hates that, so we have to eta expand, to
249 (/\ a b -> id tys a b)
252 mkSatTyApp :: Id -- Id to apply to the types
253 -> [UniType] -- Types to apply it to
256 mkSatTyApp id [] = returnDs (CoVar id)
259 | null tyvar_templates
260 = returnDs (mkCoTyApps (CoVar id) tys) -- Common case
263 = newTyVarsDs (drop (length tys) tyvar_templates) `thenDs` \ tyvars ->
264 -- pprTrace "mkSatTyApp:" (ppCat [ppr PprDebug id, ppr PprDebug tyvar_templates, ppr PprDebug tyvars, ppr PprDebug theta, ppr PprDebug tau_ty, ppr PprDebug tys]) $
265 returnDs (mkCoTyLam tyvars (mkCoTyApps (mkCoTyApps (CoVar id) tys)
266 (map mkTyVarTy tyvars)))
268 (tyvar_templates, theta, tau_ty) = splitType (getIdUniType id)
271 There are several places where we encounter ``inst binds,''
272 @(Inst, TypecheckedExpr)@ pairs. Many of these are ``trivial'' binds
273 (a var to a var or literal), which we want to substitute away; so we
274 return both some desugared bindings {\em and} a substitution
275 environment for the subbed-away ones.
277 These dictionary bindings are non-recursive, and ordered, so that
278 later ones may mention earlier ones, but not vice versa.
281 dsInstBinds :: [TyVar] -- Abstract wrt these
282 -> [(Inst, TypecheckedExpr)] -- From AbsBinds
283 -> DsM ([(Id,PlainCoreExpr)], -- Non-trivial bindings
284 [(Id,PlainCoreExpr)]) -- Trivial ones to be substituted away
286 do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
287 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
289 dsInstBinds tyvars []
290 = returnDs do_nothing
292 dsInstBinds tyvars ((inst, expr@(Var _)) : bs)
293 = dsExpr expr `thenDs` ( \ rhs ->
294 let -- Need to apply dsExpr to the variable in case it
295 -- has a substitution in the current environment
296 subst_item = (mkInstId inst, rhs)
298 extendEnvDs [subst_item] (
299 dsInstBinds tyvars bs
300 ) `thenDs` (\ (binds, subst_env) ->
301 returnDs (binds, subst_item : subst_env)
304 dsInstBinds tyvars ((inst, expr@(Lit _)) : bs)
305 = dsExpr expr `thenDs` ( \ core_lit ->
307 subst_item = (mkInstId inst, core_lit)
309 extendEnvDs [subst_item] (
310 dsInstBinds tyvars bs
311 ) `thenDs` (\ (binds, subst_env) ->
312 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 ((mkInstId 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 = (mkInstId inst, mkCoTyApps (CoVar poly_inst_id) abs_tys)
339 extendEnvDs [subst_item] (
340 dsInstBinds tyvars bs
341 ) `thenDs` \ (core_rest, subst_env) ->
342 returnDs ((poly_inst_id, mkCoTyLam abs_tyvars dict_expr) : core_rest,
343 subst_item : subst_env)
345 inst_ty = getInstUniType inst
346 abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
347 abs_tys = map mkTyVarTy 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.
355 = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
356 getSwitchCheckerDs `thenDs` \ sw_chkr ->
358 doing_profiling = sw_chkr SccProfilingOn
359 compiling_prelude = sw_chkr CompilingPrelude
361 if not doing_profiling
362 || not (isDictTy inst_ty) then -- that's easy: do nothing
364 else if compiling_prelude then
365 returnDs (CoSCC prel_dicts_cc expr)
367 getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
368 -- ToDo: do -dicts-all flag (mark dict things
369 -- with individual CCs)
371 dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
373 returnDs (CoSCC dict_cc expr)
376 %************************************************************************
378 \subsection[dsBind]{Desugaring a @Bind@}
380 %************************************************************************
382 Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, 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 :: [TyVar] -> [DictVar] -- Abstract wrt these
389 -> (Id -> Id) -- Binder substitution
390 -> [(Id,PlainCoreExpr)] -- Inst bindings already dealt with
392 -> DsM [PlainCoreBinding]
394 dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
395 = returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
397 dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
398 = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
399 returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
401 dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
402 = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
403 returnDs [CoRec (inst_bind_pairs ++ val_bind_pairs)] )
407 %************************************************************************
409 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
411 %************************************************************************
413 @dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @PlainCoreBinds@.
414 In addition to desugaring pattern matching, @dsMonoBinds@ takes
415 a list of type variables and dicts, and adds abstractions for these
416 to the front of every binding. That requires that the
417 binders be altered too (their type has changed,
418 so @dsMonoBinds@ also takes a function which maps binders into binders.
419 This mapping gives the binder the correct new type.
421 Remember, there's also a substitution in the monad which maps occurrences
422 of these binders into applications of the new binder to suitable type variables
426 dsMonoBinds :: Bool -- True <=> recursive binding group
427 -> [TyVar] -> [DictVar] -- Abstract wrt these
428 -> (Id -> Id) -- Binder substitution
429 -> TypecheckedMonoBinds
430 -> DsM [(Id,PlainCoreExpr)]
435 %==============================================
436 \subsubsection{Structure cases}
437 %==============================================
440 dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs []
442 dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2)
443 = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1)
444 (dsMonoBinds is_rec tyvars dicts binder_subst binds_2)
448 %==============================================
449 \subsubsection{Simple base cases: function and variable bindings}
450 %==============================================
452 For the simplest bindings, we just heave them in the substitution env:
455 {- THESE TWO ARE PLAIN WRONG.
456 The extendEnvDs only scopes over the nested call!
457 Let the simplifier do this.
459 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (Var new_var))
460 | not (is_rec || isExported was_var)
461 = extendEnvDs [(was_var, CoVar new_var)] (
464 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _))
465 | not (isExported was_var)
466 = dsExpr expr `thenDs` ( \ core_lit ->
467 extendEnvDs [(was_var, core_lit)] (
471 dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
472 = dsExpr expr `thenDs` ( \ core_expr ->
473 returnDs [(binder_subst var, mkCoTyLam tyvars (mkCoLam dicts core_expr))] )
477 dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
480 new_fun = binder_subst fun
482 matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
484 mkCoTyLam tyvars (mkCoLam dicts (mkCoLam args body)))]
487 error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
488 ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
490 dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
492 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
493 returnDs [(binder_subst v, mkCoTyLam tyvars (mkCoLam dicts body_expr))]
497 %==============================================
498 \subsubsection{The general base case}
499 %==============================================
501 Now the general case of a pattern binding. The monomorphism restriction
502 should ensure that if there is a non-simple pattern binding in the
503 group, then there is no overloading involved, so the dictionaries should
504 be empty. (Simple pattern bindings were handled above.)
505 First, the paranoia check.
508 dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn)
509 = panic "Non-empty dict list in for pattern binding"
512 We handle three cases for the binding
516 \item[pat has no binders.]
517 Then all this is dead code and we return an empty binding.
519 \item[pat has exactly one binder, v.]
520 Then we can transform to:
522 v' = /\ tyvars -> case rhs of { pat -> v }
524 where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}.
526 \item[pat has more than one binder.]
527 Then we transform to:
529 t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) }
531 vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi }
536 dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
539 dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
541 {- KILLED by Sansom. 95/05
542 -- make *sure* there are no primitive types in the pattern
543 if any_con_w_prim_arg pat then
544 error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t"
545 ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n"
546 ++ "(We apologise for not reporting this more `cleanly')\n" )
548 -- Check whether the pattern already is a simple tuple; if so,
549 -- we can just use the rhs directly
552 mkSelectorBinds tyvars pat
553 [(binder, binder_subst binder) | binder <- pat_binders]
557 pat_binders = collectTypedPatBinders pat
558 -- NB For a simple tuple pattern, these binders
559 -- will appear in the right order!
561 {- UNUSED, post-Sansom:
562 any_con_w_prim_arg :: TypecheckedPat -> Bool
564 any_con_w_prim_arg (WildPat ty) = isPrimType ty
565 any_con_w_prim_arg (VarPat v) = isPrimType (getIdUniType v)
566 any_con_w_prim_arg (LazyPat pat) = any_con_w_prim_arg pat
567 any_con_w_prim_arg (AsPat _ pat) = any_con_w_prim_arg pat
568 any_con_w_prim_arg p@(ConPat _ _ args) = any any_con_w_prim_arg args
569 any_con_w_prim_arg (ConOpPat a1 _ a2 _) = any any_con_w_prim_arg [a1,a2]
570 any_con_w_prim_arg (ListPat _ args) = any any_con_w_prim_arg args
571 any_con_w_prim_arg (TuplePat args) = any any_con_w_prim_arg args
572 any_con_w_prim_arg (LitPat _ ty) = isPrimType ty
573 any_con_w_prim_arg (NPat _ _ _) = False -- be more paranoid?
574 any_con_w_prim_arg (NPlusKPat _ _ _ _ _ _) = False -- ditto
577 -- Should be more efficient to find type of pid than pats
578 any_con_w_prim_arg (ProcessorPat pats _ pat)
579 = error "any_con_w_prim_arg:ProcessorPat (DPH)"
580 #endif {- Data Parallel Haskell -}
583 {- OLD ... removed 6 Feb 95
585 -- we allow it if the constructor has *only one*
586 -- argument and that is unboxed, as in
588 -- let (I# i#) = ... in ...
593 = length [ a | a <- args, isPrimType (typeOfPat a) ]
595 if no_of_prim_args == 0 then
597 else if no_of_prim_args == 1 && length args == 1 then
598 False -- special case we let through
605 Wild-card patterns could be made acceptable here, but it involves some
606 extra work to benefit only rather unusual constructs like
608 let (_,a,b) = ... in ...
610 Better to extend the whole thing for any irrefutable constructor, at least.