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