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