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