2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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 module DsBinds ( dsMonoBinds ) where
13 #include "HsVersions.h"
16 import {-# SOURCE #-} DsExpr( dsExpr )
18 import HsSyn -- lots of things
19 import CoreSyn -- lots of things
20 import CoreUtils ( coreExprType )
21 import TcHsSyn ( TypecheckedMonoBinds )
23 import DsGRHSs ( dsGuarded )
25 import Match ( matchWrapper )
27 import BasicTypes ( RecFlag(..) )
28 import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
29 opt_AutoSccsOnExportedToplevs
31 import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC )
32 import Id ( idType, Id )
34 import Name ( Module, isExported )
35 import Type ( mkTyVarTy, isDictTy, substTy
37 import TysWiredIn ( voidTy )
41 %************************************************************************
43 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
45 %************************************************************************
48 dsMonoBinds :: Bool -- False => don't (auto-)annotate scc on toplevs.
49 -> TypecheckedMonoBinds
50 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
51 -> DsM [(Id,CoreExpr)] -- Result
53 dsMonoBinds _ EmptyMonoBinds rest = returnDs rest
55 dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest
56 = dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' ->
57 dsMonoBinds auto_scc binds_1 rest'
59 dsMonoBinds _ (CoreMonoBind var core_expr) rest
60 = returnDs ((var, core_expr) : rest)
62 dsMonoBinds _ (VarMonoBind var expr) rest
63 = dsExpr expr `thenDs` \ core_expr ->
65 -- Dictionary bindings are always VarMonoBinds, so
66 -- we only need do this here
67 addDictScc var core_expr `thenDs` \ core_expr' ->
69 returnDs ((var, core_expr') : rest)
71 dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
73 matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
74 addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
75 returnDs (pair : rest)
77 error_string = "function " ++ showSDoc (ppr fun)
79 dsMonoBinds _ (PatMonoBind pat grhss locn) rest
81 dsGuarded grhss `thenDs` \ body_expr ->
82 mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
83 returnDs (sel_binds ++ rest)
85 -- Common special case: no type or dictionary abstraction
86 dsMonoBinds auto_scc (AbsBinds [] [] exports binds) rest
87 = mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' ->
88 dsMonoBinds False binds (exports' ++ rest)
90 -- Another common case: one exported variable
91 -- All non-recursive bindings come through this way
92 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) rest
93 = ASSERT( all (`elem` tyvars) all_tyvars )
94 dsMonoBinds False binds [] `thenDs` \ core_prs ->
96 -- Always treat the binds as recursive, because the typechecker
97 -- makes rather mixed-up dictionary bindings
98 core_binds = [Rec core_prs]
100 addAutoScc auto_scc (global, mkLams tyvars $ mkLams dicts $
101 mkLets core_binds (Var local)) `thenDs` \ global' ->
102 returnDs (global' : rest)
104 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports binds) rest
105 = dsMonoBinds False binds [] `thenDs` \ core_prs ->
107 core_binds = [Rec core_prs]
109 tup_expr = mkTupleExpr locals
110 tup_ty = coreExprType tup_expr
111 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
112 mkLets core_binds tup_expr
113 locals = [local | (_, _, local) <- exports]
114 local_tys = map idType locals
116 newSysLocalDs (coreExprType poly_tup_expr) `thenDs` \ poly_tup_id ->
118 dict_args = map Var dicts
120 mk_bind (tyvars, global, local) n -- locals !! n == local
121 = -- Need to make fresh locals to bind in the selector, because
122 -- some of the tyvars will be bound to voidTy
123 newSysLocalsDs (map (substTy env) local_tys) `thenDs` \ locals' ->
124 newSysLocalDs (substTy env tup_ty) `thenDs` \ tup_id ->
126 (global, mkLams tyvars $ mkLams dicts $
127 mkTupleSelector locals' (locals' !! n) tup_id $
128 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
130 mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
132 ty_args = map mk_ty_arg all_tyvars
133 env = all_tyvars `zipVarEnv` ty_args
135 zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
136 -- don't scc (auto-)annotate the tuple itself.
137 returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest))
141 %************************************************************************
143 \subsection[addAutoScc]{Adding automatic sccs}
145 %************************************************************************
148 addAutoScc :: Bool -- if needs be, decorate toplevs?
150 -> DsM (Id, CoreExpr)
152 addAutoScc auto_scc_candidate pair@(bndr, core_expr)
153 | auto_scc_candidate && worthSCC core_expr &&
154 (opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs))
155 = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
156 returnDs (bndr, Note (SCC (mkAutoCC bndr mod grp IsNotCafCC)) core_expr)
160 worthSCC (Note (SCC _) _) = False
161 worthSCC (Con _ _) = False
162 worthSCC core_expr = True
165 If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
169 | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
170 -- the latter is so that -unprof-auto-scc-all adds dict sccs
171 || not (isDictTy (idType var))
172 = returnDs rhs -- That's easy: do nothing
175 = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
177 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
178 returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)