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