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