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 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module Desugar ( deSugar, deSugarExpr ) where
  17
  18 #include "HsVersions.h"
  19
  20 import DynFlags
  21 import StaticFlags
  22 import HscTypes
  23 import HsSyn
  24 import TcRnTypes
  25 import MkIface
  26 import Id
  27 import Name
  28 import CoreSyn
  29 import OccurAnal
  30 import PprCore
  31 import DsMonad
  32 import DsExpr
  33 import DsBinds
  34 import DsForeign
  35 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  36                                 -- depends on DsExpr.hi-boot.
  37 import Module
  38 import UniqFM
  39 import PackageConfig
  40 import RdrName
  41 import NameSet
  42 import VarSet
  43 import Rules
  44 import CoreLint
  45 import CoreFVs
  46 import ErrUtils
  47 import ListSetOps
  48 import Outputable
  49 import SrcLoc
  50 import Maybes
  51 import FastString
  52 import Util
  53 import Coverage
  54 import IOEnv
  55 import Data.IORef
  56 \end{code}
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 %*              The main function: deSugar
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts)
  66 -- Can modify PCS by faulting in more declarations
  67
  68 deSugar hsc_env
  69         mod_loc
  70         tcg_env@(TcGblEnv { tcg_mod          = mod,
  71                             tcg_src          = hsc_src,
  72                             tcg_type_env     = type_env,
  73                             tcg_imports      = imports,
  74                             tcg_exports      = exports,
  75                             tcg_dus          = dus,
  76                             tcg_inst_uses    = dfun_uses_var,
  77                             tcg_th_used      = th_var,
  78                             tcg_keep         = keep_var,
  79                             tcg_rdr_env      = rdr_env,
  80                             tcg_fix_env      = fix_env,
  81                             tcg_inst_env     = inst_env,
  82                             tcg_fam_inst_env = fam_inst_env,
  83                             tcg_deprecs      = deprecs,
  84                             tcg_binds        = binds,
  85                             tcg_fords        = fords,
  86                             tcg_rules        = rules,
  87                             tcg_insts        = insts,
  88                             tcg_fam_insts    = fam_insts,
  89                             tcg_hpc          = other_hpc_info })
  90
  91   = do  { let dflags = hsc_dflags hsc_env
  92         ; showPass dflags "Desugar"
  93
  94         -- Desugar the program
  95         ; let export_set = availsToNameSet exports
  96         ; let auto_scc = mkAutoScc mod export_set
  97         ; let target = hscTarget dflags
  98         ; let hpcInfo = emptyHpcInfo other_hpc_info
  99         ; mb_res <- case target of
 100                      HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
 101                      _        -> do (binds_cvr,ds_hpc_info, modBreaks)
 102                                               <- if (opt_Hpc
 103                                                         || target == HscInterpreted)
 104                                                      && (not (isHsBoot hsc_src))
 105                                                  then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
 106                                                  else return (binds, hpcInfo, emptyModBreaks)
 107                                     initDs hsc_env mod rdr_env type_env $ do
 108                                         { core_prs <- dsTopLHsBinds auto_scc binds_cvr
 109                                         ; (ds_fords, foreign_prs) <- dsForeigns fords
 110                                         ; let all_prs = foreign_prs ++ core_prs
 111                                               local_bndrs = mkVarSet (map fst all_prs)
 112                                         ; ds_rules <- mappM (dsRule mod local_bndrs) rules
 113                                         ; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
 114                                         }
 115         ; case mb_res of {
 116            Nothing -> return Nothing ;
 117            Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 118
 119         {       -- Add export flags to bindings
 120           keep_alive <- readIORef keep_var
 121         ; let final_prs = addExportFlags target export_set
 122                                  keep_alive all_prs ds_rules
 123               ds_binds  = [Rec final_prs]
 124         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 125         -- When compiling PrelFloat, which defines data Float = F# Float#
 126         -- we want F# to be in scope in the foreign marshalling code!
 127         -- You might think it doesn't matter, but the simplifier brings all top-level
 128         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 129
 130         -- Lint result if necessary
 131         ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
 132
 133         -- Dump output
 134         ; doIfSet (dopt Opt_D_dump_ds dflags)
 135                   (printDump (ppr_ds_rules ds_rules))
 136
 137         ; dfun_uses <- readIORef dfun_uses_var          -- What dfuns are used
 138         ; th_used   <- readIORef th_var                 -- Whether TH is used
 139         ; let used_names = allUses dus `unionNameSets` dfun_uses
 140               pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
 141                    | otherwise = imp_dep_pkgs imports
 142
 143               dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
 144                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
 145                 -- it before recording the modules on which this one depends!
 146                 -- (We want to retain M.hi-boot in imp_dep_mods so that
 147                 --  loadHiBootInterface can see if M's direct imports depend
 148                 --  on M.hi-boot, and hence that we should do the hi-boot consistency
 149                 --  check.)
 150
 151               dir_imp_mods = imp_mods imports
 152
 153         ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
 154
 155         ; let
 156                 -- Modules don't compare lexicographically usually,
 157                 -- but we want them to do so here.
 158              le_mod :: Module -> Module -> Bool
 159              le_mod m1 m2 = moduleNameFS (moduleName m1)
 160                                 <= moduleNameFS (moduleName m2)
 161              le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool
 162              le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
 163
 164              deps = Deps { dep_mods   = sortLe le_dep_mod dep_mods,
 165                            dep_pkgs   = sortLe (<=)   pkgs,
 166                            dep_orphs  = sortLe le_mod (imp_orphs  imports),
 167                            dep_finsts = sortLe le_mod (imp_finsts imports) }
 168                 -- sort to get into canonical order
 169
 170              mod_guts = ModGuts {
 171                 mg_module       = mod,
 172                 mg_boot         = isHsBoot hsc_src,
 173                 mg_exports      = exports,
 174                 mg_deps         = deps,
 175                 mg_usages       = usages,
 176                 mg_dir_imps     = [m | (m, _) <- moduleEnvElts dir_imp_mods],
 177                 mg_rdr_env      = rdr_env,
 178                 mg_fix_env      = fix_env,
 179                 mg_deprecs      = deprecs,
 180                 mg_types        = type_env,
 181                 mg_insts        = insts,
 182                 mg_fam_insts    = fam_insts,
 183                 mg_inst_env     = inst_env,
 184                 mg_fam_inst_env = fam_inst_env,
 185                 mg_rules        = ds_rules,
 186                 mg_binds        = ds_binds,
 187                 mg_foreign      = ds_fords,
 188                 mg_hpc_info     = ds_hpc_info,
 189                 mg_modBreaks    = modBreaks,
 190                 mg_vect_info    = noVectInfo
 191               }
 192         ; return (Just mod_guts)
 193         }}}
 194
 195 mkAutoScc :: Module -> NameSet -> AutoScc
 196 mkAutoScc mod exports
 197   | not opt_SccProfilingOn      -- No profiling
 198   = NoSccs
 199   | opt_AutoSccsOnAllToplevs    -- Add auto-scc on all top-level things
 200   = AddSccs mod (\id -> True)
 201   | opt_AutoSccsOnExportedToplevs       -- Only on exported things
 202   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 203   | otherwise
 204   = NoSccs
 205
 206
 207 deSugarExpr :: HscEnv
 208             -> Module -> GlobalRdrEnv -> TypeEnv
 209             -> LHsExpr Id
 210             -> IO (Maybe CoreExpr)
 211 -- Prints its own errors; returns Nothing if error occurred
 212
 213 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 214   = do  { let dflags = hsc_dflags hsc_env
 215         ; showPass dflags "Desugar"
 216
 217         -- Do desugaring
 218         ; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
 219                           dsLExpr tc_expr
 220
 221         ; case mb_core_expr of {
 222             Nothing   -> return Nothing ;
 223             Just expr -> do {
 224
 225                 -- Dump output
 226           dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 227
 228         ; return (Just expr) } } }
 229
 230 --              addExportFlags
 231 -- Set the no-discard flag if either
 232 --      a) the Id is exported
 233 --      b) it's mentioned in the RHS of an orphan rule
 234 --      c) it's in the keep-alive set
 235 --
 236 -- It means that the binding won't be discarded EVEN if the binding
 237 -- ends up being trivial (v = w) -- the simplifier would usually just
 238 -- substitute w for v throughout, but we don't apply the substitution to
 239 -- the rules (maybe we should?), so this substitution would make the rule
 240 -- bogus.
 241
 242 -- You might wonder why exported Ids aren't already marked as such;
 243 -- it's just because the type checker is rather busy already and
 244 -- I didn't want to pass in yet another mapping.
 245
 246 addExportFlags target exports keep_alive prs rules
 247   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
 248   where
 249     add_export bndr
 250         | dont_discard bndr = setIdExported bndr
 251         | otherwise         = bndr
 252
 253     orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
 254                                 | rule <- rules,
 255                                   not (isLocalRule rule) ]
 256         -- A non-local rule keeps alive the free vars of its right-hand side.
 257         -- (A "non-local" is one whose head function is not locally defined.)
 258         -- Local rules are (later, after gentle simplification)
 259         -- attached to the Id, and that keeps the rhs free vars alive.
 260
 261     dont_discard bndr = is_exported name
 262                      || name `elemNameSet` keep_alive
 263                      || bndr `elemVarSet` orph_rhs_fvs
 264                      where
 265                         name = idName bndr
 266
 267         -- In interactive mode, we don't want to discard any top-level
 268         -- entities at all (eg. do not inline them away during
 269         -- simplification), and retain them all in the TypeEnv so they are
 270         -- available from the command line.
 271         --
 272         -- isExternalName separates the user-defined top-level names from those
 273         -- introduced by the type checker.
 274     is_exported :: Name -> Bool
 275     is_exported | target == HscInterpreted = isExternalName
 276                 | otherwise                = (`elemNameSet` exports)
 277
 278 ppr_ds_rules [] = empty
 279 ppr_ds_rules rules
 280   = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
 281     pprRules rules
 282 \end{code}
 283
 284
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 %*              Desugaring transformation rules
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
 294 dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs))
 295   = putSrcSpanDs loc $
 296     do  { let bndrs = [var | RuleBndr (L _ var) <- vars]
 297         ; lhs'  <- dsLExpr lhs
 298         ; rhs'  <- dsLExpr rhs
 299
 300         ; case decomposeRuleLhs (occurAnalyseExpr lhs') of {
 301                 Nothing -> do { warnDs msg; return Nothing } ;
 302                 Just (fn_id, args) -> do
 303
 304         -- Substitute the dict bindings eagerly,
 305         -- and take the body apart into a (f args) form
 306         { let local_rule = isLocalId fn_id
 307                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 308                 -- we don't want to attach rules to the bindings of implicit Ids,
 309                 -- because they don't show up in the bindings until just before code gen
 310               fn_name   = idName fn_id
 311
 312               rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
 313                             ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
 314                             ru_rough = roughTopNames args,
 315                             ru_local = local_rule }
 316         ; return (Just rule)
 317         } } }
 318   where
 319     msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
 320              2 (ppr lhs)
 321 \end{code}