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                                     , undefined
  97                                     , undefined
  98                                     , undefined
  99                                     , undefined
 100                                     , undefined
 101                                     , undefined
 102                                     , undefined
 103                                     , undefined
 104                                     , undefined
 105                                     , undefined
 106                                     , undefined
 107                                     , undefined
 108                                     , undefined
 109                                     , undefined
 110                                     , undefined
 111                                     , undefined
 112                                     , undefined
 113                                     , undefined
 114                                     , undefined
 115                                     , undefined
 116                                ))
 117                    _        -> do
 118                      (binds_cvr,ds_hpc_info, modBreaks)
 119                          <- if (opt_Hpc
 120                                   || target == HscInterpreted)
 121                                && (not (isHsBoot hsc_src))
 122                               then addCoverageTicksToBinds dflags mod mod_loc
 123                                                            (typeEnvTyCons type_env) binds
 124                               else return (binds, hpcInfo, emptyModBreaks)
 125                      initDs hsc_env mod rdr_env type_env $ do
 126                        do { ds_ev_binds <- dsEvBinds ev_binds
 127                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 128                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 129                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 130                           ; ds_rules <- mapMaybeM dsRule rules
 131                           ; ds_vects <- mapM dsVect vects
 132                           ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
 133                           ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
 134                           ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
 135                           ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
 136                           ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
 137                           ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
 138                           ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
 139                           ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
 140                           ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
 141                           ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
 142                           ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
 143                           ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
 144                           ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
 145                           ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
 146                           ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
 147                           ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
 148                           ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
 149                           ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
 150                           ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
 151                           ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
 152                           ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
 153                           ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
 154                           ; let hpc_init
 155                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
 156                                   | otherwise = empty
 157                           ; return ( ds_ev_binds
 158                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 159                                    , spec_rules ++ ds_rules, ds_vects
 160                                    , ds_fords `appendStubC` hpc_init
 161                                    , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc, hetmet_flatten, hetmet_flattened_id
 162                                    , hetmet_PGArrow
 163                                    , hetmet_pga_id
 164                                    , hetmet_pga_comp
 165                                    , hetmet_pga_first
 166                                    , hetmet_pga_second
 167                                    , hetmet_pga_cancell
 168                                    , hetmet_pga_cancelr
 169                                    , hetmet_pga_uncancell
 170                                    , hetmet_pga_uncancelr
 171                                    , hetmet_pga_assoc
 172                                    , hetmet_pga_unassoc
 173                                    , hetmet_pga_copy
 174                                    , hetmet_pga_drop
 175                                    , hetmet_pga_swap
 176                                    , hetmet_pga_applyl
 177                                    , hetmet_pga_applyr
 178                                    , hetmet_pga_curryl
 179                                    , hetmet_pga_curryr
 180                                    ) }
 181
 182         ; case mb_res of {
 183            Nothing -> return (msgs, Nothing) ;
 184            Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
 185                                    , hetmet_brak, hetmet_esc, hetmet_flatten, hetmet_flattened_id
 186                                    , hetmet_PGArrow
 187                                    , hetmet_pga_id
 188                                    , hetmet_pga_comp
 189                                    , hetmet_pga_first
 190                                    , hetmet_pga_second
 191                                    , hetmet_pga_cancell
 192                                    , hetmet_pga_cancelr
 193                                    , hetmet_pga_uncancell
 194                                    , hetmet_pga_uncancelr
 195                                    , hetmet_pga_assoc
 196                                    , hetmet_pga_unassoc
 197                                    , hetmet_pga_copy
 198                                    , hetmet_pga_drop
 199                                    , hetmet_pga_swap
 200                                    , hetmet_pga_applyl
 201                                    , hetmet_pga_applyr
 202                                    , hetmet_pga_curryl
 203                                    , hetmet_pga_curryr) -> do
 204
 205         {       -- Add export flags to bindings
 206           keep_alive <- readIORef keep_var
 207         ; let (rules_for_locals, rules_for_imps)
 208                    = partition isLocalRule all_rules
 209               final_prs = addExportFlagsAndRules target
 210                               export_set keep_alive rules_for_locals (fromOL all_prs)
 211
 212               final_pgm = combineEvBinds ds_ev_binds final_prs
 213         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 214         -- When compiling PrelFloat, which defines data Float = F# Float#
 215         -- we want F# to be in scope in the foreign marshalling code!
 216         -- You might think it doesn't matter, but the simplifier brings all top-level
 217         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 218
 219         -- Lint result if necessary, and print
 220         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 221                (vcat [ pprCoreBindings final_pgm
 222                      , pprRules rules_for_imps ])
 223
 224         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 225                          -- The simpleOptPgm gets rid of type
 226                          -- bindings plus any stupid dead code
 227
 228         ; ds_binds' <- if dopt Opt_F_coqpass dflags
 229                        then do { us <- mkSplitUniqSupply '~'
 230                                ; return (coqPassCoreToCore
 231                                              hetmet_brak
 232                                              hetmet_esc
 233                                              hetmet_flatten
 234                                              hetmet_flattened_id
 235                                              us
 236                                              ds_binds
 237                                              hetmet_PGArrow
 238                                              hetmet_pga_id
 239                                              hetmet_pga_comp
 240                                              hetmet_pga_first
 241                                              hetmet_pga_second
 242                                              hetmet_pga_cancell
 243                                              hetmet_pga_cancelr
 244                                              hetmet_pga_uncancell
 245                                              hetmet_pga_uncancelr
 246                                              hetmet_pga_assoc
 247                                              hetmet_pga_unassoc
 248                                              hetmet_pga_copy
 249                                              hetmet_pga_drop
 250                                              hetmet_pga_swap
 251                                              hetmet_pga_applyl
 252                                              hetmet_pga_applyr
 253                                              hetmet_pga_curryl
 254                                              hetmet_pga_curryr)
 255                                }
 256                        else return ds_binds
 257
 258         ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
 259
 260         ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
 261
 262         ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
 263
 264         ; let used_names = mkUsedNames tcg_env
 265         ; deps <- mkDependencies tcg_env
 266
 267         ; let mod_guts = ModGuts {
 268                 mg_module       = mod,
 269                 mg_boot         = isHsBoot hsc_src,
 270                 mg_exports      = exports,
 271                 mg_deps         = deps,
 272                 mg_used_names   = used_names,
 273                 mg_dir_imps     = imp_mods imports,
 274                 mg_rdr_env      = rdr_env,
 275                 mg_fix_env      = fix_env,
 276                 mg_warns        = warns,
 277                 mg_anns         = anns,
 278                 mg_types        = type_env,
 279                 mg_insts        = insts,
 280                 mg_fam_insts    = fam_insts,
 281                 mg_inst_env     = inst_env,
 282                 mg_fam_inst_env = fam_inst_env,
 283                 mg_rules        = ds_rules_for_imps,
 284                 mg_binds        = ds_binds',
 285                 mg_foreign      = ds_fords,
 286                 mg_hpc_info     = ds_hpc_info,
 287                 mg_modBreaks    = modBreaks,
 288                 mg_vect_decls   = ds_vects,
 289                 mg_vect_info    = noVectInfo
 290               }
 291         ; return (msgs, Just mod_guts)
 292         }}}
 293
 294 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 295 dsImpSpecs imp_specs
 296  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 297       ; let (spec_binds, spec_rules) = unzip spec_prs
 298       ; return (concatOL spec_binds, spec_rules) }
 299
 300 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 301 -- Top-level bindings can include coercion bindings, but not via superclasses
 302 -- See Note [Top-level evidence]
 303 combineEvBinds [] val_prs
 304   = [Rec val_prs]
 305 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 306   | isId b    = combineEvBinds bs ((b,r):val_prs)
 307   | otherwise = NonRec b r : combineEvBinds bs val_prs
 308 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 309   = combineEvBinds bs (prs ++ val_prs)
 310 combineEvBinds (CaseEvBind x _ _ : _) _
 311   = pprPanic "topEvBindPairs" (ppr x)
 312 \end{code}
 313
 314 Note [Top-level evidence]
 315 ~~~~~~~~~~~~~~~~~~~~~~~~~
 316 Top-level evidence bindings may be mutually recursive with the top-level value
 317 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 318 because the occurrence analyser doesn't teke account of type/coercion variables
 319 when computing dependencies.
 320
 321 So we pull out the type/coercion variables (which are in dependency order),
 322 and Rec the rest.
 323
 324
 325 \begin{code}
 326 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 327 mkAutoScc dflags mod exports
 328   | not opt_SccProfilingOn      -- No profiling
 329   = NoSccs
 330     -- Add auto-scc on all top-level things
 331   | dopt Opt_AutoSccsOnAllToplevs dflags
 332   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 333     -- See #1641.  This is pretty yucky, but I can't see a better way
 334     -- to identify compiler-generated Ids, and at least this should
 335     -- catch them all.
 336     -- Only on exported things
 337   | dopt Opt_AutoSccsOnExportedToplevs dflags
 338   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 339   | otherwise
 340   = NoSccs
 341
 342 deSugarExpr :: HscEnv
 343             -> Module -> GlobalRdrEnv -> TypeEnv
 344             -> LHsExpr Id
 345             -> IO (Messages, Maybe CoreExpr)
 346 -- Prints its own errors; returns Nothing if error occurred
 347
 348 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 349     let dflags = hsc_dflags hsc_env
 350     showPass dflags "Desugar"
 351
 352     -- Do desugaring
 353     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 354                                    dsLExpr tc_expr
 355
 356     case mb_core_expr of
 357       Nothing   -> return (msgs, Nothing)
 358       Just expr -> do
 359
 360         -- Dump output
 361         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 362
 363         return (msgs, Just expr)
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 %*              Add rules and export flags to binders
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 addExportFlagsAndRules
 374     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 375     -> [(Id, t)] -> [(Id, t)]
 376 addExportFlagsAndRules target exports keep_alive rules prs
 377   = mapFst add_one prs
 378   where
 379     add_one bndr = add_rules name (add_export name bndr)
 380        where
 381          name = idName bndr
 382
 383     ---------- Rules --------
 384         -- See Note [Attach rules to local ids]
 385         -- NB: the binder might have some existing rules,
 386         -- arising from specialisation pragmas
 387     add_rules name bndr
 388         | Just rules <- lookupNameEnv rule_base name
 389         = bndr `addIdSpecialisations` rules
 390         | otherwise
 391         = bndr
 392     rule_base = extendRuleBaseList emptyRuleBase rules
 393
 394     ---------- Export flag --------
 395     -- See Note [Adding export flags]
 396     add_export name bndr
 397         | dont_discard name = setIdExported bndr
 398         | otherwise         = bndr
 399
 400     dont_discard :: Name -> Bool
 401     dont_discard name = is_exported name
 402                      || name `elemNameSet` keep_alive
 403
 404         -- In interactive mode, we don't want to discard any top-level
 405         -- entities at all (eg. do not inline them away during
 406         -- simplification), and retain them all in the TypeEnv so they are
 407         -- available from the command line.
 408         --
 409         -- isExternalName separates the user-defined top-level names from those
 410         -- introduced by the type checker.
 411     is_exported :: Name -> Bool
 412     is_exported | target == HscInterpreted = isExternalName
 413                 | otherwise                = (`elemNameSet` exports)
 414 \end{code}
 415
 416
 417 Note [Adding export flags]
 418 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 419 Set the no-discard flag if either
 420         a) the Id is exported
 421         b) it's mentioned in the RHS of an orphan rule
 422         c) it's in the keep-alive set
 423
 424 It means that the binding won't be discarded EVEN if the binding
 425 ends up being trivial (v = w) -- the simplifier would usually just
 426 substitute w for v throughout, but we don't apply the substitution to
 427 the rules (maybe we should?), so this substitution would make the rule
 428 bogus.
 429
 430 You might wonder why exported Ids aren't already marked as such;
 431 it's just because the type checker is rather busy already and
 432 I didn't want to pass in yet another mapping.
 433
 434 Note [Attach rules to local ids]
 435 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 436 Find the rules for locally-defined Ids; then we can attach them
 437 to the binders in the top-level bindings
 438
 439 Reason
 440   - It makes the rules easier to look up
 441   - It means that transformation rules and specialisations for
 442     locally defined Ids are handled uniformly
 443   - It keeps alive things that are referred to only from a rule
 444     (the occurrence analyser knows about rules attached to Ids)
 445   - It makes sure that, when we apply a rule, the free vars
 446     of the RHS are more likely to be in scope
 447   - The imported rules are carried in the in-scope set
 448     which is extended on each iteration by the new wave of
 449     local binders; any rules which aren't on the binding will
 450     thereby get dropped
 451
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 %*              Desugaring transformation rules
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 461 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 462   = putSrcSpanDs loc $
 463     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 464
 465         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 466                   unsetOptM Opt_WarnIdentities $
 467                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 468
 469         ; rhs' <- dsLExpr rhs
 470
 471         -- Substitute the dict bindings eagerly,
 472         -- and take the body apart into a (f args) form
 473         ; case decomposeRuleLhs bndrs' lhs' of {
 474                 Left msg -> do { warnDs msg; return Nothing } ;
 475                 Right (final_bndrs, fn_id, args) -> do
 476
 477         { let is_local = isLocalId fn_id
 478                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 479                 -- we don't want to attach rules to the bindings of implicit Ids,
 480                 -- because they don't show up in the bindings until just before code gen
 481               fn_name   = idName fn_id
 482               final_rhs = simpleOptExpr rhs'    -- De-crap it
 483               rule      = mkRule False {- Not auto -} is_local
 484                                  name act fn_name final_bndrs args final_rhs
 485         ; return (Just rule)
 486         } } }
 487 \end{code}
 488
 489 Note [Desugaring RULE left hand sides]
 490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 491 For the LHS of a RULE we do *not* want to desugar
 492     [x]   to    build (\cn. x `c` n)
 493 We want to leave explicit lists simply as chains
 494 of cons's. We can achieve that slightly indirectly by
 495 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 496
 497 That keeps the desugaring of list comprehensions simple too.
 498
 499 Nor do we want to warn of conversion identities on the LHS;
 500 the rule is precisly to optimise them:
 501   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 %*              Desugaring vectorisation declarations
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 dsVect :: LVectDecl Id -> DsM CoreVect
 512 dsVect (L loc (HsVect v rhs))
 513   = putSrcSpanDs loc $
 514     do { rhs' <- fmapMaybeM dsLExpr rhs
 515        ; return $ Vect (unLoc v) rhs'
 516            }
 517 -- dsVect (L loc (HsVect v Nothing))
 518 --   = return $ Vect v Nothing
 519 -- dsVect (L loc (HsVect v (Just rhs)))
 520 --   = putSrcSpanDs loc $
 521 --     do { rhs' <- dsLExpr rhs
 522 --        ; return $ Vect v (Just rhs')
 523 --       }
 524 \end{code}