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