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 ) where
16 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
17 IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
19 import {-# SOURCE #-} DsExpr
22 import HsSyn -- lots of things
23 import CoreSyn -- lots of things
24 import CoreUtils ( coreExprType )
25 import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
26 SYN_IE(TypecheckedMonoBinds),
27 SYN_IE(TypecheckedPat)
30 import DsGRHSs ( dsGuarded )
32 import Match ( matchWrapper )
34 import BasicTypes ( SYN_IE(Module) )
35 import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
36 opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals )
37 import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre )
38 import Id ( idType, SYN_IE(DictVar), GenId, SYN_IE(Id) )
39 import ListSetOps ( minusList, intersectLists )
40 import Name ( isExported )
41 import PprType ( GenType )
42 import Outputable ( PprStyle(..) )
43 import Type ( mkTyVarTy, isDictTy, instantiateTy
45 import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
46 import TysPrim ( voidTy )
47 import Util ( isIn, panic, assertPanic )
50 %************************************************************************
52 \subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@}
54 %************************************************************************
56 Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be
57 that some of the binders are of unboxed type. This is sorted out when
58 the caller wraps the bindings round an expression.
61 type Group = FAST_STRING
63 dsBinds :: Maybe (Module, Group) -> TypecheckedHsBinds -> DsM [CoreBinding]
65 dsBinds _ EmptyBinds = returnDs []
66 dsBinds mb_mod_grp (ThenBinds binds_1 binds_2)
67 = andDs (++) (dsBinds mb_mod_grp binds_1) (dsBinds mb_mod_grp binds_2)
69 dsBinds mb_mod_grp (MonoBind binds sigs is_rec)
70 = dsMonoBinds mb_mod_grp is_rec binds `thenDs` \ prs ->
71 returnDs (if is_rec then
74 [NonRec binder rhs | (binder,rhs) <- prs]
79 %************************************************************************
81 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
83 %************************************************************************
86 dsMonoBinds :: Maybe (Module, Group) -- Nothing => don't (auto-)annotate scc on toplevs.
88 -> TypecheckedMonoBinds
89 -> DsM [(Id,CoreExpr)]
91 dsMonoBinds _ is_rec EmptyMonoBinds = returnDs []
93 dsMonoBinds mb_mod_grp is_rec (AndMonoBinds binds_1 binds_2)
94 = andDs (++) (dsMonoBinds mb_mod_grp is_rec binds_1) (dsMonoBinds mb_mod_grp is_rec binds_2)
96 dsMonoBinds _ is_rec (CoreMonoBind var core_expr)
97 = returnDs [(var, core_expr)]
99 dsMonoBinds _ is_rec (VarMonoBind var expr)
100 = dsExpr expr `thenDs` \ core_expr ->
102 -- Dictionary bindings are always VarMonoBinds, so
103 -- we only need do this here
104 addDictScc var core_expr `thenDs` \ core_expr' ->
106 returnDs [(var, core_expr')]
108 dsMonoBinds mb_mod_grp is_rec (FunMonoBind fun _ matches locn)
110 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
111 returnDs [addAutoScc mb_mod_grp (fun, mkValLam args body)]
113 error_string = "function " ++ showForErr fun
115 dsMonoBinds mb_mod_grp is_rec (PatMonoBind pat grhss_and_binds locn)
117 dsGuarded grhss_and_binds `thenDs` \ body_expr ->
118 mkSelectorBinds pat body_expr
120 -- Common special case: no type or dictionary abstraction
121 dsMonoBinds mb_mod_grp is_rec (AbsBinds [] [] exports binds)
122 = dsMonoBinds Nothing is_rec binds `thenDs` \ prs ->
123 returnDs (prs ++ [ addAutoScc mb_mod_grp (global, Var local) | (_, global, local) <- exports])
125 -- Another common case: one exported variable
126 -- All non-recursive bindings come through this way
127 dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds)
128 = ASSERT( all (`elem` tyvars) all_tyvars )
129 dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
131 core_binds | is_rec = [Rec core_prs]
132 | otherwise = [NonRec b e | (b,e) <- core_prs]
134 returnDs [addAutoScc mb_mod_grp (global, mkLam tyvars dicts $
135 mkCoLetsAny core_binds (Var local))]
137 dsMonoBinds mb_mod_grp is_rec (AbsBinds all_tyvars dicts exports binds)
138 = dsMonoBinds Nothing is_rec binds `thenDs` \ core_prs ->
140 core_binds | is_rec = [Rec core_prs]
141 | otherwise = [NonRec b e | (b,e) <- core_prs]
143 tup_expr = mkLam all_tyvars dicts $
144 mkCoLetsAny core_binds $
146 locals = [local | (_, _, local) <- exports]
147 local_tys = map idType locals
149 newSysLocalDs (coreExprType tup_expr) `thenDs` \ tup_id ->
151 dict_args = map VarArg dicts
153 mk_bind (tyvars, global, local) n -- locals !! n == local
154 = -- Need to make fresh locals to bind in the selector, because
155 -- some of the tyvars will be bound to voidTy
156 newSysLocalsDs (map (instantiateTy env) local_tys) `thenDs` \ locals' ->
157 returnDs (addAutoScc mb_mod_grp $
158 (global, mkLam tyvars dicts $
159 mkTupleSelector locals' (locals' !! n) $
160 mkValApp (mkTyApp (Var tup_id) ty_args) dict_args))
162 mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
164 ty_args = map mk_ty_arg all_tyvars
165 env = all_tyvars `zip` ty_args
167 zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
168 -- don't scc (auto-)annotate the tuple itself.
169 returnDs ((tup_id, tup_expr) : export_binds)
173 %************************************************************************
175 \subsection[addAutoScc]{Adding automatic sccs}
177 %************************************************************************
180 addAutoScc :: Maybe (Module, Group) -- Module and group
184 addAutoScc mb_mod_grp pair@(bndr, core_expr)
187 | worthSCC core_expr &&
188 (opt_AutoSccsOnAllToplevs ||
189 (isExported bndr && opt_AutoSccsOnExportedToplevs))
190 -> (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
191 _ -> pair -- no auto-annotation.
193 worthSCC (SCC _ _) = False
194 worthSCC (Con _ _) = False
195 worthSCC core_expr = True
198 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
202 | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
203 -- the latter is so that -unprof-auto-scc-all adds dict sccs
204 || not (isDictTy (idType var))
205 = returnDs rhs -- That's easy: do nothing
207 | opt_CompilingGhcInternals
208 = returnDs (SCC prel_dicts_cc rhs)
211 = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
213 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
214 returnDs (SCC (mkAllDictsCC mod grp False) rhs)
216 prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto