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