summaryrefslogtreecommitdiff
path: root/ghc/compiler/deSugar/Desugar.lhs
blob: 153cc1a32328582d4822cd35e96c791813317734 (plain)
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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Desugar]{@deSugar@: the main function}

\begin{code}
module Desugar ( deSugar, deSugarExpr ) where

#include "HsVersions.h"

import CmdLineOpts	( DynFlag(..), dopt, opt_SccProfilingOn )
import HscTypes		( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
			  Dependencies(..), TypeEnv, 
	  		  unQualInScope, availsToNameSet )
import HsSyn		( MonoBinds, RuleDecl(..), RuleBndr(..), 
			  HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn		( TypecheckedRuleDecl, TypecheckedHsExpr )
import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
import MkIface		( mkUsageInfo )
import Id		( Id, setIdLocalExported, idName )
import Name		( Name, isExternalName )
import CoreSyn
import PprCore		( pprIdRules, pprCoreExpr )
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, moduleEnvElts, emptyModuleEnv )
import Id		( Id )
import RdrName	 	( GlobalRdrEnv )
import NameSet
import VarEnv
import VarSet
import Bag		( isEmptyBag, mapBag, emptyBag )
import CoreLint		( showPass, endPass )
import CoreFVs		( ruleRhsFreeVars )
import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, 
			  addShortWarnLocLine, errorsFound )
import Outputable
import qualified Pretty
import UniqSupply	( mkSplitUniqSupply )
import SrcLoc		( SrcLoc )
import DATA_IOREF	( readIORef )
import FastString
\end{code}

%************************************************************************
%*									*
%* 		The main function: deSugar
%*									*
%************************************************************************

\begin{code}
deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
-- Can modify PCS by faulting in more declarations

deSugar hsc_env 
        tcg_env@(TcGblEnv { tcg_mod       = mod,
		    	    tcg_type_env  = type_env,
		    	    tcg_imports   = imports,
		    	    tcg_exports   = exports,
		    	    tcg_dus	  = dus, 
		    	    tcg_inst_uses = dfun_uses_var,
		    	    tcg_rdr_env   = rdr_env,
		    	    tcg_fix_env   = fix_env,
	    	    	    tcg_deprecs   = deprecs,
		    	    tcg_insts     = insts })
  = do	{ showPass dflags "Desugar"

	-- Do desugaring
	; let { is_boot = imp_dep_mods imports }
	; (results, warnings) <- initDs hsc_env mod type_env is_boot $
				 dsProgram ghci_mode tcg_env

	; let { (ds_binds, ds_rules, ds_fords) = results
	      ; warns    = mapBag mk_warn warnings
	      ; warn_doc = pprBagOfWarnings warns }

	-- Display any warnings
        ; doIfSet (not (isEmptyBag warnings))
		  (printErrs warn_doc)

	-- If warnings are considered errors, leave.
	; if errorsFound dflags (warns, emptyBag)
	   then return Nothing
	   else do

	-- Lint result if necessary
	{ endPass dflags "Desugar" Opt_D_dump_ds ds_binds

	-- Dump output
	; doIfSet (dopt Opt_D_dump_ds dflags) 
		  (printDump (ppr_ds_rules ds_rules))

	; dfun_uses <- readIORef dfun_uses_var		-- What dfuns are used
	; let used_names = allUses dus `unionNameSets` dfun_uses
	; usages <- mkUsageInfo hsc_env imports used_names
	; let 
	     deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), 
			   dep_pkgs = imp_dep_pkgs imports,
			   dep_orphs = imp_orphs imports }
	     mod_guts = ModGuts {	
		mg_module   = mod,
		mg_exports  = exports,
		mg_deps	    = deps,
		mg_usages   = usages,
		mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)],
	        mg_rdr_env  = rdr_env,
		mg_fix_env  = fix_env,
		mg_deprecs  = deprecs,
		mg_types    = type_env,
		mg_insts    = insts,
	        mg_rules    = ds_rules,
		mg_binds    = ds_binds,
		mg_foreign  = ds_fords }
	
        ; return (Just mod_guts)
	}}

  where
    dflags       = hsc_dflags hsc_env
    ghci_mode    = hsc_mode hsc_env
    print_unqual = unQualInScope rdr_env

	-- Desugarer warnings are SDocs; here we
	-- add the info about whether or not to print unqualified
    mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
    mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc


