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 TysWiredIn (unitDataConId)
  12 import DynFlags
  13 import StaticFlags
  14 import HscTypes
  15 import HsSyn
  16 import TcRnTypes
  17 import MkIface
  18 import Id
  19 import Name
  20 import CoreSyn
  21 import CoreSubst
  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 DsHetMet
  45 import Control.Exception ( catch, ErrorCall, Exception(..) )
  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_insts        = insts,
  79                             tcg_fam_insts    = fam_insts,
  80                             tcg_hpc          = other_hpc_info })
  81
  82   = do  { let dflags = hsc_dflags hsc_env
  83         ; showPass dflags "Desugar"
  84
  85         -- Desugar the program
  86         ; let export_set = availsToNameSet exports
  87         ; let auto_scc = mkAutoScc dflags mod export_set
  88         ; let target = hscTarget dflags
  89         ; let hpcInfo = emptyHpcInfo other_hpc_info
  90         ; (msgs, mb_res)
  91               <- case target of
  92                    HscNothing ->
  93                        return (emptyMessages,
  94                                Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
  95                    _        -> do
  96                      (binds_cvr,ds_hpc_info, modBreaks)
  97                          <- if (opt_Hpc
  98                                   || target == HscInterpreted)
  99                                && (not (isHsBoot hsc_src))
 100                               then addCoverageTicksToBinds dflags mod mod_loc
 101                                                            (typeEnvTyCons type_env) binds
 102                               else return (binds, hpcInfo, emptyModBreaks)
 103                      initDs hsc_env mod rdr_env type_env $ do
 104                        do { ds_ev_binds <- dsEvBinds ev_binds
 105                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 106                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 107                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 108                           ; rules <- mapMaybeM dsRule rules
 109                           ; return ( ds_ev_binds
 110                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 111                                    , spec_rules ++ rules
 112                                    , ds_fords, ds_hpc_info, modBreaks) }
 113
 114         ; case mb_res of {
 115            Nothing -> return (msgs, Nothing) ;
 116            Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 117
 118         {       -- Add export flags to bindings
 119           keep_alive <- readIORef keep_var
 120         ; let (rules_for_locals, rules_for_imps)
 121                    = partition isLocalRule all_rules
 122               final_prs = addExportFlagsAndRules target
 123                               export_set keep_alive rules_for_locals (fromOL all_prs)
 124
 125               final_pgm = combineEvBinds ds_ev_binds final_prs
 126         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 127         -- When compiling PrelFloat, which defines data Float = F# Float#
 128         -- we want F# to be in scope in the foreign marshalling code!
 129         -- You might think it doesn't matter, but the simplifier brings all top-level
 130         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 131
 132         -- Lint result if necessary, and print
 133         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 134                (vcat [ pprCoreBindings final_pgm
 135                      , pprRules rules_for_imps ])
 136
 137         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 138                          -- The simpleOptPgm gets rid of type
 139                          -- bindings plus any stupid dead code
 140 {-
 141         ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds)
 142         ; let uhandler (err::ErrorCall)
 143                       = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof"
 144                                        (text $ "\\begin{verbatim}\n" ++
 145                                                show err ++
 146                                                "\\end{verbatim}\n\n")
 147           in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $
 148                (vcat (map (\ bind -> let e = case bind of
 149                                                NonRec b e -> e
 150                                                Rec    lve -> Let (Rec lve) (Var unitDataConId)
 151                                      in text $ "\\begin{verbatim}\n" ++
 152                                                (showSDoc $ pprCoreBindings ds_binds) ++
 153                                                "\\end{verbatim}\n\n" ++
 154                                                "$$\n"++
 155                                                (core2proofAndShow e) ++
 156                                                "$$\n"
 157                           ) ds_binds))) `Control.Exception.catch` uhandler
 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_info    = noVectInfo
 186               }
 187         ; return (msgs, Just mod_guts)
 188         }}}
 189
 190 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 191 dsImpSpecs imp_specs
 192  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 193       ; let (spec_binds, spec_rules) = unzip spec_prs
 194       ; return (concatOL spec_binds, spec_rules) }
 195
 196 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 197 -- Top-level bindings can include coercion bindings, but not via superclasses
 198 -- See Note [Top-level evidence]
 199 combineEvBinds [] val_prs
 200   = [Rec val_prs]
 201 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 202   | isId b    = combineEvBinds bs ((b,r):val_prs)
 203   | otherwise = NonRec b r : combineEvBinds bs val_prs
 204 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 205   = combineEvBinds bs (prs ++ val_prs)
 206 combineEvBinds (CaseEvBind x _ _ : _) _
 207   = pprPanic "topEvBindPairs" (ppr x)
 208 \end{code}
 209
 210 Note [Top-level evidence]
 211 ~~~~~~~~~~~~~~~~~~~~~~~~~
 212 Top-level evidence bindings may be mutually recursive with the top-level value
 213 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 214 because the occurrence analyser doesn't teke account of type/coercion variables
 215 when computing dependencies.
 216
 217 So we pull out the type/coercion variables (which are in dependency order),
 218 and Rec the rest.
 219
 220
 221 \begin{code}
 222 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 223 mkAutoScc dflags mod exports
 224   | not opt_SccProfilingOn      -- No profiling
 225   = NoSccs
 226     -- Add auto-scc on all top-level things
 227   | dopt Opt_AutoSccsOnAllToplevs dflags
 228   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 229     -- See #1641.  This is pretty yucky, but I can't see a better way
 230     -- to identify compiler-generated Ids, and at least this should
 231     -- catch them all.
 232     -- Only on exported things
 233   | dopt Opt_AutoSccsOnExportedToplevs dflags
 234   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 235   | otherwise
 236   = NoSccs
 237
 238 deSugarExpr :: HscEnv
 239             -> Module -> GlobalRdrEnv -> TypeEnv
 240             -> LHsExpr Id
 241             -> IO (Messages, Maybe CoreExpr)
 242 -- Prints its own errors; returns Nothing if error occurred
 243
 244 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 245     let dflags = hsc_dflags hsc_env
 246     showPass dflags "Desugarz"
 247
 248     -- Do desugaring
 249     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 250                                    dsLExpr tc_expr
 251
 252     case mb_core_expr of
 253       Nothing   -> return (msgs, Nothing)
 254       Just expr -> do
 255
 256 {-
 257         -- Dump output
 258         dumpIfSet_dyn dflags Opt_D_dump_ds    "Desugared"            (text $ "$$\n"++(core2proofAndShow expr)++"$$\n")
 259 -}
 260
 261         return (msgs, Just expr)
 262 \end{code}
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 %*              Add rules and export flags to binders
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 \begin{code}
 271 addExportFlagsAndRules
 272     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 273     -> [(Id, t)] -> [(Id, t)]
 274 addExportFlagsAndRules target exports keep_alive rules prs
 275   = mapFst add_one prs
 276   where
 277     add_one bndr = add_rules name (add_export name bndr)
 278        where
 279          name = idName bndr
 280
 281     ---------- Rules --------
 282         -- See Note [Attach rules to local ids]
 283         -- NB: the binder might have some existing rules,
 284         -- arising from specialisation pragmas
 285     add_rules name bndr
 286         | Just rules <- lookupNameEnv rule_base name
 287         = bndr `addIdSpecialisations` rules
 288         | otherwise
 289         = bndr
 290     rule_base = extendRuleBaseList emptyRuleBase rules
 291
 292     ---------- Export flag --------
 293     -- See Note [Adding export flags]
 294     add_export name bndr
 295         | dont_discard name = setIdExported bndr
 296         | otherwise         = bndr
 297
 298     dont_discard :: Name -> Bool
 299     dont_discard name = is_exported name
 300                      || name `elemNameSet` keep_alive
 301
 302         -- In interactive mode, we don't want to discard any top-level
 303         -- entities at all (eg. do not inline them away during
 304         -- simplification), and retain them all in the TypeEnv so they are
 305         -- available from the command line.
 306         --
 307         -- isExternalName separates the user-defined top-level names from those
 308         -- introduced by the type checker.
 309     is_exported :: Name -> Bool
 310     is_exported | target == HscInterpreted = isExternalName
 311                 | otherwise                = (`elemNameSet` exports)
 312 \end{code}
 313
 314
 315 Note [Adding export flags]
 316 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 317 Set the no-discard flag if either
 318         a) the Id is exported
 319         b) it's mentioned in the RHS of an orphan rule
 320         c) it's in the keep-alive set
 321
 322 It means that the binding won't be discarded EVEN if the binding
 323 ends up being trivial (v = w) -- the simplifier would usually just
 324 substitute w for v throughout, but we don't apply the substitution to
 325 the rules (maybe we should?), so this substitution would make the rule
 326 bogus.
 327
 328 You might wonder why exported Ids aren't already marked as such;
 329 it's just because the type checker is rather busy already and
 330 I didn't want to pass in yet another mapping.
 331
 332 Note [Attach rules to local ids]
 333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 334 Find the rules for locally-defined Ids; then we can attach them
 335 to the binders in the top-level bindings
 336
 337 Reason
 338   - It makes the rules easier to look up
 339   - It means that transformation rules and specialisations for
 340     locally defined Ids are handled uniformly
 341   - It keeps alive things that are referred to only from a rule
 342     (the occurrence analyser knows about rules attached to Ids)
 343   - It makes sure that, when we apply a rule, the free vars
 344     of the RHS are more likely to be in scope
 345   - The imported rules are carried in the in-scope set
 346     which is extended on each iteration by the new wave of
 347     local binders; any rules which aren't on the binding will
 348     thereby get dropped
 349
 350
 351 %************************************************************************
 352 %*                                                                      *
 353 %*              Desugaring transformation rules
 354 %*                                                                      *
 355 %************************************************************************
 356
 357 \begin{code}
 358 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 359 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 360   = putSrcSpanDs loc $
 361     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 362
 363         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 364                   unsetOptM Opt_WarnIdentities $
 365                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 366
 367         ; rhs' <- dsLExpr rhs
 368
 369         -- Substitute the dict bindings eagerly,
 370         -- and take the body apart into a (f args) form
 371         ; case decomposeRuleLhs bndrs' lhs' of {
 372                 Left msg -> do { warnDs msg; return Nothing } ;
 373                 Right (final_bndrs, fn_id, args) -> do
 374
 375         { let is_local = isLocalId fn_id
 376                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 377                 -- we don't want to attach rules to the bindings of implicit Ids,
 378                 -- because they don't show up in the bindings until just before code gen
 379               fn_name   = idName fn_id
 380               final_rhs = simpleOptExpr rhs'    -- De-crap it
 381               rule      = mkRule False {- Not auto -} is_local
 382                                  name act fn_name final_bndrs args final_rhs
 383         ; return (Just rule)
 384         } } }
 385 \end{code}
 386
 387 Note [Desugaring RULE left hand sides]
 388 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 389 For the LHS of a RULE we do *not* want to desugar
 390     [x]   to    build (\cn. x `c` n)
 391 We want to leave explicit lists simply as chains
 392 of cons's. We can achieve that slightly indirectly by
 393 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 394
 395 That keeps the desugaring of list comprehensions simple too.
 396
 397 Nor do we want to warn of conversion identities on the LHS;
 398 the rule is precisly to optimise them:
 399   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}