Desugar.lhs 17.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

The Desugarer: turning HsSyn into Core.
7 8

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
9 10 11 12 13 14 15
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

16
module Desugar ( deSugar, deSugarExpr ) where
17

Simon Marlow's avatar
Simon Marlow committed
18 19 20 21
import DynFlags
import HscTypes
import HsSyn
import TcRnTypes
22
import TcRnMonad ( finalSafeMode )
Simon Marlow's avatar
Simon Marlow committed
23 24 25
import MkIface
import Id
import Name
26
import Type
27 28
import InstEnv
import Class
29
import Avail
30
import CoreSyn
31
import CoreSubst
Simon Marlow's avatar
Simon Marlow committed
32
import PprCore
33
import DsMonad
Simon Marlow's avatar
Simon Marlow committed
34 35 36
import DsExpr
import DsBinds
import DsForeign
37 38
import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
				-- depends on DsExpr.hi-boot.
Simon Marlow's avatar
Simon Marlow committed
39
import Module
Simon Marlow's avatar
Simon Marlow committed
40
import RdrName
41
import NameSet
42
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
43
import Rules
44
import BasicTypes       ( Activation(.. ) )
45
import CoreMonad	( endPass, CoreToDo(..) )
46
import FastString
Simon Marlow's avatar
Simon Marlow committed
47
import ErrUtils
48
import Outputable
Simon Marlow's avatar
Simon Marlow committed
49
import SrcLoc
andy@galois.com's avatar
andy@galois.com committed
50
import Coverage
51
import Util
52 53
import MonadUtils
import OrdList
54
import Data.List
Simon Marlow's avatar
Simon Marlow committed
55
import Data.IORef
56
import Control.Monad( when )
57 58
\end{code}

59 60 61 62 63 64
%************************************************************************
%*									*
%* 		The main function: deSugar
%*									*
%************************************************************************

65
\begin{code}
Thomas Schilling's avatar
Thomas Schilling committed
66
-- | Main entry point to the desugarer.
67
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
68 69 70
-- Can modify PCS by faulting in more declarations

deSugar hsc_env 
andy@galois.com's avatar
andy@galois.com committed
71
        mod_loc
72
        tcg_env@(TcGblEnv { tcg_mod          = mod,
73 74 75 76 77
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
                            tcg_keep	     = keep_var,
78 79
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
80 81 82 83 84 85 86
                            tcg_fix_env      = fix_env,
                            tcg_inst_env     = inst_env,
                            tcg_fam_inst_env = fam_inst_env,
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
                            tcg_imp_specs    = imp_specs,
GregWeber's avatar
GregWeber committed
87
                            tcg_dependent_files = dependent_files,
88 89 90 91
                            tcg_ev_binds     = ev_binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_vects        = vects,
92
                            tcg_tcs          = tcs,
93 94 95
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
                            tcg_hpc          = other_hpc_info })
96

