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