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

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

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

deSugar hsc_env 
andy@galois.com's avatar
andy@galois.com committed
72
        mod_loc
73
        tcg_env@(TcGblEnv { tcg_mod          = mod,
74 75 76 77 78
                            tcg_src          = hsc_src,
                            tcg_type_env     = type_env,
                            tcg_imports      = imports,
                            tcg_exports      = exports,
                            tcg_keep	     = keep_var,
79 80
                            tcg_th_splice_used = tc_splice_used,
                            tcg_rdr_env      = rdr_env,
81 82 83 84 85 86 87
                            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
88
                            tcg_dependent_files = dependent_files,
89 90 91 92
                            tcg_ev_binds     = ev_binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_vects        = vects,
93
                            tcg_tcs          = tcs,
94 95 96
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts,
                            tcg_hpc          = other_hpc_info })
97

98 99
  = do { let dflags = hsc_dflags hsc_env
             platform = targetPlatform dflags
100
        ; showPass dflags "Desugar"
101

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

                     let want_ticks = opt_Hpc
                                   || target == HscInterpreted
                                   || (opt_SccProfilingOn
                                       && case profAuto dflags of
                                            NoProfAuto -> False
                                            _          -> True)

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

126
                     initDs hsc_env mod rdr_env type_env $ do
127
                       do { ds_ev_binds <- dsEvBinds ev_binds
128
                          ; core_prs <- dsTopLHsBinds binds_cvr
129
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
130 131 132
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
                          ; ds_vects <- mapM dsVect vects
133
                          ; let hpc_init
134
                                  | opt_Hpc   = hpcInitCode platform mod ds_hpc_info
135
                                  | otherwise = empty
136
                          ; return ( ds_ev_binds
137
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
138
                                   , spec_rules ++ ds_rules, ds_vects
139 140
                                   , ds_fords `appendStubC` hpc_init
                                   , ds_hpc_info, modBreaks) }
141

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

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

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

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

169
        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
170

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

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

        ; let mod_guts = ModGuts {
179 180 181 182 183
                mg_module       = mod,
                mg_boot	        = isHsBoot hsc_src,
                mg_exports      = exports,
                mg_deps	        = deps,
                mg_used_names   = used_names,
184 185
                mg_used_th      = used_th,
                mg_dir_imps     = imp_mods imports,
186 187 188 189 190 191 192 193 194 195 196 197 198
                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,
199
                mg_modBreaks    = modBreaks,
200
                mg_vect_decls   = ds_vects,
201
                mg_vect_info    = noVectInfo,
202
                mg_safe_haskell = safe_mode,
GregWeber's avatar
GregWeber committed
203 204
                mg_trust_pkg    = imp_trust_own_pkg imports,
                mg_dependent_files = dep_files
205
              }
206
        ; return (msgs, Just mod_guts)
207
	}}}
208

209 210 211 212 213
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) }
214

batterseapower's avatar
batterseapower committed
215
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
216 217 218 219
-- 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
220
combineEvBinds (NonRec b r : bs) val_prs
221 222
  | isId b    = combineEvBinds bs ((b,r):val_prs)
  | otherwise = NonRec b r : combineEvBinds bs val_prs
batterseapower's avatar
batterseapower committed
223
combineEvBinds (Rec prs : bs) val_prs 
224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
  = 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}
239
deSugarExpr :: HscEnv
240
	    -> Module -> GlobalRdrEnv -> TypeEnv 
241
 	    -> LHsExpr Id
242
	    -> IO (Messages, Maybe CoreExpr)
243 244
-- Prints its own errors; returns Nothing if error occurred

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

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

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

257 258
        -- Dump output
        dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
259

260
        return (msgs, Just expr)
261
\end{code}
262

263 264 265 266 267 268 269 270 271 272 273 274
%************************************************************************
%*									*
%* 		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
275
  where
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
    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
295
	| otherwise	    = bndr
296

297 298
    dont_discard :: Name -> Bool
    dont_discard name = is_exported name
299 300 301 302 303 304 305 306 307 308
		     || 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
309 310
    is_exported | targetRetainsAllBindings target = isExternalName
                | otherwise                       = (`elemNameSet` exports)
311 312
\end{code}

sof's avatar
sof committed
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 347 348
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

349 350 351 352 353 354 355 356

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

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

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

366
	; rhs' <- dsLExpr rhs
367 368 369

	-- Substitute the dict bindings eagerly,
	-- and take the body apart into a (f args) form
370 371 372
	; case decomposeRuleLhs bndrs' lhs' of {
		Left msg -> do { warnDs msg; return Nothing } ;
		Right (final_bndrs, fn_id, args) -> do
373
	
374
	{ let is_local = isLocalId fn_id
375 376 377
		-- 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
378 379
	      fn_name   = idName fn_id
	      final_rhs = simpleOptExpr rhs'	-- De-crap it
380
	      rule      = mkRule False {- Not auto -} is_local 
381
                                 name act fn_name final_bndrs args final_rhs
382 383 384 385 386 387 388

              inline_shadows_rule   -- Function can be inlined before rule fires
                = 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 392 393 394 395 396 397
                    (ActiveAfter {}, AlwaysActive)    -> False
                    (ActiveAfter {}, ActiveBefore {}) -> False
                                       

        ; when inline_shadows_rule $
          warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
                               <+> ptext (sLit "may never fire"))
                            2 (ptext (sLit "becuase") <+> 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}