deSugarExpr :: HscEnv
	    -> Module -> GlobalRdrEnv -> TypeEnv 
 	    -> TypecheckedHsExpr
	    -> IO CoreExpr
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
  = do	{ showPass dflags "Desugar"
	; us <- mkSplitUniqSupply 'd'

	-- Do desugaring
	; let { is_boot = emptyModuleEnv }	-- Assume no hi-boot files when
						-- doing stuff from the command line
	; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $
				   dsExpr tc_expr

	-- Display any warnings 
	-- Note: if -Werror is used, we don't signal an error here.
        ; doIfSet (not (isEmptyBag ds_warns))
		  (printErrs (pprBagOfWarnings (mapBag mk_warn ds_warns)))

	-- Dump output
	; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)

        ; return core_expr
	}
  where
    dflags       = hsc_dflags hsc_env
    print_unqual = unQualInScope rdr_env

    mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
    mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc


dsProgram ghci_mode (TcGblEnv { tcg_exports = exports,
		      		tcg_keep    = keep_alive,
		      		tcg_binds   = binds,
		      		tcg_fords   = fords,
		      		tcg_rules   = rules })
  = dsMonoBinds auto_scc binds []	`thenDs` \ core_prs ->
    dsForeigns fords			`thenDs` \ (ds_fords, foreign_prs) ->
    let
	all_prs = foreign_prs ++ core_prs
	local_bndrs = mkVarSet (map fst all_prs)
    in
    mappM (dsRule local_bndrs) rules	`thenDs` \ ds_rules ->
    let
	final_prs = addExportFlags ghci_mode exports keep_alive 
				   local_bndrs all_prs ds_rules
	ds_binds  = [Rec final_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#!
    in
    returnDs (ds_binds, ds_rules, ds_fords)
  where
    auto_scc | opt_SccProfilingOn = TopLevel
	     | otherwise          = NoSccs

--		addExportFlags
-- Set the no-discard flag if either 
--	a) the Id is exported
--	b) it's mentioned in the RHS of an orphan rule
--	c) it's in the keep-alive set
--
-- It means that the binding won't be discarded EVEN if the binding
-- ends up being trivial (v = w) -- the simplifier would usually just 
-- substitute w for v throughout, but we don't apply the substitution to
-- the rules (maybe we should?), so this substitution would make the rule
-- bogus.

-- You might wonder why exported Ids aren't already marked as such;
-- it's just because the type checker is rather busy already and
-- I didn't want to pass in yet another mapping.

addExportFlags ghci_mode exports keep_alive bndrs prs rules
  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
  where
    add_export bndr | dont_discard bndr = setIdLocalExported bndr
		    | otherwise	        = bndr

    orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
			        | (id, rule) <- rules, 
				  not (id `elemVarSet` bndrs) ]
	-- An orphan rule must keep alive the free vars 
	-- of its right-hand side.  
	-- Non-orphan rules are attached to the Id (bndr_with_rules above)
	-- and that keeps the rhs free vars alive

    dont_discard bndr = is_exported name
		     || name `elemNameSet` keep_alive
		     || bndr `elemVarSet` orph_rhs_fvs 
		     where
			name = idName bndr

    	-- In interactive mode, we don't want to discard any top-level
    	-- entities at all (eg. do not inline them away during
    	-- simplification), and retain them all in the TypeEnv so they are
    	-- available from the command line.
	--
	-- isExternalName separates the user-defined top-level names from those
	-- introduced by the type checker.
    is_exported :: Name -> Bool
    is_exported | ghci_mode == Interactive = isExternalName
		| otherwise 		   = (`elemNameSet` export_fvs)

    export_fvs = availsToNameSet exports

ppr_ds_rules [] = empty
ppr_ds_rules rules
  = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
    pprIdRules rules
\end{code}



%************************************************************************
%*									*
%* 		Desugaring transformation rules
%*									*
%************************************************************************

\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (HsRule name act vars lhs rhs loc)
  = putSrcLocDs loc		$
    ds_lhs all_vars lhs		`thenDs` \ (fn, args) ->
    dsExpr rhs			`thenDs` \ core_rhs ->
    returnDs (fn, Rule name act tpl_vars args core_rhs)
  where
    tpl_vars = [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}