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