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 IfaceEnv
  18 import Id
  19 import Pair
  20 import Name
  21 import FastString
  22 import CoreSyn
  23 import CoreSubst
  24 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
  25 import PprCore
  26 import DsMonad
  27 import DsExpr
  28 import DsBinds
  29 import DsForeign
  30 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  31                                 -- depends on DsExpr.hi-boot.
  32 import Module
  33 import RdrName
  34 import NameSet
  35 import NameEnv
  36 import Rules
  37 import CoreMonad        ( endPass, CoreToDo(..) )
  38 import ErrUtils
  39 import Outputable
  40 import SrcLoc
  41 import Coverage
  42 import Util
  43 import MonadUtils
  44 import OrdList
  45 import Data.List
  46 import Data.IORef
  47 import PrelNames
  48 import UniqSupply
  49 import UniqFM
  50 import CoreFVs
  51 import Type
  52 import Coercion
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 %*              The main function: deSugar
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62
  63 -- | Main entry point to the desugarer.
  64 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  65 -- Can modify PCS by faulting in more declarations
  66
  67 deSugar hsc_env
  68         mod_loc
  69         tcg_env@(TcGblEnv { tcg_mod          = mod,
  70                             tcg_src          = hsc_src,
  71                             tcg_type_env     = type_env,
  72                             tcg_imports      = imports,
  73                             tcg_exports      = exports,
  74                             tcg_keep         = keep_var,
  75                             tcg_rdr_env      = rdr_env,
  76                             tcg_fix_env      = fix_env,
  77                             tcg_inst_env     = inst_env,
  78                             tcg_fam_inst_env = fam_inst_env,
  79                             tcg_warns        = warns,
  80                             tcg_anns         = anns,
  81                             tcg_binds        = binds,
  82                             tcg_imp_specs    = imp_specs,
  83                             tcg_ev_binds     = ev_binds,
  84                             tcg_fords        = fords,
  85                             tcg_rules        = rules,
  86                             tcg_vects        = vects,
  87                             tcg_insts        = insts,
  88                             tcg_fam_insts    = fam_insts,
  89                             tcg_hpc          = other_hpc_info })
  90
  91   = do  { let dflags = hsc_dflags hsc_env
  92         ; showPass dflags "Desugar"
  93
  94         -- Desugar the program
  95         ; let export_set = availsToNameSet exports
  96         ; let auto_scc = mkAutoScc dflags mod export_set
  97         ; let target = hscTarget dflags
  98         ; let hpcInfo = emptyHpcInfo other_hpc_info
  99         ; (msgs, mb_res)
 100               <- case target of
 101                    HscNothing ->
 102                        return (emptyMessages,
 103                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined))
 104                    _        -> do
 105                      (binds_cvr,ds_hpc_info, modBreaks)
 106                          <- if (opt_Hpc
 107                                   || target == HscInterpreted)
 108                                && (not (isHsBoot hsc_src))
 109                               then addCoverageTicksToBinds dflags mod mod_loc
 110                                                            (typeEnvTyCons type_env) binds
 111                               else return (binds, hpcInfo, emptyModBreaks)
 112
 113                      initDs hsc_env mod rdr_env type_env $ do
 114                        do { ds_ev_binds <- dsEvBinds ev_binds
 115                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 116                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 117                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 118                           ; ds_rules <- mapMaybeM dsRule rules
 119                           ; ds_vects <- mapM dsVect vects
 120                           ; junk <- if dopt Opt_F_coqpass dflags
 121                                     then do { hetmet_brak_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_brak"))
 122                                             ; hetmet_brak <- dsLookupGlobalId hetmet_brak_name
 123                                             ; hetmet_esc_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_esc"))
 124                                             ; hetmet_esc  <- dsLookupGlobalId hetmet_esc_name
 125                                             ; hetmet_flatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "hetmet_flatten"))
 126                                             ; hetmet_flatten <- dsLookupGlobalId hetmet_flatten_name
 127                                             ; hetmet_unflatten_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_unflatten"))
 128                                             ; hetmet_unflatten <- dsLookupGlobalId hetmet_unflatten_name
 129                                             ; hetmet_flattened_id_name <- lookupOrig gHC_HETMET_CODETYPES (mkOccNameFS varName (fsLit "pga_flattened_id"))
 130                                             ; hetmet_flattened_id <- dsLookupGlobalId hetmet_flattened_id_name
 131                                             ; hetmet_PGArrow_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS tcName (fsLit "PGArrow"))
 132                                             ; hetmet_PGArrow <- dsLookupTyCon hetmet_PGArrow_name
 133                                             ; hetmet_PGArrow_unit_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowUnit"))
 134                                             ; hetmet_PGArrow_unit <- dsLookupTyCon hetmet_PGArrow_unit_name
 135                                             ; hetmet_PGArrow_tensor_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowTensor"))
 136                                             ; hetmet_PGArrow_tensor <- dsLookupTyCon hetmet_PGArrow_tensor_name
 137                                             ; hetmet_PGArrow_exponent_name <- lookupOrig gHC_HETMET_GARROW (mkOccNameFS tcName (fsLit "GArrowExponent"))
 138                                             ; hetmet_PGArrow_exponent <- dsLookupTyCon hetmet_PGArrow_exponent_name
 139                                             ; hetmet_pga_id_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_id"))
 140                                             ; hetmet_pga_id <- dsLookupGlobalId hetmet_pga_id_name
 141                                             ; hetmet_pga_comp_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_comp"))
 142                                             ; hetmet_pga_comp <- dsLookupGlobalId hetmet_pga_comp_name
 143                                             ; hetmet_pga_first_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_first"))
 144                                             ; hetmet_pga_first <- dsLookupGlobalId hetmet_pga_first_name
 145                                             ; hetmet_pga_second_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_second"))
 146                                             ; hetmet_pga_second <- dsLookupGlobalId hetmet_pga_second_name
 147                                             ; hetmet_pga_cancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancell"))
 148                                             ; hetmet_pga_cancell <- dsLookupGlobalId hetmet_pga_cancell_name
 149                                             ; hetmet_pga_cancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_cancelr"))
 150                                             ; hetmet_pga_cancelr <- dsLookupGlobalId hetmet_pga_cancelr_name
 151                                             ; hetmet_pga_uncancell_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancell"))
 152                                             ; hetmet_pga_uncancell <- dsLookupGlobalId hetmet_pga_uncancell_name
 153                                             ; hetmet_pga_uncancelr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_uncancelr"))
 154                                             ; hetmet_pga_uncancelr <- dsLookupGlobalId hetmet_pga_uncancelr_name
 155                                             ; hetmet_pga_assoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_assoc"))
 156                                             ; hetmet_pga_assoc <- dsLookupGlobalId hetmet_pga_assoc_name
 157                                             ; hetmet_pga_unassoc_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_unassoc"))
 158                                             ; hetmet_pga_unassoc <- dsLookupGlobalId hetmet_pga_unassoc_name
 159                                             ; hetmet_pga_copy_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_copy"))
 160                                             ; hetmet_pga_copy <- dsLookupGlobalId hetmet_pga_copy_name
 161                                             ; hetmet_pga_drop_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_drop"))
 162                                             ; hetmet_pga_drop <- dsLookupGlobalId hetmet_pga_drop_name
 163                                             ; hetmet_pga_swap_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_swap"))
 164                                             ; hetmet_pga_swap <- dsLookupGlobalId hetmet_pga_swap_name
 165                                             ; hetmet_pga_applyl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyl"))
 166                                             ; hetmet_pga_applyl <- dsLookupGlobalId hetmet_pga_applyl_name
 167                                             ; hetmet_pga_applyr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_applyr"))
 168                                             ; hetmet_pga_applyr <- dsLookupGlobalId hetmet_pga_applyr_name
 169                                             ; hetmet_pga_curryl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryl"))
 170                                             ; hetmet_pga_curryl <- dsLookupGlobalId hetmet_pga_curryl_name
 171                                             ; hetmet_pga_curryr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_curryr"))
 172                                             ; hetmet_pga_curryr <- dsLookupGlobalId hetmet_pga_curryr_name
 173                                             ; hetmet_pga_loopl_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopl"))
 174                                             ; hetmet_pga_loopl <- dsLookupGlobalId hetmet_pga_loopl_name
 175                                             ; hetmet_pga_loopr_name <- lookupOrig gHC_HETMET_PRIVATE (mkOccNameFS varName (fsLit "pga_loopr"))
 176                                             ; hetmet_pga_loopr <- dsLookupGlobalId hetmet_pga_loopr_name
 177                                             ; return ( hetmet_brak
 178                                                      , hetmet_esc
 179                                                      , hetmet_flatten
 180                                                      , hetmet_unflatten
 181                                                      , hetmet_flattened_id
 182                                                      , hetmet_PGArrow
 183                                                      , hetmet_PGArrow_unit
 184                                                      , hetmet_PGArrow_tensor
 185                                                      , hetmet_PGArrow_exponent
 186                                                      , hetmet_pga_id
 187                                                      , hetmet_pga_comp
 188                                                      , hetmet_pga_first
 189                                                      , hetmet_pga_second
 190                                                      , hetmet_pga_cancell
 191                                                      , hetmet_pga_cancelr
 192                                                      , hetmet_pga_uncancell
 193                                                      , hetmet_pga_uncancelr
 194                                                      , hetmet_pga_assoc
 195                                                      , hetmet_pga_unassoc
 196                                                      , hetmet_pga_copy
 197                                                      , hetmet_pga_drop
 198                                                      , hetmet_pga_swap
 199                                                      , hetmet_pga_applyl
 200                                                      , hetmet_pga_applyr
 201                                                      , hetmet_pga_curryl
 202                                                      , hetmet_pga_curryr
 203                                                      , hetmet_pga_loopl
 204                                                      , hetmet_pga_loopr )
 205                                             }
 206                                     else return undefined
 207                           ; let hpc_init
 208                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
 209                                   | otherwise = empty
 210                           ; return ( ds_ev_binds
 211                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 212                                    , spec_rules ++ ds_rules, ds_vects
 213                                    , ds_fords `appendStubC` hpc_init
 214                                    , ds_hpc_info, modBreaks, junk)
 215                                    }
 216
 217         ; case mb_res of {
 218            Nothing -> return (msgs, Nothing) ;
 219            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks, junk) -> do
 220
 221         {       -- Add export flags to bindings
 222           keep_alive <- readIORef keep_var
 223         ; let (rules_for_locals, rules_for_imps)
 224                    = partition isLocalRule all_rules
 225               final_prs = addExportFlagsAndRules target
 226                               export_set keep_alive rules_for_locals (fromOL all_prs)
 227
 228               final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
 229                           in if dopt Opt_F_simpleopt_before_flatten dflags
 230                              then comb
 231                              else simplifyBinds comb
 232         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 233         -- When compiling PrelFloat, which defines data Float = F# Float#
 234         -- we want F# to be in scope in the foreign marshalling code!
 235         -- You might think it doesn't matter, but the simplifier brings all top-level
 236         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 237
 238         ; (final_pgm1, rules_for_imps1, ds_vects1) <- if dopt Opt_F_simpleopt_before_flatten dflags
 239                                                       then simpleOptPgm dflags final_pgm rules_for_imps vects0
 240                                                       else return (final_pgm, rules_for_imps, vects0)
 241
 242         ; ds_binds1 <- if dopt Opt_F_coqpass dflags
 243                        then do { us <- mkSplitUniqSupply '~'
 244                                ; let do_flatten   = dopt Opt_F_flatten dflags
 245                                ; let do_skolemize = dopt Opt_F_skolemize dflags
 246                                ; (case junk of {
 247                                      ( hetmet_brak ,
 248                                        hetmet_esc ,
 249                                        hetmet_flatten ,
 250                                        hetmet_unflatten ,
 251                                        hetmet_flattened_id ,
 252                                        hetmet_PGArrow ,
 253                                        hetmet_PGArrow_unit ,
 254                                        hetmet_PGArrow_tensor ,
 255                                        hetmet_PGArrow_exponent ,
 256                                        hetmet_pga_id ,
 257                                        hetmet_pga_comp ,
 258                                        hetmet_pga_first ,
 259                                        hetmet_pga_second ,
 260                                        hetmet_pga_cancell ,
 261                                        hetmet_pga_cancelr ,
 262                                        hetmet_pga_uncancell ,
 263                                        hetmet_pga_uncancelr ,
 264                                        hetmet_pga_assoc ,
 265                                        hetmet_pga_unassoc ,
 266                                        hetmet_pga_copy ,
 267                                        hetmet_pga_drop ,
 268                                        hetmet_pga_swap ,
 269                                        hetmet_pga_applyl ,
 270                                        hetmet_pga_applyr ,
 271                                        hetmet_pga_curryl ,
 272                                        hetmet_pga_curryr ,
 273                                        hetmet_pga_loopl ,
 274                                        hetmet_pga_loopr ) ->
 275                                            return (coqPassCoreToCore
 276                                                      do_flatten
 277                                                      do_skolemize
 278                                                      hetmet_brak
 279                                                      hetmet_esc
 280                                                      hetmet_flatten
 281                                                      hetmet_unflatten
 282                                                      hetmet_flattened_id
 283                                                      us
 284                                                      final_pgm1
 285                                                      hetmet_PGArrow
 286                                                      hetmet_PGArrow_unit
 287                                                      hetmet_PGArrow_tensor
 288                                                      hetmet_PGArrow_exponent
 289                                                      hetmet_pga_id
 290                                                      hetmet_pga_comp
 291                                                      hetmet_pga_first
 292                                                      hetmet_pga_second
 293                                                      hetmet_pga_cancell
 294                                                      hetmet_pga_cancelr
 295                                                      hetmet_pga_uncancell
 296                                                      hetmet_pga_uncancelr
 297                                                      hetmet_pga_assoc
 298                                                      hetmet_pga_unassoc
 299                                                      hetmet_pga_copy
 300                                                      hetmet_pga_drop
 301                                                      hetmet_pga_swap
 302                                                      hetmet_pga_applyl
 303                                                      hetmet_pga_applyr
 304                                                      hetmet_pga_curryl
 305                                                      hetmet_pga_curryr
 306                                                      hetmet_pga_loopl
 307                                                      hetmet_pga_loopr
 308                                         )
 309                                             }
 310                                  )
 311                                }
 312                        else return final_pgm
 313
 314         ; (ds_binds2, ds_rules_for_imps2, ds_vects2) <- if dopt Opt_F_simpleopt_before_flatten dflags
 315                                                         then return (ds_binds1, rules_for_imps1, ds_vects1)
 316                                                         else simpleOptPgm dflags ds_binds1 rules_for_imps1 ds_vects1
 317                          -- The simpleOptPgm gets rid of type
 318                          -- bindings plus any stupid dead code
 319
 320         ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds1
 321
 322         ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds1)
 323
 324         ; (ds_binds3, ds_rules_for_imps3, ds_vects3)
 325             <- simpleOptPgm dflags ds_binds2 ds_rules_for_imps2 ds_vects2
 326                          -- The simpleOptPgm gets rid of type
 327                          -- bindings plus any stupid dead code
 328
 329         ; endPass dflags CoreDesugar ds_binds3 ds_rules_for_imps3
 330
 331         ; let used_names = mkUsedNames tcg_env
 332         ; deps <- mkDependencies tcg_env
 333
 334         ; let mod_guts = ModGuts {
 335                 mg_module       = mod,
 336                 mg_boot         = isHsBoot hsc_src,
 337                 mg_exports      = exports,
 338                 mg_deps         = deps,
 339                 mg_used_names   = used_names,
 340                 mg_dir_imps     = imp_mods imports,
 341                 mg_rdr_env      = rdr_env,
 342                 mg_fix_env      = fix_env,
 343                 mg_warns        = warns,
 344                 mg_anns         = anns,
 345                 mg_types        = type_env,
 346                 mg_insts        = insts,
 347                 mg_fam_insts    = fam_insts,
 348                 mg_inst_env     = inst_env,
 349                 mg_fam_inst_env = fam_inst_env,
 350                 mg_rules        = ds_rules_for_imps3,
 351                 mg_binds        = ds_binds3,
 352                 mg_foreign      = ds_fords,
 353                 mg_hpc_info     = ds_hpc_info,
 354                 mg_modBreaks    = modBreaks,
 355                 mg_vect_decls   = ds_vects2,
 356                 mg_vect_info    = noVectInfo
 357               }
 358         ; return (msgs, Just mod_guts)
 359         }}}
 360
 361 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 362 dsImpSpecs imp_specs
 363  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 364       ; let (spec_binds, spec_rules) = unzip spec_prs
 365       ; return (concatOL spec_binds, spec_rules) }
 366
 367 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 368 -- Top-level bindings can include coercion bindings, but not via superclasses
 369 -- See Note [Top-level evidence]
 370 combineEvBinds [] val_prs
 371   = [Rec val_prs]
 372 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 373   | isId b    = combineEvBinds bs ((b,r):val_prs)
 374   | otherwise = NonRec b r : combineEvBinds bs val_prs
 375 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 376   = combineEvBinds bs (prs ++ val_prs)
 377 combineEvBinds (CaseEvBind x _ _ : _) _
 378   = pprPanic "topEvBindPairs" (ppr x)
 379 \end{code}
 380
 381 Note [Top-level evidence]
 382 ~~~~~~~~~~~~~~~~~~~~~~~~~
 383 Top-level evidence bindings may be mutually recursive with the top-level value
 384 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 385 because the occurrence analyser doesn't teke account of type/coercion variables
 386 when computing dependencies.
 387
 388 So we pull out the type/coercion variables (which are in dependency order),
 389 and Rec the rest.
 390
 391
 392 \begin{code}
 393 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 394 mkAutoScc dflags mod exports
 395   | not opt_SccProfilingOn      -- No profiling
 396   = NoSccs
 397     -- Add auto-scc on all top-level things
 398   | dopt Opt_AutoSccsOnAllToplevs dflags
 399   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 400     -- See #1641.  This is pretty yucky, but I can't see a better way
 401     -- to identify compiler-generated Ids, and at least this should
 402     -- catch them all.
 403     -- Only on exported things
 404   | dopt Opt_AutoSccsOnExportedToplevs dflags
 405   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 406   | otherwise
 407   = NoSccs
 408
 409 deSugarExpr :: HscEnv
 410             -> Module -> GlobalRdrEnv -> TypeEnv
 411             -> LHsExpr Id
 412             -> IO (Messages, Maybe CoreExpr)
 413 -- Prints its own errors; returns Nothing if error occurred
 414
 415 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 416     let dflags = hsc_dflags hsc_env
 417     showPass dflags "Desugar"
 418
 419     -- Do desugaring
 420     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 421                                    dsLExpr tc_expr
 422
 423     case mb_core_expr of
 424       Nothing   -> return (msgs, Nothing)
 425       Just expr -> do
 426
 427         -- Dump output
 428         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 429
 430         return (msgs, Just expr)
 431 \end{code}
 432
 433 %************************************************************************
 434 %*                                                                      *
 435 %*              Add rules and export flags to binders
 436 %*                                                                      *
 437 %************************************************************************
 438
 439 \begin{code}
 440 addExportFlagsAndRules
 441     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 442     -> [(Id, t)] -> [(Id, t)]
 443 addExportFlagsAndRules target exports keep_alive rules prs
 444   = mapFst add_one prs
 445   where
 446     add_one bndr = add_rules name (add_export name bndr)
 447        where
 448          name = idName bndr
 449
 450     ---------- Rules --------
 451         -- See Note [Attach rules to local ids]
 452         -- NB: the binder might have some existing rules,
 453         -- arising from specialisation pragmas
 454     add_rules name bndr
 455         | Just rules <- lookupNameEnv rule_base name
 456         = bndr `addIdSpecialisations` rules
 457         | otherwise
 458         = bndr
 459     rule_base = extendRuleBaseList emptyRuleBase rules
 460
 461     ---------- Export flag --------
 462     -- See Note [Adding export flags]
 463     add_export name bndr
 464         | dont_discard name = setIdExported bndr
 465         | otherwise         = bndr
 466
 467     dont_discard :: Name -> Bool
 468     dont_discard name = is_exported name
 469                      || name `elemNameSet` keep_alive
 470
 471         -- In interactive mode, we don't want to discard any top-level
 472         -- entities at all (eg. do not inline them away during
 473         -- simplification), and retain them all in the TypeEnv so they are
 474         -- available from the command line.
 475         --
 476         -- isExternalName separates the user-defined top-level names from those
 477         -- introduced by the type checker.
 478     is_exported :: Name -> Bool
 479     is_exported | target == HscInterpreted = isExternalName
 480                 | otherwise                = (`elemNameSet` exports)
 481 \end{code}
 482
 483
 484 Note [Adding export flags]
 485 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 486 Set the no-discard flag if either
 487         a) the Id is exported
 488         b) it's mentioned in the RHS of an orphan rule
 489         c) it's in the keep-alive set
 490
 491 It means that the binding won't be discarded EVEN if the binding
 492 ends up being trivial (v = w) -- the simplifier would usually just
 493 substitute w for v throughout, but we don't apply the substitution to
 494 the rules (maybe we should?), so this substitution would make the rule
 495 bogus.
 496
 497 You might wonder why exported Ids aren't already marked as such;
 498 it's just because the type checker is rather busy already and
 499 I didn't want to pass in yet another mapping.
 500
 501 Note [Attach rules to local ids]
 502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 503 Find the rules for locally-defined Ids; then we can attach them
 504 to the binders in the top-level bindings
 505
 506 Reason
 507   - It makes the rules easier to look up
 508   - It means that transformation rules and specialisations for
 509     locally defined Ids are handled uniformly
 510   - It keeps alive things that are referred to only from a rule
 511     (the occurrence analyser knows about rules attached to Ids)
 512   - It makes sure that, when we apply a rule, the free vars
 513     of the RHS are more likely to be in scope
 514   - The imported rules are carried in the in-scope set
 515     which is extended on each iteration by the new wave of
 516     local binders; any rules which aren't on the binding will
 517     thereby get dropped
 518
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 %*              Desugaring transformation rules
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 \begin{code}
 527 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 528 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 529   = putSrcSpanDs loc $
 530     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 531
 532         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 533                   unsetOptM Opt_WarnIdentities $
 534                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 535
 536         ; rhs' <- dsLExpr rhs
 537
 538         -- Substitute the dict bindings eagerly,
 539         -- and take the body apart into a (f args) form
 540         ; case decomposeRuleLhs bndrs' lhs' of {
 541                 Left msg -> do { warnDs msg; return Nothing } ;
 542                 Right (final_bndrs, fn_id, args) -> do
 543
 544         { let is_local = isLocalId fn_id
 545                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 546                 -- we don't want to attach rules to the bindings of implicit Ids,
 547                 -- because they don't show up in the bindings until just before code gen
 548               fn_name   = idName fn_id
 549               final_rhs = simpleOptExpr rhs'    -- De-crap it
 550               rule      = mkRule False {- Not auto -} is_local
 551                                  name act fn_name final_bndrs args final_rhs
 552         ; return (Just rule)
 553         } } }
 554 \end{code}
 555
 556 Note [Desugaring RULE left hand sides]
 557 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 558 For the LHS of a RULE we do *not* want to desugar
 559     [x]   to    build (\cn. x `c` n)
 560 We want to leave explicit lists simply as chains
 561 of cons's. We can achieve that slightly indirectly by
 562 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 563
 564 That keeps the desugaring of list comprehensions simple too.
 565
 566
 567
 568 Nor do we want to warn of conversion identities on the LHS;
 569 the rule is precisly to optimise them:
 570   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 %*              Desugaring vectorisation declarations
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 \begin{code}
 580 dsVect :: LVectDecl Id -> DsM CoreVect
 581 dsVect (L loc (HsVect (L _ v) rhs))
 582   = putSrcSpanDs loc $
 583     do { rhs' <- fmapMaybeM dsLExpr rhs
 584        ; return $ Vect v rhs'
 585            }
 586 dsVect (L _loc (HsNoVect (L _ v)))
 587   = return $ NoVect v
 588 \end{code}
 589
 590
 591
 592 \begin{code}
 593 --
 594 -- Simplification routines run before the flattener.  We can't use
 595 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
 596 -- let-binding groups.
 597 --
 598 simplify :: Expr CoreBndr -> Expr CoreBndr
 599 simplify (Var v)                 = Var v
 600 simplify (App e1 e2)             = App (simplify e1) (simplify e2)
 601 simplify (Lit lit)               = Lit lit
 602 simplify (Note note e)           = Note note (simplify e)
 603 simplify (Cast e co)             = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
 604                                        then simplify e
 605                                        else Cast (simplify e) co
 606 simplify (Lam v e)               = Lam v (simplify e)
 607 simplify (Case e b ty as)        = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
 608 simplify (Let bind body)         = foldr Let (simplify body) (simplifyBind bind)
 609 simplify (Type t)                = Type t
 610 simplify (Coercion co)           = Coercion co
 611
 612 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
 613 simplifyBind (NonRec b e)             = [NonRec b (simplify e)]
 614 simplifyBind (Rec [])                 = []
 615 simplifyBind (Rec (rbs@((b,e):rbs'))) =
 616     if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
 617     then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
 618     else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
 619
 620 simplifyBinds = concatMap simplifyBind
 621 \end{code}