Desugar.lhs 16 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 CoreMonad	( endPass, CoreToDo(..) )
Simon Marlow's avatar
Simon Marlow committed
46
import ErrUtils
47
import Outputable
Simon Marlow's avatar
Simon Marlow committed
48
import SrcLoc
andy@galois.com's avatar
andy@galois.com committed
49
import Coverage
50
import Util
51 52
import MonadUtils
import OrdList
53
import Data.List
Simon Marlow's avatar
Simon Marlow committed
54
import Data.IORef
55 56
\end{code}

57 58 59 60 61 62
%************************************************************************
%*									*
%* 		The main function: deSugar
%*									*
%************************************************************************

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

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

95 96
  = do { let dflags = hsc_dflags hsc_env
             platform = targetPlatform dflags
97
        ; showPass dflags "Desugar"
98

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

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

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

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

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

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

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

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

166
        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
167

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

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

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

206 207 208 209 210
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) }
211

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

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

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

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

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

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

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

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

sof's avatar
sof committed
310

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
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

346 347 348 349 350 351 352 353

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

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

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

363
	; rhs' <- dsLExpr rhs
364 365 366

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

383 384 385 386 387 388
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
389
switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
390 391

That keeps the desugaring of list comprehensions simple too.
392

393 394


395 396 397
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 #-}
398 399 400 401 402 403 404 405 406 407


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

\begin{code}
dsVect :: LVectDecl Id -> DsM CoreVect
408
dsVect (L loc (HsVect (L _ v) rhs))
409 410
  = putSrcSpanDs loc $ 
    do { rhs' <- fmapMaybeM dsLExpr rhs
411
       ; return $ Vect v rhs'
412
       }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
413
dsVect (L _loc (HsNoVect (L _ v)))
414
  = return $ NoVect v
415
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
416 417 418 419 420
  = return $ VectType isScalar tycon' rhs_tycon
  where
    tycon' | Just ty <- coreView $ mkTyConTy tycon
           , (tycon', []) <- splitTyConApp ty      = tycon'
           | otherwise                             = tycon
421
dsVect vd@(L _ (HsVectTypeIn _ _ _))
422
  = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
423 424 425 426
dsVect (L _loc (HsVectClassOut cls))
  = return $ VectClass (classTyCon cls)
dsVect vc@(L _ (HsVectClassIn _))
  = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
427 428 429
dsVect (L _loc (HsVectInstOut inst))
  = return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
430
  = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
431
\end{code}