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