compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The Desugarer: turning HsSyn into Core.
   7
   8 \begin{code}
   9 module Desugar ( deSugar, deSugarExpr ) where
  10
  11 import DynFlags
  12 import StaticFlags
  13 import HscTypes
  14 import HsSyn
  15 import TcRnTypes
  16 import MkIface
  17 import Id
  18 import Name
  19 import CoreSyn
  20 import CoreSubst
  21 import PprCore
  22 import DsMonad
  23 import DsExpr
  24 import DsBinds
  25 import DsForeign
  26 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  27                                 -- depends on DsExpr.hi-boot.
  28 import Module
  29 import RdrName
  30 import NameSet
  31 import NameEnv
  32 import Rules
  33 import CoreMonad        ( endPass, CoreToDo(..) )
  34 import ErrUtils
  35 import Outputable
  36 import SrcLoc
  37 import Maybes
  38 import FastString
  39 import Coverage
  40 import Util
  41
  42 import Data.List
  43 import Data.IORef
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 %*              The main function: deSugar
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 \begin{code}
  53 -- | Main entry point to the desugarer.
  54 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  55 -- Can modify PCS by faulting in more declarations
  56
  57 deSugar hsc_env
  58         mod_loc
  59         tcg_env@(TcGblEnv { tcg_mod          = mod,
  60                             tcg_src          = hsc_src,
  61                             tcg_type_env     = type_env,
  62                             tcg_imports      = imports,
  63                             tcg_exports      = exports,
  64                             tcg_keep         = keep_var,
  65                             tcg_rdr_env      = rdr_env,
  66                             tcg_fix_env      = fix_env,
  67                             tcg_inst_env     = inst_env,
  68                             tcg_fam_inst_env = fam_inst_env,
  69                             tcg_warns        = warns,
  70                             tcg_anns         = anns,
  71                             tcg_binds        = binds,
  72                             tcg_ev_binds     = ev_binds,
  73                             tcg_fords        = fords,
  74                             tcg_rules        = rules,
  75                             tcg_insts        = insts,
  76                             tcg_fam_insts    = fam_insts,
  77                             tcg_hpc          = other_hpc_info })
  78
  79   = do  { let dflags = hsc_dflags hsc_env
  80         ; showPass dflags "Desugar"
  81
  82         -- Desugar the program
  83         ; let export_set = availsToNameSet exports
  84         ; let auto_scc = mkAutoScc dflags mod export_set
  85         ; let target = hscTarget dflags
  86         ; let hpcInfo = emptyHpcInfo other_hpc_info
  87         ; (msgs, mb_res)
  88               <- case target of
  89                    HscNothing ->
  90                        return (emptyMessages,
  91                                Just ([], [], [], NoStubs, hpcInfo, emptyModBreaks))
  92                    _        -> do
  93                      (binds_cvr,ds_hpc_info, modBreaks)
  94                          <- if (opt_Hpc
  95                                   || target == HscInterpreted)
  96                                && (not (isHsBoot hsc_src))
  97                               then addCoverageTicksToBinds dflags mod mod_loc
  98                                                            (typeEnvTyCons type_env) binds
  99                               else return (binds, hpcInfo, emptyModBreaks)
 100                      initDs hsc_env mod rdr_env type_env $ do
 101                          ds_ev_binds <- dsEvBinds ev_binds
 102                          core_prs <- dsTopLHsBinds auto_scc binds_cvr
 103                          (ds_fords, foreign_prs) <- dsForeigns fords
 104                          let all_prs = foreign_prs ++ core_prs
 105                          mb_rules <- mapM dsRule rules
 106                          return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks)
 107
 108         ; case mb_res of {
 109            Nothing -> return (msgs, Nothing) ;
 110            Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 111
 112         {       -- Add export flags to bindings
 113           keep_alive <- readIORef keep_var
 114         ; let (rules_for_locals, rules_for_imps)
 115                    = partition isLocalRule (catMaybes mb_rules)
 116               final_prs = addExportFlagsAndRules target
 117                               export_set keep_alive rules_for_locals all_prs
 118
 119               final_pgm = combineEvBinds ds_ev_binds final_prs
 120         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 121         -- When compiling PrelFloat, which defines data Float = F# Float#
 122         -- we want F# to be in scope in the foreign marshalling code!
 123         -- You might think it doesn't matter, but the simplifier brings all top-level
 124         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 125
 126         -- Lint result if necessary, and print
 127         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 128                (vcat [ pprCoreBindings final_pgm
 129                      , pprRules rules_for_imps ])
 130
 131         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 132                          -- The simpleOptPgm gets rid of type
 133                          -- bindings plus any stupid dead code
 134
 135         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 136
 137         ; used_names <- mkUsedNames tcg_env
 138         ; deps <- mkDependencies tcg_env
 139
 140         ; let mod_guts = ModGuts {
 141                 mg_module       = mod,
 142                 mg_boot         = isHsBoot hsc_src,
 143                 mg_exports      = exports,
 144                 mg_deps         = deps,
 145                 mg_used_names   = used_names,
 146                 mg_dir_imps     = imp_mods imports,
 147                 mg_rdr_env      = rdr_env,
 148                 mg_fix_env      = fix_env,
 149                 mg_warns        = warns,
 150                 mg_anns         = anns,
 151                 mg_types        = type_env,
 152                 mg_insts        = insts,
 153                 mg_fam_insts    = fam_insts,
 154                 mg_inst_env     = inst_env,
 155                 mg_fam_inst_env = fam_inst_env,
 156                 mg_rules        = ds_rules_for_imps,
 157                 mg_binds        = ds_binds,
 158                 mg_foreign      = ds_fords,
 159                 mg_hpc_info     = ds_hpc_info,
 160                 mg_modBreaks    = modBreaks,
 161                 mg_vect_info    = noVectInfo
 162               }
 163         ; return (msgs, Just mod_guts)
 164         }}}
 165
 166
 167 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 168 -- Top-level bindings can include coercion bindings, but not via superclasses
 169 -- See Note [Top-level evidence]
 170 combineEvBinds [] val_prs
 171   = [Rec val_prs]
 172 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 173   | isId b    = combineEvBinds bs ((b,r):val_prs)
 174   | otherwise = NonRec b r : combineEvBinds bs val_prs
 175 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 176   = combineEvBinds bs (prs ++ val_prs)
 177 combineEvBinds (CaseEvBind x _ _ : _) _
 178   = pprPanic "topEvBindPairs" (ppr x)
 179 \end{code}
 180
 181 Note [Top-level evidence]
 182 ~~~~~~~~~~~~~~~~~~~~~~~~~
 183 Top-level evidence bindings may be mutually recursive with the top-level value
 184 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 185 because the occurrence analyser doesn't teke account of type/coercion variables
 186 when computing dependencies.
 187
 188 So we pull out the type/coercion variables (which are in dependency order),
 189 and Rec the rest.
 190
 191
 192 \begin{code}
 193 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 194 mkAutoScc dflags mod exports
 195   | not opt_SccProfilingOn      -- No profiling
 196   = NoSccs
 197     -- Add auto-scc on all top-level things
 198   | dopt Opt_AutoSccsOnAllToplevs dflags
 199   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 200     -- See #1641.  This is pretty yucky, but I can't see a better way
 201     -- to identify compiler-generated Ids, and at least this should
 202     -- catch them all.
 203     -- Only on exported things
 204   | dopt Opt_AutoSccsOnExportedToplevs dflags
 205   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 206   | otherwise
 207   = NoSccs
 208
 209 deSugarExpr :: HscEnv
 210             -> Module -> GlobalRdrEnv -> TypeEnv
 211             -> LHsExpr Id
 212             -> IO (Messages, Maybe CoreExpr)
 213 -- Prints its own errors; returns Nothing if error occurred
 214
 215 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 216     let dflags = hsc_dflags hsc_env
 217     showPass dflags "Desugar"
 218
 219     -- Do desugaring
 220     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 221                                    dsLExpr tc_expr
 222
 223     case mb_core_expr of
 224       Nothing   -> return (msgs, Nothing)
 225       Just expr -> do
 226
 227         -- Dump output
 228         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 229
 230         return (msgs, Just expr)
 231 \end{code}
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 %*              Add rules and export flags to binders
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 addExportFlagsAndRules
 241     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 242     -> [(Id, t)] -> [(Id, t)]
 243 addExportFlagsAndRules target exports keep_alive rules prs
 244   = mapFst add_one prs
 245   where
 246     add_one bndr = add_rules name (add_export name bndr)
 247        where
 248          name = idName bndr
 249
 250     ---------- Rules --------
 251         -- See Note [Attach rules to local ids]
 252         -- NB: the binder might have some existing rules,
 253         -- arising from specialisation pragmas
 254     add_rules name bndr
 255         | Just rules <- lookupNameEnv rule_base name
 256         = bndr `addIdSpecialisations` rules
 257         | otherwise
 258         = bndr
 259     rule_base = extendRuleBaseList emptyRuleBase rules
 260
 261     ---------- Export flag --------
 262     -- See Note [Adding export flags]
 263     add_export name bndr
 264         | dont_discard name = setIdExported bndr
 265         | otherwise         = bndr
 266
 267     dont_discard :: Name -> Bool
 268     dont_discard name = is_exported name
 269                      || name `elemNameSet` keep_alive
 270
 271         -- In interactive mode, we don't want to discard any top-level
 272         -- entities at all (eg. do not inline them away during
 273         -- simplification), and retain them all in the TypeEnv so they are
 274         -- available from the command line.
 275         --
 276         -- isExternalName separates the user-defined top-level names from those
 277         -- introduced by the type checker.
 278     is_exported :: Name -> Bool
 279     is_exported | target == HscInterpreted = isExternalName
 280                 | otherwise                = (`elemNameSet` exports)
 281 \end{code}
 282
 283
 284 Note [Adding export flags]
 285 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 286 Set the no-discard flag if either
 287         a) the Id is exported
 288         b) it's mentioned in the RHS of an orphan rule
 289         c) it's in the keep-alive set
 290
 291 It means that the binding won't be discarded EVEN if the binding
 292 ends up being trivial (v = w) -- the simplifier would usually just
 293 substitute w for v throughout, but we don't apply the substitution to
 294 the rules (maybe we should?), so this substitution would make the rule
 295 bogus.
 296
 297 You might wonder why exported Ids aren't already marked as such;
 298 it's just because the type checker is rather busy already and
 299 I didn't want to pass in yet another mapping.
 300
 301 Note [Attach rules to local ids]
 302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 303 Find the rules for locally-defined Ids; then we can attach them
 304 to the binders in the top-level bindings
 305
 306 Reason
 307   - It makes the rules easier to look up
 308   - It means that transformation rules and specialisations for
 309     locally defined Ids are handled uniformly
 310   - It keeps alive things that are referred to only from a rule
 311     (the occurrence analyser knows about rules attached to Ids)
 312   - It makes sure that, when we apply a rule, the free vars
 313     of the RHS are more likely to be in scope
 314   - The imported rules are carried in the in-scope set
 315     which is extended on each iteration by the new wave of
 316     local binders; any rules which aren't on the binding will
 317     thereby get dropped
 318
 319
 320 %************************************************************************
 321 %*                                                                      *
 322 %*              Desugaring transformation rules
 323 %*                                                                      *
 324 %************************************************************************
 325
 326 \begin{code}
 327 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 328 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 329   = putSrcSpanDs loc $
 330     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 331
 332         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 333                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 334
 335         ; rhs' <- dsLExpr rhs
 336
 337         -- Substitute the dict bindings eagerly,
 338         -- and take the body apart into a (f args) form
 339         ; case decomposeRuleLhs lhs' of {
 340                 Nothing -> do { warnDs msg; return Nothing } ;
 341                 Just (fn_id, args) -> do
 342
 343         { let local_rule = isLocalId fn_id
 344                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 345                 -- we don't want to attach rules to the bindings of implicit Ids,
 346                 -- because they don't show up in the bindings until just before code gen
 347               fn_name   = idName fn_id
 348               final_rhs = simpleOptExpr rhs'    -- De-crap it
 349               rule      = mkRule local_rule name act fn_name bndrs' args final_rhs
 350         ; return (Just rule)
 351         } } }
 352   where
 353     msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
 354              2 (ppr lhs)
 355 \end{code}
 356
 357 Note [Desugaring RULE left hand sides]
 358 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 359 For the LHS of a RULE we do *not* want to desugar
 360     [x]   to    build (\cn. x `c` n)
 361 We want to leave explicit lists simply as chains
 362 of cons's. We can achieve that slightly indirectly by
 363 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 364
 365 That keeps the desugaring of list comprehensions simple too.
 366
 367