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 PprCore
  21 import DsMonad
  22 import DsExpr
  23 import DsBinds
  24 import DsForeign
  25 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  26                                 -- depends on DsExpr.hi-boot.
  27 import Module
  28 import RdrName
  29 import NameSet
  30 import VarSet
  31 import Rules
  32 import CoreLint
  33 import CoreFVs
  34 import ErrUtils
  35 import Outputable
  36 import SrcLoc
  37 import Maybes
  38 import FastString
  39 import Coverage
  40
  41 import Data.IORef
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 %*              The main function: deSugar
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 \begin{code}
  51 -- | Main entry point to the desugarer.
  52 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  53 -- Can modify PCS by faulting in more declarations
  54
  55 deSugar hsc_env
  56         mod_loc
  57         tcg_env@(TcGblEnv { tcg_mod          = mod,
  58                             tcg_src          = hsc_src,
  59                             tcg_type_env     = type_env,
  60                             tcg_imports      = imports,
  61                             tcg_exports      = exports,
  62                             tcg_keep         = keep_var,
  63                             tcg_rdr_env      = rdr_env,
  64                             tcg_fix_env      = fix_env,
  65                             tcg_inst_env     = inst_env,
  66                             tcg_fam_inst_env = fam_inst_env,
  67                             tcg_warns        = warns,
  68                             tcg_anns         = anns,
  69                             tcg_binds        = binds,
  70                             tcg_fords        = fords,
  71                             tcg_rules        = rules,
  72                             tcg_insts        = insts,
  73                             tcg_fam_insts    = fam_insts,
  74                             tcg_hpc          = other_hpc_info })
  75
  76   = do  { let dflags = hsc_dflags hsc_env
  77         ; showPass dflags "Desugar"
  78
  79         -- Desugar the program
  80         ; let export_set = availsToNameSet exports
  81         ; let auto_scc = mkAutoScc dflags mod export_set
  82         ; let target = hscTarget dflags
  83         ; let hpcInfo = emptyHpcInfo other_hpc_info
  84         ; (msgs, mb_res)
  85               <- case target of
  86                    HscNothing ->
  87                        return (emptyMessages,
  88                                Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
  89                    _        -> do
  90                      (binds_cvr,ds_hpc_info, modBreaks)
  91                          <- if (opt_Hpc
  92                                   || target == HscInterpreted)
  93                                && (not (isHsBoot hsc_src))
  94                               then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
  95                               else return (binds, hpcInfo, emptyModBreaks)
  96                      initDs hsc_env mod rdr_env type_env $ do
  97                          core_prs <- dsTopLHsBinds auto_scc binds_cvr
  98                          (ds_fords, foreign_prs) <- dsForeigns fords
  99                          let all_prs = foreign_prs ++ core_prs
 100                          ds_rules <- mapM dsRule rules
 101                          return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
 102
 103         ; case mb_res of {
 104            Nothing -> return (msgs, Nothing) ;
 105            Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 106
 107         {       -- Add export flags to bindings
 108           keep_alive <- readIORef keep_var
 109         ; let final_prs = addExportFlags target export_set
 110                                  keep_alive all_prs ds_rules
 111               ds_binds  = [Rec final_prs]
 112         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 113         -- When compiling PrelFloat, which defines data Float = F# Float#
 114         -- we want F# to be in scope in the foreign marshalling code!
 115         -- You might think it doesn't matter, but the simplifier brings all top-level
 116         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 117
 118         -- Lint result if necessary
 119         ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
 120
 121         -- Dump output
 122         ; doIfSet (dopt Opt_D_dump_ds dflags)
 123                   (printDump (ppr_ds_rules ds_rules))
 124
 125         ; used_names <- mkUsedNames tcg_env
 126         ; deps <- mkDependencies tcg_env
 127
 128         ; let mod_guts = ModGuts {
 129                 mg_module       = mod,
 130                 mg_boot         = isHsBoot hsc_src,
 131                 mg_exports      = exports,
 132                 mg_deps         = deps,
 133                 mg_used_names   = used_names,
 134                 mg_dir_imps     = imp_mods imports,
 135                 mg_rdr_env      = rdr_env,
 136                 mg_fix_env      = fix_env,
 137                 mg_warns        = warns,
 138                 mg_anns         = anns,
 139                 mg_types        = type_env,
 140                 mg_insts        = insts,
 141                 mg_fam_insts    = fam_insts,
 142                 mg_inst_env     = inst_env,
 143                 mg_fam_inst_env = fam_inst_env,
 144                 mg_rules        = ds_rules,
 145                 mg_binds        = ds_binds,
 146                 mg_foreign      = ds_fords,
 147                 mg_hpc_info     = ds_hpc_info,
 148                 mg_modBreaks    = modBreaks,
 149                 mg_vect_info    = noVectInfo
 150               }
 151         ; return (msgs, Just mod_guts)
 152         }}}
 153
 154 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 155 mkAutoScc dflags mod exports
 156   | not opt_SccProfilingOn      -- No profiling
 157   = NoSccs
 158     -- Add auto-scc on all top-level things
 159   | dopt Opt_AutoSccsOnAllToplevs dflags
 160   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 161     -- See #1641.  This is pretty yucky, but I can't see a better way
 162     -- to identify compiler-generated Ids, and at least this should
 163     -- catch them all.
 164     -- Only on exported things
 165   | dopt Opt_AutoSccsOnExportedToplevs dflags
 166   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 167   | otherwise
 168   = NoSccs
 169
 170 deSugarExpr :: HscEnv
 171             -> Module -> GlobalRdrEnv -> TypeEnv
 172             -> LHsExpr Id
 173             -> IO (Messages, Maybe CoreExpr)
 174 -- Prints its own errors; returns Nothing if error occurred
 175
 176 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 177     let dflags = hsc_dflags hsc_env
 178     showPass dflags "Desugar"
 179
 180     -- Do desugaring
 181     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 182                                    dsLExpr tc_expr
 183
 184     case mb_core_expr of
 185       Nothing   -> return (msgs, Nothing)
 186       Just expr -> do
 187
 188         -- Dump output
 189         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 190
 191         return (msgs, Just expr)
 192
 193 --              addExportFlags
 194 -- Set the no-discard flag if either
 195 --      a) the Id is exported
 196 --      b) it's mentioned in the RHS of an orphan rule
 197 --      c) it's in the keep-alive set
 198 --
 199 -- It means that the binding won't be discarded EVEN if the binding
 200 -- ends up being trivial (v = w) -- the simplifier would usually just
 201 -- substitute w for v throughout, but we don't apply the substitution to
 202 -- the rules (maybe we should?), so this substitution would make the rule
 203 -- bogus.
 204
 205 -- You might wonder why exported Ids aren't already marked as such;
 206 -- it's just because the type checker is rather busy already and
 207 -- I didn't want to pass in yet another mapping.
 208
 209 addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [CoreRule]
 210                -> [(Id, t)]
 211 addExportFlags target exports keep_alive prs rules
 212   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
 213   where
 214     add_export bndr
 215         | dont_discard bndr = setIdExported bndr
 216         | otherwise         = bndr
 217
 218     orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
 219                                 | rule <- rules,
 220                                   not (isLocalRule rule) ]
 221         -- A non-local rule keeps alive the free vars of its right-hand side.
 222         -- (A "non-local" is one whose head function is not locally defined.)
 223         -- Local rules are (later, after gentle simplification)
 224         -- attached to the Id, and that keeps the rhs free vars alive.
 225
 226     dont_discard bndr = is_exported name
 227                      || name `elemNameSet` keep_alive
 228                      || bndr `elemVarSet` orph_rhs_fvs
 229                      where
 230                         name = idName bndr
 231
 232         -- In interactive mode, we don't want to discard any top-level
 233         -- entities at all (eg. do not inline them away during
 234         -- simplification), and retain them all in the TypeEnv so they are
 235         -- available from the command line.
 236         --
 237         -- isExternalName separates the user-defined top-level names from those
 238         -- introduced by the type checker.
 239     is_exported :: Name -> Bool
 240     is_exported | target == HscInterpreted = isExternalName
 241                 | otherwise                = (`elemNameSet` exports)
 242
 243 ppr_ds_rules :: [CoreRule] -> SDoc
 244 ppr_ds_rules [] = empty
 245 ppr_ds_rules rules
 246   = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$
 247     pprRules rules
 248 \end{code}
 249
 250
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 %*              Desugaring transformation rules
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 \begin{code}
 259 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 260 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 261   = putSrcSpanDs loc $
 262     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 263         ; lhs'  <- dsLExpr lhs
 264         ; rhs'  <- dsLExpr rhs
 265
 266         -- Substitute the dict bindings eagerly,
 267         -- and take the body apart into a (f args) form
 268         ; case decomposeRuleLhs (mkLams bndrs' lhs') of {
 269                 Nothing -> do { warnDs msg; return Nothing } ;
 270                 Just (bndrs, fn_id, args) -> do
 271
 272         { let local_rule = isLocalId fn_id
 273                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 274                 -- we don't want to attach rules to the bindings of implicit Ids,
 275                 -- because they don't show up in the bindings until just before code gen
 276               fn_name   = idName fn_id
 277
 278               rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
 279                             ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
 280                             ru_rough = roughTopNames args,
 281                             ru_local = local_rule }
 282         ; return (Just rule)
 283         } } }
 284   where
 285     msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored"))
 286              2 (ppr lhs)
 287 \end{code}