97
  = do { let dflags = hsc_dflags hsc_env
98
        ; showPass dflags "Desugar"
99

100
	-- Desugar the program
101
        ; let export_set = availsToNameSet exports
102
        ; let target = hscTarget dflags
103
        ; let hpcInfo = emptyHpcInfo other_hpc_info
104 105 106 107
	; (msgs, mb_res)
              <- case target of
	           HscNothing ->
                       return (emptyMessages,
108
                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
109
                   _        -> do
110

ian@well-typed.com's avatar
ian@well-typed.com committed
111
                     let want_ticks = dopt Opt_Hpc dflags
112
                                   || target == HscInterpreted
113
                                   || (dopt Opt_SccProfilingOn dflags
114 115 116 117
                                       && case profAuto dflags of
                                            NoProfAuto -> False
                                            _          -> True)

118
                     (binds_cvr,ds_hpc_info, modBreaks)
119 120 121
                         <- if want_ticks && not (isHsBoot hsc_src)
                              then addTicksToBinds dflags mod mod_loc export_set
                                          (typeEnvTyCons type_env) binds
122
                              else return (binds, hpcInfo, emptyModBreaks)
123

124
                     initDs hsc_env mod rdr_env type_env $ do
125
                       do { ds_ev_binds <- dsEvBinds ev_binds
126
                          ; core_prs <- dsTopLHsBinds binds_cvr
127
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
128 129 130
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
                          ; ds_vects <- mapM dsVect vects
131
                          ; let hpc_init
ian@well-typed.com's avatar
ian@well-typed.com committed
132
                                  | dopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
133
                                  | otherwise = empty
134
                          ; return ( ds_ev_binds
135
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
136
                                   , spec_rules ++ ds_rules, ds_vects
137 138
                                   , ds_fords `appendStubC` hpc_init
                                   , ds_hpc_info, modBreaks) }
139

140 141
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
142
           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
sof's avatar
sof committed
143

144 145 146
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
        ; let (rules_for_locals, rules_for_imps) 
147
                   = partition isLocalRule all_rules
148
              final_prs = addExportFlagsAndRules target
149
                              export_set keep_alive rules_for_locals (fromOL all_prs)
150 151

              final_pgm = combineEvBinds ds_ev_binds final_prs
152 153 154 155 156
        -- 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#!
157

158
#ifdef DEBUG
dimitris's avatar
dimitris committed
159
          -- Debug only as pre-simple-optimisation program may be really big
160 161
        ; endPass dflags CoreDesugar final_pgm rules_for_imps 
#endif
162
        ; (ds_binds, ds_rules_for_imps, ds_vects) 
163
            <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
164 165
                         -- The simpleOptPgm gets rid of type 
                         -- bindings plus any stupid dead code
sof's avatar
sof committed
166

167
        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
168

169
        ; let used_names = mkUsedNames tcg_env
170
        ; deps <- mkDependencies tcg_env
Simon Marlow's avatar
Simon Marlow committed
171

172
        ; used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
173
        ; dep_files <- readIORef dependent_files
174
        ; safe_mode <- finalSafeMode dflags tcg_env
175 176

        ; let mod_guts = ModGuts {
177 178 179 180 181
                mg_module       = mod,
                mg_boot	        = isHsBoot hsc_src,
                mg_exports      = exports,
                mg_deps	        = deps,
                mg_used_names   = used_names,
182 183
                mg_used_th      = used_th,
                mg_dir_imps     = imp_mods imports,
184 185 186 187 188 189 190 191 192 193 194 195 196
                mg_rdr_env      = rdr_env,
                mg_fix_env      = fix_env,
                mg_warns        = warns,
                mg_anns         = anns,
                mg_tcs          = tcs,
                mg_insts        = insts,
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
                mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
197
                mg_modBreaks    = modBreaks,
198
                mg_vect_decls   = ds_vects,
199
                mg_vect_info    = noVectInfo,
200
                mg_safe_haskell = safe_mode,
GregWeber's avatar
GregWeber committed
201 202
                mg_trust_pkg    = imp_trust_own_pkg imports,
                mg_dependent_files = dep_files
203
              }
204
        ; return (msgs, Just mod_guts)
205
	}}}
206

207 208 209 210 211
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs imp_specs
 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
      ; let (spec_binds, spec_rules) = unzip spec_prs
      ; return (concatOL spec_binds, spec_rules) }
212

batterseapower's avatar
batterseapower committed
213
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
214 215 216 217
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
combineEvBinds [] val_prs 
  = [Rec val_prs]
batterseapower's avatar
batterseapower committed
218
combineEvBinds (NonRec b r : bs) val_prs
219 220
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
batterseapower's avatar
batterseapower committed
221
combineEvBinds (Rec prs : bs) val_prs 
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
  = combineEvBinds bs (prs ++ val_prs)
\end{code}

Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
because the occurrence analyser doesn't teke account of type/coercion variables
when computing dependencies.  

So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.


\begin{code}
237
deSugarExpr :: HscEnv
238
	    -> Module -> GlobalRdrEnv -> TypeEnv 
239
 	    -> LHsExpr Id
240
	    -> IO (Messages, Maybe CoreExpr)
241 242
-- Prints its own errors; returns Nothing if error occurred

243 244 245
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
    let dflags = hsc_dflags hsc_env
    showPass dflags "Desugar"
246

