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