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