1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Desugar]{@deSugar@: the main function}
\begin{code}
module Desugar ( deSugar ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import Id ( Id )
import CoreSyn
import PprCore ( pprIdCoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module )
import Id ( Id )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
import CoreLint ( showPass, endPass )
import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import HscTypes ( HomeSymbolTable )
\end{code}
%************************************************************************
%* *
%* The main function: deSugar
%* *
%************************************************************************
The only trick here is to get the @DsMonad@ stuff off to a good
start.
\begin{code}
deSugar :: DynFlags
-> Module -> PrintUnqualified
-> HomeSymbolTable
-> TcResults
-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name unqual hst
(TcResults {tc_env = global_val_env,
tc_pcs = pcs,
tc_binds = all_binds,
tc_rules = rules,
tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
-- Do desugaring
; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name
(dsProgram mod_name all_binds rules fo_decls)
(ds_binds, ds_rules, _, _, _) = result
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
(printErrs unqual (pprBagOfWarnings ds_warns))
-- Lint result if necessary
; let do_dump_ds = dopt Opt_D_dump_ds dflags
; endPass dflags "Desugar" do_dump_ds ds_binds
-- Dump output
; doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
; return result
}
-- deSugarExpr dflags unqual hst tc_expr
-- = do {
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
let
ds_binds = [Rec (foreign_binds ++ core_prs)]
-- Notice that we put the whole lot in a big Rec, even the foreign binds
-- When compiling PrelFloat, which defines data Float = F# Float#
-- we want F# to be in scope in the foreign marshalling code!
-- You might think it doesn't matter, but the simplifier brings all top-level
-- things into the in-scope set before simplifying; so we get no unfolding for F#!
local_binders = mkVarSet (bindersOfBinds ds_binds)
in
mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
returnDs (ds_binds, rules', h_code, c_code, fe_binders)
where
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
vcat (map pprIdCoreRule rules)
\end{code}
%************************************************************************
%* *
%* Desugaring transformation rules
%* *
%************************************************************************
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
returnDs (fn, Rule name tpl_vars args core_rhs)
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
ds_lhs all_vars lhs
= let
(dict_binds, body) = case lhs of
(HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body)
other -> (EmptyMonoBinds, lhs)
in
ds_dict_binds dict_binds `thenDs` \ dict_binds' ->
dsExpr body `thenDs` \ body' ->
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
let
subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds']
[ContEx subst_env rhs | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
subst = mkSubst all_vars subst_env
body'' = substExpr subst body'
in
-- Now unpack the resulting body
let
pair = case collectArgs body'' of
(Var fn, args) -> (fn, args)
other -> pprPanic "dsRule" (ppr lhs)
in
returnDs pair
ds_dict_binds EmptyMonoBinds = returnDs []
ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 ->
ds_dict_binds b2 `thenDs` \ env2 ->
returnDs (env1 ++ env2)
ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' ->
returnDs [(id,rhs')]
\end{code}
|
