compiler/deSugar/Desugar.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The Desugarer: turning HsSyn into Core.
   7
   8 \begin{code}
   9 module Desugar ( deSugar, deSugarExpr ) where
  10
  11 import DynFlags
  12 import StaticFlags
  13 import HscTypes
  14 import HsSyn
  15 import TcRnTypes
  16 import MkIface
  17 import Id
  18 import Name
  19 import CoreSyn
  20 import CoreSubst
  21 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
  22 import PprCore
  23 import DsMonad
  24 import DsExpr
  25 import DsBinds
  26 import DsForeign
  27 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  28                                 -- depends on DsExpr.hi-boot.
  29 import Module
  30 import RdrName
  31 import NameSet
  32 import NameEnv
  33 import Rules
  34 import CoreMonad        ( endPass, CoreToDo(..) )
  35 import ErrUtils
  36 import Outputable
  37 import SrcLoc
  38 import Coverage
  39 import Util
  40 import MonadUtils
  41 import OrdList
  42 import Data.List
  43 import Data.IORef
  44 import PrelNames
  45 import UniqSupply
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 %*              The main function: deSugar
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 \begin{code}
  55 -- | Main entry point to the desugarer.
  56 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  57 -- Can modify PCS by faulting in more declarations
  58
  59 deSugar hsc_env
  60         mod_loc
  61         tcg_env@(TcGblEnv { tcg_mod          = mod,
  62                             tcg_src          = hsc_src,
  63                             tcg_type_env     = type_env,
  64                             tcg_imports      = imports,
  65                             tcg_exports      = exports,
  66                             tcg_keep         = keep_var,
  67                             tcg_rdr_env      = rdr_env,
  68                             tcg_fix_env      = fix_env,
  69                             tcg_inst_env     = inst_env,
  70                             tcg_fam_inst_env = fam_inst_env,
  71                             tcg_warns        = warns,
  72                             tcg_anns         = anns,
  73                             tcg_binds        = binds,
  74                             tcg_imp_specs    = imp_specs,
  75                             tcg_ev_binds     = ev_binds,
  76                             tcg_fords        = fords,
  77                             tcg_rules        = rules,
  78                             tcg_vects        = vects,
  79                             tcg_insts        = insts,
  80                             tcg_fam_insts    = fam_insts,
  81                             tcg_hpc          = other_hpc_info })
  82
  83   = do  { let dflags = hsc_dflags hsc_env
  84         ; showPass dflags "Desugar"
  85
  86         -- Desugar the program
  87         ; let export_set = availsToNameSet exports
  88         ; let auto_scc = mkAutoScc dflags mod export_set
  89         ; let target = hscTarget dflags
  90         ; let hpcInfo = emptyHpcInfo other_hpc_info
  91         ; (msgs, mb_res)
  92               <- case target of
  93                    HscNothing ->
  94                        return (emptyMessages,
  95                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined))
  96                    _        -> do
  97                      (binds_cvr,ds_hpc_info, modBreaks)
  98                          <- if (opt_Hpc
  99                                   || target == HscInterpreted)
 100                                && (not (isHsBoot hsc_src))
 101                               then addCoverageTicksToBinds dflags mod mod_loc
 102                                                            (typeEnvTyCons type_env) binds
 103                               else return (binds, hpcInfo, emptyModBreaks)
 104                      initDs hsc_env mod rdr_env type_env $ do
 105                        do { ds_ev_binds <- dsEvBinds ev_binds
 106                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 107                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 108                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 109                           ; ds_rules <- mapMaybeM dsRule rules
 110                           ; ds_vects <- mapM dsVect vects
 111                           ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
 112                           ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
 113                           ; let hpc_init
 114                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
 115                                   | otherwise = empty
 116                           ; return ( ds_ev_binds
 117                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 118                                    , spec_rules ++ ds_rules, ds_vects
 119                                    , ds_fords `appendStubC` hpc_init
 120                                    , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) }
 121
 122         ; case mb_res of {
 123            Nothing -> return (msgs, Nothing) ;
 124            Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do
 125
 126         {       -- Add export flags to bindings
 127           keep_alive <- readIORef keep_var
 128         ; let (rules_for_locals, rules_for_imps)
 129                    = partition isLocalRule all_rules
 130               final_prs = addExportFlagsAndRules target
 131                               export_set keep_alive rules_for_locals (fromOL all_prs)
 132
 133               final_pgm = combineEvBinds ds_ev_binds final_prs
 134         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 135         -- When compiling PrelFloat, which defines data Float = F# Float#
 136         -- we want F# to be in scope in the foreign marshalling code!
 137         -- You might think it doesn't matter, but the simplifier brings all top-level
 138         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 139
 140         -- Lint result if necessary, and print
 141         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 142                (vcat [ pprCoreBindings final_pgm
 143                      , pprRules rules_for_imps ])
 144
 145         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 146                          -- The simpleOptPgm gets rid of type
 147                          -- bindings plus any stupid dead code
 148
 149         ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds
 150
 151         ; ds_binds' <- if dopt Opt_F_coqpass dflags
 152                        then do { us <- mkSplitUniqSupply '~'
 153                                ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds
 154                                }
 155                        else return ds_binds
 156
 157         ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
 158
 159         ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
 160
 161         ; let used_names = mkUsedNames tcg_env
 162         ; deps <- mkDependencies tcg_env
 163
 164         ; let mod_guts = ModGuts {
 165                 mg_module       = mod,
 166                 mg_boot         = isHsBoot hsc_src,
 167                 mg_exports      = exports,
 168                 mg_deps         = deps,
 169                 mg_used_names   = used_names,
 170                 mg_dir_imps     = imp_mods imports,
 171                 mg_rdr_env      = rdr_env,
 172                 mg_fix_env      = fix_env,
 173                 mg_warns        = warns,
 174                 mg_anns         = anns,
 175                 mg_types        = type_env,
 176                 mg_insts        = insts,
 177                 mg_fam_insts    = fam_insts,
 178                 mg_inst_env     = inst_env,
 179                 mg_fam_inst_env = fam_inst_env,
 180                 mg_rules        = ds_rules_for_imps,
 181                 mg_binds        = ds_binds',
 182                 mg_foreign      = ds_fords,
 183                 mg_hpc_info     = ds_hpc_info,
 184                 mg_modBreaks    = modBreaks,
 185                 mg_vect_decls   = ds_vects,
 186                 mg_vect_info    = noVectInfo
 187               }
 188         ; return (msgs, Just mod_guts)
 189         }}}
 190
 191 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 192 dsImpSpecs imp_specs
 193  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 194       ; let (spec_binds, spec_rules) = unzip spec_prs
 195       ; return (concatOL spec_binds, spec_rules) }
 196
 197 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 198 -- Top-level bindings can include coercion bindings, but not via superclasses
 199 -- See Note [Top-level evidence]
 200 combineEvBinds [] val_prs
 201   = [Rec val_prs]
 202 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 203   | isId b    = combineEvBinds bs ((b,r):val_prs)
 204   | otherwise = NonRec b r : combineEvBinds bs val_prs
 205 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 206   = combineEvBinds bs (prs ++ val_prs)
 207 combineEvBinds (CaseEvBind x _ _ : _) _
 208   = pprPanic "topEvBindPairs" (ppr x)
 209 \end{code}
 210
 211 Note [Top-level evidence]
 212 ~~~~~~~~~~~~~~~~~~~~~~~~~
 213 Top-level evidence bindings may be mutually recursive with the top-level value
 214 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 215 because the occurrence analyser doesn't teke account of type/coercion variables
 216 when computing dependencies.
 217
 218 So we pull out the type/coercion variables (which are in dependency order),
 219 and Rec the rest.
 220
 221
 222 \begin{code}
 223 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 224 mkAutoScc dflags mod exports
 225   | not opt_SccProfilingOn      -- No profiling
 226   = NoSccs
 227     -- Add auto-scc on all top-level things
 228   | dopt Opt_AutoSccsOnAllToplevs dflags
 229   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 230     -- See #1641.  This is pretty yucky, but I can't see a better way
 231     -- to identify compiler-generated Ids, and at least this should
 232     -- catch them all.
 233     -- Only on exported things
 234   | dopt Opt_AutoSccsOnExportedToplevs dflags
 235   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 236   | otherwise
 237   = NoSccs
 238
 239 deSugarExpr :: HscEnv
 240             -> Module -> GlobalRdrEnv -> TypeEnv
 241             -> LHsExpr Id
 242             -> IO (Messages, Maybe CoreExpr)
 243 -- Prints its own errors; returns Nothing if error occurred
 244
 245 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 246     let dflags = hsc_dflags hsc_env
 247     showPass dflags "Desugar"
 248
 249     -- Do desugaring
 250     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 251                                    dsLExpr tc_expr
 252
 253     case mb_core_expr of
 254       Nothing   -> return (msgs, Nothing)
 255       Just expr -> do
 256
 257         -- Dump output
 258         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 259
 260         return (msgs, Just expr)
 261 \end{code}
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 %*              Add rules and export flags to binders
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270 addExportFlagsAndRules
 271     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 272     -> [(Id, t)] -> [(Id, t)]
 273 addExportFlagsAndRules target exports keep_alive rules prs
 274   = mapFst add_one prs
 275   where
 276     add_one bndr = add_rules name (add_export name bndr)
 277        where
 278          name = idName bndr
 279
 280     ---------- Rules --------
 281         -- See Note [Attach rules to local ids]
 282         -- NB: the binder might have some existing rules,
 283         -- arising from specialisation pragmas
 284     add_rules name bndr
 285         | Just rules <- lookupNameEnv rule_base name
 286         = bndr `addIdSpecialisations` rules
 287         | otherwise
 288         = bndr
 289     rule_base = extendRuleBaseList emptyRuleBase rules
 290
 291     ---------- Export flag --------
 292     -- See Note [Adding export flags]
 293     add_export name bndr
 294         | dont_discard name = setIdExported bndr
 295         | otherwise         = bndr
 296
 297     dont_discard :: Name -> Bool
 298     dont_discard name = is_exported name
 299                      || name `elemNameSet` keep_alive
 300
 301         -- In interactive mode, we don't want to discard any top-level
 302         -- entities at all (eg. do not inline them away during
 303         -- simplification), and retain them all in the TypeEnv so they are
 304         -- available from the command line.
 305         --
 306         -- isExternalName separates the user-defined top-level names from those
 307         -- introduced by the type checker.
 308     is_exported :: Name -> Bool
 309     is_exported | target == HscInterpreted = isExternalName
 310                 | otherwise                = (`elemNameSet` exports)
 311 \end{code}
 312
 313
 314 Note [Adding export flags]
 315 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 316 Set the no-discard flag if either
 317         a) the Id is exported
 318         b) it's mentioned in the RHS of an orphan rule
 319         c) it's in the keep-alive set
 320
 321 It means that the binding won't be discarded EVEN if the binding
 322 ends up being trivial (v = w) -- the simplifier would usually just
 323 substitute w for v throughout, but we don't apply the substitution to
 324 the rules (maybe we should?), so this substitution would make the rule
 325 bogus.
 326
 327 You might wonder why exported Ids aren't already marked as such;
 328 it's just because the type checker is rather busy already and
 329 I didn't want to pass in yet another mapping.
 330
 331 Note [Attach rules to local ids]
 332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 333 Find the rules for locally-defined Ids; then we can attach them
 334 to the binders in the top-level bindings
 335
 336 Reason
 337   - It makes the rules easier to look up
 338   - It means that transformation rules and specialisations for
 339     locally defined Ids are handled uniformly
 340   - It keeps alive things that are referred to only from a rule
 341     (the occurrence analyser knows about rules attached to Ids)
 342   - It makes sure that, when we apply a rule, the free vars
 343     of the RHS are more likely to be in scope
 344   - The imported rules are carried in the in-scope set
 345     which is extended on each iteration by the new wave of
 346     local binders; any rules which aren't on the binding will
 347     thereby get dropped
 348
 349
 350 %************************************************************************
 351 %*                                                                      *
 352 %*              Desugaring transformation rules
 353 %*                                                                      *
 354 %************************************************************************
 355
 356 \begin{code}
 357 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 358 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 359   = putSrcSpanDs loc $
 360     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 361
 362         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 363                   unsetOptM Opt_WarnIdentities $
 364                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 365
 366         ; rhs' <- dsLExpr rhs
 367
 368         -- Substitute the dict bindings eagerly,
 369         -- and take the body apart into a (f args) form
 370         ; case decomposeRuleLhs bndrs' lhs' of {
 371                 Left msg -> do { warnDs msg; return Nothing } ;
 372                 Right (final_bndrs, fn_id, args) -> do
 373
 374         { let is_local = isLocalId fn_id
 375                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 376                 -- we don't want to attach rules to the bindings of implicit Ids,
 377                 -- because they don't show up in the bindings until just before code gen
 378               fn_name   = idName fn_id
 379               final_rhs = simpleOptExpr rhs'    -- De-crap it
 380               rule      = mkRule False {- Not auto -} is_local
 381                                  name act fn_name final_bndrs args final_rhs
 382         ; return (Just rule)
 383         } } }
 384 \end{code}
 385
 386 Note [Desugaring RULE left hand sides]
 387 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 388 For the LHS of a RULE we do *not* want to desugar
 389     [x]   to    build (\cn. x `c` n)
 390 We want to leave explicit lists simply as chains
 391 of cons's. We can achieve that slightly indirectly by
 392 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 393
 394 That keeps the desugaring of list comprehensions simple too.
 395
 396 Nor do we want to warn of conversion identities on the LHS;
 397 the rule is precisly to optimise them:
 398   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 399
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 %*              Desugaring vectorisation declarations
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 \begin{code}
 408 dsVect :: LVectDecl Id -> DsM CoreVect
 409 dsVect (L loc (HsVect v rhs))
 410   = putSrcSpanDs loc $
 411     do { rhs' <- fmapMaybeM dsLExpr rhs
 412        ; return $ Vect (unLoc v) rhs'
 413            }
 414 -- dsVect (L loc (HsVect v Nothing))
 415 --   = return $ Vect v Nothing
 416 -- dsVect (L loc (HsVect v (Just rhs)))
 417 --   = putSrcSpanDs loc $
 418 --     do { rhs' <- dsLExpr rhs
 419 --        ; return $ Vect v (Just rhs')
 420 --       }
 421 \end{code}