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 Control.Exception ( catch, ErrorCall, Exception(..) )
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 %*              The main function: deSugar
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 \begin{code}
  54 -- | Main entry point to the desugarer.
  55 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  56 -- Can modify PCS by faulting in more declarations
  57
  58 deSugar hsc_env
  59         mod_loc
  60         tcg_env@(TcGblEnv { tcg_mod          = mod,
  61                             tcg_src          = hsc_src,
  62                             tcg_type_env     = type_env,
  63                             tcg_imports      = imports,
  64                             tcg_exports      = exports,
  65                             tcg_keep         = keep_var,
  66                             tcg_rdr_env      = rdr_env,
  67                             tcg_fix_env      = fix_env,
  68                             tcg_inst_env     = inst_env,
  69                             tcg_fam_inst_env = fam_inst_env,
  70                             tcg_warns        = warns,
  71                             tcg_anns         = anns,
  72                             tcg_binds        = binds,
  73                             tcg_imp_specs    = imp_specs,
  74                             tcg_ev_binds     = ev_binds,
  75                             tcg_fords        = fords,
  76                             tcg_rules        = rules,
  77                             tcg_insts        = insts,
  78                             tcg_fam_insts    = fam_insts,
  79                             tcg_hpc          = other_hpc_info })
  80
  81   = do  { let dflags = hsc_dflags hsc_env
  82         ; showPass dflags "Desugar"
  83
  84         -- Desugar the program
  85         ; let export_set = availsToNameSet exports
  86         ; let auto_scc = mkAutoScc dflags mod export_set
  87         ; let target = hscTarget dflags
  88         ; let hpcInfo = emptyHpcInfo other_hpc_info
  89         ; (msgs, mb_res)
  90               <- case target of
  91                    HscNothing ->
  92                        return (emptyMessages,
  93                                Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
  94                    _        -> do
  95                      (binds_cvr,ds_hpc_info, modBreaks)
  96                          <- if (opt_Hpc
  97                                   || target == HscInterpreted)
  98                                && (not (isHsBoot hsc_src))
  99                               then addCoverageTicksToBinds dflags mod mod_loc
 100                                                            (typeEnvTyCons type_env) binds
 101                               else return (binds, hpcInfo, emptyModBreaks)
 102                      initDs hsc_env mod rdr_env type_env $ do
 103                        do { ds_ev_binds <- dsEvBinds ev_binds
 104                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 105                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 106                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 107                           ; rules <- mapMaybeM dsRule rules
 108                           ; return ( ds_ev_binds
 109                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 110                                    , spec_rules ++ rules
 111                                    , ds_fords, ds_hpc_info, modBreaks) }
 112
 113         ; case mb_res of {
 114            Nothing -> return (msgs, Nothing) ;
 115            Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 116
 117         {       -- Add export flags to bindings
 118           keep_alive <- readIORef keep_var
 119         ; let (rules_for_locals, rules_for_imps)
 120                    = partition isLocalRule all_rules
 121               final_prs = addExportFlagsAndRules target
 122                               export_set keep_alive rules_for_locals (fromOL all_prs)
 123
 124               final_pgm = combineEvBinds ds_ev_binds final_prs
 125         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 126         -- When compiling PrelFloat, which defines data Float = F# Float#
 127         -- we want F# to be in scope in the foreign marshalling code!
 128         -- You might think it doesn't matter, but the simplifier brings all top-level
 129         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 130
 131         -- Lint result if necessary, and print
 132         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 133                (vcat [ pprCoreBindings final_pgm
 134                      , pprRules rules_for_imps ])
 135
 136         ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
 137                          -- The simpleOptPgm gets rid of type
 138                          -- bindings plus any stupid dead code
 139 {-
 140         ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds)
 141         ; let uhandler (err::ErrorCall)
 142                       = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof"
 143                                        (text $ "\\begin{verbatim}\n" ++
 144                                                show err ++
 145                                                "\\end{verbatim}\n\n")
 146           in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $
 147                (vcat (map (\ bind -> let e = case bind of
 148                                                NonRec b e -> e
 149                                                Rec    lve -> Let (Rec lve) (Var unitDataConId)
 150                                      in text $ "\\begin{verbatim}\n" ++
 151                                                (showSDoc $ pprCoreBindings ds_binds) ++
 152                                                "\\end{verbatim}\n\n" ++
 153                                                "$$\n"++
 154                                                (core2proofAndShow e) ++
 155                                                "$$\n"
 156                           ) ds_binds))) `Control.Exception.catch` uhandler
 157 -}
 158         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 159
 160         ; let used_names = mkUsedNames tcg_env
 161         ; deps <- mkDependencies tcg_env
 162
 163         ; let mod_guts = ModGuts {
 164                 mg_module       = mod,
 165                 mg_boot         = isHsBoot hsc_src,
 166                 mg_exports      = exports,
 167                 mg_deps         = deps,
 168                 mg_used_names   = used_names,
 169                 mg_dir_imps     = imp_mods imports,
 170                 mg_rdr_env      = rdr_env,
 171                 mg_fix_env      = fix_env,
 172                 mg_warns        = warns,
 173                 mg_anns         = anns,
 174                 mg_types        = type_env,
 175                 mg_insts        = insts,
 176                 mg_fam_insts    = fam_insts,
 177                 mg_inst_env     = inst_env,
 178                 mg_fam_inst_env = fam_inst_env,
 179                 mg_rules        = ds_rules_for_imps,
 180                 mg_binds        = ds_binds,
 181                 mg_foreign      = ds_fords,
 182                 mg_hpc_info     = ds_hpc_info,
 183                 mg_modBreaks    = modBreaks,
 184                 mg_vect_info    = noVectInfo
 185               }
 186         ; return (msgs, Just mod_guts)
 187         }}}
 188
 189 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 190 dsImpSpecs imp_specs
 191  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 192       ; let (spec_binds, spec_rules) = unzip spec_prs
 193       ; return (concatOL spec_binds, spec_rules) }
 194
 195 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 196 -- Top-level bindings can include coercion bindings, but not via superclasses
 197 -- See Note [Top-level evidence]
 198 combineEvBinds [] val_prs
 199   = [Rec val_prs]
 200 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 201   | isId b    = combineEvBinds bs ((b,r):val_prs)
 202   | otherwise = NonRec b r : combineEvBinds bs val_prs
 203 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 204   = combineEvBinds bs (prs ++ val_prs)
 205 combineEvBinds (CaseEvBind x _ _ : _) _
 206   = pprPanic "topEvBindPairs" (ppr x)
 207 \end{code}
 208
 209 Note [Top-level evidence]
 210 ~~~~~~~~~~~~~~~~~~~~~~~~~
 211 Top-level evidence bindings may be mutually recursive with the top-level value
 212 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 213 because the occurrence analyser doesn't teke account of type/coercion variables
 214 when computing dependencies.
 215
 216 So we pull out the type/coercion variables (which are in dependency order),
 217 and Rec the rest.
 218
 219
 220 \begin{code}
 221 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 222 mkAutoScc dflags mod exports
 223   | not opt_SccProfilingOn      -- No profiling
 224   = NoSccs
 225     -- Add auto-scc on all top-level things
 226   | dopt Opt_AutoSccsOnAllToplevs dflags
 227   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 228     -- See #1641.  This is pretty yucky, but I can't see a better way
 229     -- to identify compiler-generated Ids, and at least this should
 230     -- catch them all.
 231     -- Only on exported things
 232   | dopt Opt_AutoSccsOnExportedToplevs dflags
 233   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 234   | otherwise
 235   = NoSccs
 236
 237 deSugarExpr :: HscEnv
 238             -> Module -> GlobalRdrEnv -> TypeEnv
 239             -> LHsExpr Id
 240             -> IO (Messages, Maybe CoreExpr)
 241 -- Prints its own errors; returns Nothing if error occurred
 242
 243 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 244     let dflags = hsc_dflags hsc_env
 245     showPass dflags "Desugarz"
 246
 247     -- Do desugaring
 248     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 249                                    dsLExpr tc_expr
 250
 251     case mb_core_expr of
 252       Nothing   -> return (msgs, Nothing)
 253       Just expr -> do
 254
 255 {-
 256         -- Dump output
 257         dumpIfSet_dyn dflags Opt_D_dump_ds    "Desugared"            (text $ "$$\n"++(core2proofAndShow expr)++"$$\n")
 258 -}
 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 #-}