247 248 249
    -- Do desugaring
    (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
                                   dsLExpr tc_expr
250

251 252 253
    case mb_core_expr of
      Nothing   -> return (msgs, Nothing)
      Just expr -> do
254

255 256
        -- Dump output
        dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
257

258
        return (msgs, Just expr)
259
\end{code}
260

261 262 263 264 265 266 267 268 269 270 271 272
%************************************************************************
%*									*
%* 		Add rules and export flags to binders
%*									*
%************************************************************************

\begin{code}
addExportFlagsAndRules 
    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
    -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules target exports keep_alive rules prs
  = mapFst add_one prs
273
  where
274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292
    add_one bndr = add_rules name (add_export name bndr)
       where
         name = idName bndr

    ---------- Rules --------
	-- See Note [Attach rules to local ids]
	-- NB: the binder might have some existing rules,
	-- arising from specialisation pragmas
    add_rules name bndr
	| Just rules <- lookupNameEnv rule_base name
	= bndr `addIdSpecialisations` rules
	| otherwise
	= bndr
    rule_base = extendRuleBaseList emptyRuleBase rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    add_export name bndr
	| dont_discard name = setIdExported bndr
293
	| otherwise	    = bndr
294

295 296
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
297 298 299 300 301 302 303 304 305 306
		     || name `elemNameSet` keep_alive

    	-- 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
307 308
    is_exported | targetRetainsAllBindings target = isExternalName
                | otherwise                       = (`elemNameSet` exports)
309 310
\end{code}

sof's avatar
sof committed
311

312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
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.

Note [Attach rules to local ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Find the rules for locally-defined Ids; then we can attach them
to the binders in the top-level bindings

Reason
  - It makes the rules easier to look up
  - It means that transformation rules and specialisations for
    locally defined Ids are handled uniformly
  - It keeps alive things that are referred to only from a rule
    (the occurrence analyser knows about rules attached to Ids)
  - It makes sure that, when we apply a rule, the free vars
    of the RHS are more likely to be in scope
  - The imported rules are carried in the in-scope set
    which is extended on each iteration by the new wave of
    local binders; any rules which aren't on the binding will
    thereby get dropped

347 348 349 350 351 352 353 354

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

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
355 356
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
357
  = putSrcSpanDs loc $ 
358
    do	{ let bndrs' = [var | RuleBndr (L _ var) <- vars]
359

360
        ; lhs' <- unsetDOptM Opt_EnableRewriteRules $
361
                  unsetWOptM Opt_WarnIdentities $
362
                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
363

364
	; rhs' <- dsLExpr rhs
365
        ; dflags <- getDynFlags
366 367 368

	-- Substitute the dict bindings eagerly,
	-- and take the body apart into a (f args) form
369 370 371
	; case decomposeRuleLhs bndrs' lhs' of {
		Left msg -> do { warnDs msg; return Nothing } ;
		Right (final_bndrs, fn_id, args) -> do
372
	
373
	{ let is_local = isLocalId fn_id
374 375 376
		-- NB: isLocalId is False of implicit Ids.  This is good becuase
		-- we don't want to attach rules to the bindings of implicit Ids, 
		-- because they don't show up in the bindings until just before code gen
377 378
	      fn_name   = idName fn_id
	      final_rhs = simpleOptExpr rhs'	-- De-crap it
379
	      rule      = mkRule False {- Not auto -} is_local 
380
                                 name act fn_name final_bndrs args final_rhs
381 382

              inline_shadows_rule   -- Function can be inlined before rule fires
383
                | wopt Opt_WarnInlineRuleShadowing dflags
384 385 386 387 388
                = case (idInlineActivation fn_id, act) of
                    (NeverActive, _)    -> False
                    (AlwaysActive, _)   -> True
                    (ActiveBefore {}, _) -> True
                    (ActiveAfter {}, NeverActive)     -> True
389
                    (ActiveAfter n, ActiveAfter r)    -> r < n  -- Rule active strictly first
390 391
                    (ActiveAfter {}, AlwaysActive)    -> False
                    (ActiveAfter {}, ActiveBefore {}) -> False
392
                | otherwise = False
393 394 395 396

        ; when inline_shadows_rule $
          warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
                               <+> ptext (sLit "may never fire"))
pcapriotti's avatar
pcapriotti committed
397
                            2 (ptext (sLit "because") <+> quotes (ppr fn_id)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
398
                               <+> ptext (sLit "might inline first"))
399 400 401
                       , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")
                         <+> quotes (ppr fn_id) ])

402 403
	; return (Just rule)
	} } }
404
\end{code}
405

406 407 408 409 410 411
Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
    [x]   to    build (\cn. x `c` n)
We want to leave explicit lists simply as chains
of cons's. We can achieve that slightly indirectly by
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
412
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
413 414

That keeps the desugaring of list comprehensions simple too.
415

416 417


418 419 420
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
421 422 423 424 425 426 427 428 429 430


%************************************************************************
%*                                                                      *
%*              Desugaring vectorisation declarations
%*                                                                      *
%************************************************************************

\begin{code}
dsVect :: LVectDecl Id -> DsM CoreVect
431
dsVect (L loc (HsVect (L _ v) rhs))
432 433
  = putSrcSpanDs loc $ 
    do { rhs' <- fmapMaybeM dsLExpr rhs
434
       ; return $ Vect v rhs'
435
       }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
436
dsVect (L _loc (HsNoVect (L _ v)))
437
  = return $ NoVect v
438
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
439 440 441 442 443
  = return $ VectType isScalar tycon' rhs_tycon
  where
    tycon' | Just ty <- coreView $ mkTyConTy tycon
           , (tycon', []) <- splitTyConApp ty      = tycon'
           | otherwise                             = tycon
444
dsVect vd@(L _ (HsVectTypeIn _ _ _))
445
  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
446 447 448 449
dsVect (L _loc (HsVectClassOut cls))
  = return $ VectClass (classTyCon cls)
dsVect vc@(L _ (HsVectClassIn _))
  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
450 451 452
dsVect (L _loc (HsVectInstOut inst))
  = return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
453
  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
454
\end{code}