Desugar.lhs 10.5 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6
%
\section[Desugar]{@deSugar@: the main function}

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

9
#include "HsVersions.h"
10

11
import DynFlags		( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
12 13 14
import StaticFlags	( opt_SccProfilingOn,
			  opt_AutoSccsOnAllToplevs,
			  opt_AutoSccsOnExportedToplevs )
15
import DriverPhases	( isHsBoot )
16
import HscTypes		( ModGuts(..), HscEnv(..), 
17
			  Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
18
import HsSyn		( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
19
import TcRnTypes	( TcGblEnv(..), ImportAvails(..) )
20
import MkIface		( mkUsageInfo )
21 22
import Id		( Id, setIdExported, idName )
import Name		( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
23
import CoreSyn
24
import PprCore		( pprRules, pprCoreExpr )
25
import DsMonad
26
import DsExpr		( dsLExpr )
27
import DsBinds		( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
sof's avatar
sof committed
28
import DsForeign	( dsForeigns )
29 30
import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
				-- depends on DsExpr.hi-boot.
Simon Marlow's avatar
Simon Marlow committed
31 32 33
import Module
import UniqFM		( eltsUFM, delFromUFM )
import PackageConfig	( thPackageId )
34 35
import RdrName	 	( GlobalRdrEnv )
import NameSet
36
import VarSet
37
import Rules		( roughTopNames )
38
import CoreLint		( showPass, endPass )
39
import CoreFVs		( ruleRhsFreeVars, exprsFreeNames )
40
import ErrUtils		( doIfSet, dumpIfSet_dyn )
41
import ListSetOps	( insertList )
42
import Outputable
43
import SrcLoc		( Located(..) )
44
import DATA_IOREF	( readIORef )
45
import Maybes		( catMaybes )
46
import FastString
47
import Util		( sortLe )
48 49
\end{code}

50 51 52 53 54 55
%************************************************************************
%*									*
%* 		The main function: deSugar
%*									*
%************************************************************************

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

deSugar hsc_env 
61
        tcg_env@(TcGblEnv { tcg_mod       = mod,
62
			    tcg_src	  = hsc_src,
63 64 65 66 67
		    	    tcg_type_env  = type_env,
		    	    tcg_imports   = imports,
		    	    tcg_exports   = exports,
		    	    tcg_dus	  = dus, 
		    	    tcg_inst_uses = dfun_uses_var,
68
			    tcg_th_used   = th_var,
69
			    tcg_keep	  = keep_var,
70 71 72
		    	    tcg_rdr_env   = rdr_env,
		    	    tcg_fix_env   = fix_env,
	    	    	    tcg_deprecs   = deprecs,
73 74 75
			    tcg_binds     = binds,
			    tcg_fords     = fords,
			    tcg_rules     = rules,
76 77
		    	    tcg_insts     = insts,
		    	    tcg_fam_insts = fam_insts })
78
  = do	{ showPass dflags "Desugar"
79

80
	-- Desugar the program
81 82
	; let auto_scc = mkAutoScc mod exports

83 84
	; mb_res <- case ghcMode dflags of
	             JustTypecheck -> return (Just ([], [], NoStubs))
85 86 87 88 89 90 91 92
	             _             -> initDs hsc_env mod rdr_env type_env $ do
		                        { core_prs <- dsTopLHsBinds auto_scc binds
		                        ; (ds_fords, foreign_prs) <- dsForeigns fords
		                        ; let all_prs = foreign_prs ++ core_prs
		                              local_bndrs = mkVarSet (map fst all_prs)
		                        ; ds_rules <- mappM (dsRule mod local_bndrs) rules
		                        ; return (all_prs, catMaybes ds_rules, ds_fords)
		                        }
93 94 95
	; case mb_res of {
	   Nothing -> return Nothing ;
	   Just (all_prs, ds_rules, ds_fords) -> do
sof's avatar
sof committed
96

97 98 99
	{ 	-- Add export flags to bindings
	  keep_alive <- readIORef keep_var
	; let final_prs = addExportFlags ghci_mode exports keep_alive 
100
			   	 all_prs ds_rules
101 102 103 104 105 106 107
	      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#!

108
	-- Lint result if necessary
109
	; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
sof's avatar
sof committed
110

111
	-- Dump output
112
	; doIfSet (dopt Opt_D_dump_ds dflags) 
113 114
		  (printDump (ppr_ds_rules ds_rules))

115
	; dfun_uses <- readIORef dfun_uses_var		-- What dfuns are used
116
	; th_used   <- readIORef th_var			-- Whether TH is used
117
	; let used_names = allUses dus `unionNameSets` dfun_uses
Simon Marlow's avatar
Simon Marlow committed
118 119
	      pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
	      	   | otherwise = imp_dep_pkgs imports
120

Simon Marlow's avatar
Simon Marlow committed
121
	      dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
122 123
		-- M.hi-boot can be in the imp_dep_mods, but we must remove
		-- it before recording the modules on which this one depends!
124 125 126 127 128 129
		-- (We want to retain M.hi-boot in imp_dep_mods so that 
		--  loadHiBootInterface can see if M's direct imports depend 
		--  on M.hi-boot, and hence that we should do the hi-boot consistency 
		--  check.)

	      dir_imp_mods = imp_mods imports
130

Simon Marlow's avatar
Simon Marlow committed
131 132
	; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names

133
	; let 
134
		-- Modules don't compare lexicographically usually, 
135
		-- but we want them to do so here.
136
	     le_mod :: Module -> Module -> Bool	 
Simon Marlow's avatar
Simon Marlow committed
137 138 139 140
	     le_mod m1 m2 = moduleNameFS (moduleName m1) 
				<= moduleNameFS (moduleName m2)
	     le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool	 
	     le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
141

142
	     deps = Deps { dep_mods  = sortLe le_dep_mod dep_mods,
143 144
			   dep_pkgs  = sortLe (<=)   pkgs,	
			   dep_orphs = sortLe le_mod (imp_orphs imports) }
145 146
		-- sort to get into canonical order

147
	     mod_guts = ModGuts {	
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162
		mg_module    = mod,
		mg_boot	     = isHsBoot hsc_src,
		mg_exports   = exports,
		mg_deps	     = deps,
		mg_usages    = usages,
		mg_dir_imps  = [m | (m,_,_) <- moduleEnvElts dir_imp_mods],
	        mg_rdr_env   = rdr_env,
		mg_fix_env   = fix_env,
		mg_deprecs   = deprecs,
		mg_types     = type_env,
		mg_insts     = insts,
		mg_fam_insts = fam_insts,
	        mg_rules     = ds_rules,
		mg_binds     = ds_binds,
		mg_foreign   = ds_fords }
163
	
164 165
        ; return (Just mod_guts)
	}}}
166

167
  where
168 169
    dflags    = hsc_dflags hsc_env
    ghci_mode = ghcMode (hsc_dflags hsc_env)
170 171 172 173 174 175 176 177 178 179 180 181

mkAutoScc :: Module -> NameSet -> AutoScc
mkAutoScc mod exports
  | not opt_SccProfilingOn 	-- No profiling
  = NoSccs		
  | opt_AutoSccsOnAllToplevs 	-- Add auto-scc on all top-level things
  = AddSccs mod (\id -> True)
  | opt_AutoSccsOnExportedToplevs	-- Only on exported things
  = AddSccs mod (\id -> idName id `elemNameSet` exports)
  | otherwise
  = NoSccs

182

183
deSugarExpr :: HscEnv
184
	    -> Module -> GlobalRdrEnv -> TypeEnv 
185
 	    -> LHsExpr Id
186 187 188
	    -> IO (Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred

189
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
190 191
  = do	{ let dflags = hsc_dflags hsc_env
	; showPass dflags "Desugar"
192 193

	-- Do desugaring
194 195
	; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
			  dsLExpr tc_expr
196

197 198 199
	; case mb_core_expr of {
	    Nothing   -> return Nothing ;
	    Just expr -> do {
200

201 202
		-- Dump output
	  dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
203

204
        ; return (Just expr) } } }
205

206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
--		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.

222
addExportFlags ghci_mode exports keep_alive prs rules
223 224
  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
  where
225
    add_export bndr
226 227
	| dont_discard bndr = setIdExported bndr
	| otherwise	    = bndr
228 229

    orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
230 231 232 233 234 235
			        | rule <- rules, 
				  not (isLocalRule rule) ]
	-- A non-local rule keeps alive the free vars of its right-hand side. 
	-- (A "non-local" is one whose head function is not locally defined.)
	-- Local rules are (later, after gentle simplification) 
	-- attached to the Id, and that keeps the rhs free vars alive.
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251

    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
252
		| otherwise 		   = (`elemNameSet` exports)
253

254 255 256
ppr_ds_rules [] = empty
ppr_ds_rules rules
  = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
257
    pprRules rules
258 259
\end{code}

sof's avatar
sof committed
260

261 262 263 264 265 266 267 268

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

\begin{code}
269
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
270
dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
271
  = putSrcSpanDs loc $ 
272 273 274
    do	{ let bndrs     = [var | RuleBndr (L _ var) <- vars]
	; lhs'  <- dsLExpr lhs
	; rhs'  <- dsLExpr rhs
275

276
	; case decomposeRuleLhs bndrs lhs' of {
277
		Nothing -> do { warnDs msg; return Nothing } ;
278 279
		Just (bndrs', fn_id, args) -> do
	
280 281
	-- Substitute the dict bindings eagerly,
	-- and take the body apart into a (f args) form
282
	{ let local_rule = nameIsLocalOrFrom mod fn_name
283 284
		-- NB we can't use isLocalId in the orphan test, 
		-- because isLocalId isn't true of class methods
285 286
	      fn_name   = idName fn_id
	      lhs_names = fn_name : nameSetToList (exprsFreeNames args)
287
		-- No need to delete bndrs, because
288
		-- exprsFreeNames finds only External names
289 290 291

		-- A rule is an orphan only if none of the variables
		-- mentioned on its left-hand side are locally defined
292 293 294 295
	      orph = case filter (nameIsLocalOrFrom mod) lhs_names of
			(n:ns) -> Just (nameOccName n)
			[]     -> Nothing

296 297 298 299 300 301 302 303 304
	      rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
			    ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', 
			    ru_rough = roughTopNames args, 
			    ru_local = local_rule, ru_orph = orph }
	; return (Just rule)
	} } }
  where
    msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
	     2 (ppr lhs)
305
\end{code}