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 IfaceEnv
  18 import Id
  19 import IOEnv
  20 import Pair
  21 import Name
  22 import FastString
  23 import CoreSyn
  24 import CoreSubst
  25 import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
  26 import PprCore
  27 import DsMonad
  28 import DsExpr
  29 import DsBinds
  30 import DsForeign
  31 import DsExpr           ()      -- Forces DsExpr to be compiled; DsBinds only
  32                                 -- depends on DsExpr.hi-boot.
  33 import Module
  34 import RdrName
  35 import NameSet
  36 import NameEnv
  37 import Rules
  38 import CoreMonad        ( endPass, CoreToDo(..), CoreM, runCoreM, lookupOrigCoreM )
  39 import TyCon
  40 import ErrUtils
  41 import Outputable
  42 import SrcLoc
  43 import Coverage
  44 import Util
  45 import MonadUtils
  46 import OrdList
  47 import Data.List
  48 import Data.IORef
  49 import PrelNames
  50 import UniqSupply
  51 import UniqFM
  52 import CoreFVs
  53 import Type
  54 import Coercion
  55 \end{code}
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 %*              The main function: deSugar
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 \begin{code}
  64
  65 -- | Main entry point to the desugarer.
  66 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  67 -- Can modify PCS by faulting in more declarations
  68
  69 deSugar hsc_env
  70         mod_loc
  71         tcg_env@(TcGblEnv { tcg_mod          = mod,
  72                             tcg_src          = hsc_src,
  73                             tcg_type_env     = type_env,
  74                             tcg_imports      = imports,
  75                             tcg_exports      = exports,
  76                             tcg_keep         = keep_var,
  77                             tcg_rdr_env      = rdr_env,
  78                             tcg_fix_env      = fix_env,
  79                             tcg_inst_env     = inst_env,
  80                             tcg_fam_inst_env = fam_inst_env,
  81                             tcg_warns        = warns,
  82                             tcg_anns         = anns,
  83                             tcg_binds        = binds,
  84                             tcg_imp_specs    = imp_specs,
  85                             tcg_ev_binds     = ev_binds,
  86                             tcg_fords        = fords,
  87                             tcg_rules        = rules,
  88                             tcg_vects        = vects,
  89                             tcg_insts        = insts,
  90                             tcg_fam_insts    = fam_insts,
  91                             tcg_hpc          = other_hpc_info })
  92
  93   = do  { let dflags = hsc_dflags hsc_env
  94         ; showPass dflags "Desugar"
  95
  96         -- Desugar the program
  97         ; let export_set = availsToNameSet exports
  98         ; let auto_scc = mkAutoScc dflags mod export_set
  99         ; let target = hscTarget dflags
 100         ; let hpcInfo = emptyHpcInfo other_hpc_info
 101         ; (msgs, mb_res)
 102               <- case target of
 103                    HscNothing ->
 104                        return (emptyMessages,
 105                                Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
 106                    _        -> do
 107                      (binds_cvr,ds_hpc_info, modBreaks)
 108                          <- if (opt_Hpc
 109                                   || target == HscInterpreted)
 110                                && (not (isHsBoot hsc_src))
 111                               then addCoverageTicksToBinds dflags mod mod_loc
 112                                                            (typeEnvTyCons type_env) binds
 113                               else return (binds, hpcInfo, emptyModBreaks)
 114
 115                      initDs hsc_env mod rdr_env type_env $ do
 116                        do { ds_ev_binds <- dsEvBinds ev_binds
 117                           ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
 118                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
 119                           ; (ds_fords, foreign_prs) <- dsForeigns fords
 120                           ; ds_rules <- mapMaybeM dsRule rules
 121                           ; ds_vects <- mapM dsVect vects
 122                           ; let hpc_init
 123                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
 124                                   | otherwise = empty
 125                           ; return ( ds_ev_binds
 126                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
 127                                    , spec_rules ++ ds_rules, ds_vects
 128                                    , ds_fords `appendStubC` hpc_init
 129                                    , ds_hpc_info, modBreaks)
 130                                    }
 131
 132         ; case mb_res of {
 133            Nothing -> return (msgs, Nothing) ;
 134            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
 135
 136         {       -- Add export flags to bindings
 137           keep_alive <- readIORef keep_var
 138         ; let (rules_for_locals, rules_for_imps)
 139                    = partition isLocalRule all_rules
 140               final_prs = addExportFlagsAndRules target
 141                               export_set keep_alive rules_for_locals (fromOL all_prs)
 142
 143               final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
 144                           in if dopt Opt_F_simpleopt_before_flatten dflags
 145                              then comb
 146                              else simplifyBinds comb
 147         -- Notice that we put the whole lot in a big Rec, even the foreign binds
 148         -- When compiling PrelFloat, which defines data Float = F# Float#
 149         -- we want F# to be in scope in the foreign marshalling code!
 150         -- You might think it doesn't matter, but the simplifier brings all top-level
 151         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 152
 153         ; (final_pgm1, rules_for_imps1, ds_vects1) <- if dopt Opt_F_simpleopt_before_flatten dflags
 154                                                       then simpleOptPgm dflags final_pgm rules_for_imps vects0
 155                                                       else return (final_pgm, rules_for_imps, vects0)
 156
 157         ; ds_binds1 <- if dopt Opt_F_coqpass dflags
 158                        then do { us1 <- mkSplitUniqSupply '*'  -- hack
 159                                ; us2 <- mkSplitUniqSupply '~'  -- hack
 160                                ; let do_flatten   = dopt Opt_F_flatten dflags
 161                                ; let do_skolemize = dopt Opt_F_skolemize dflags
 162                                ; let mon = runCoreM hsc_env (mkRuleBase rules_for_imps1) us1 mod
 163                                              $ coqPassCoreToCore do_flatten do_skolemize dsLookupVar dsLookupTyc us2 final_pgm1
 164                                            where
 165                                              dsLookupVar :: String -> String -> CoreM Var
 166                                              dsLookupVar modname varname
 167                                                  = do { name <- lookupOrigCoreM
 168                                                                   (mkBaseModule (fsLit modname))
 169                                                                   (mkOccNameFS varName (fsLit varname))
 170                                                       ; lookupId name
 171                                                       }
 172                                              dsLookupTyc :: String -> String -> CoreM TyCon
 173                                              dsLookupTyc modname tycname
 174                                                  = do { name <- lookupOrigCoreM
 175                                                                   (mkBaseModule (fsLit modname))
 176                                                                   (mkOccNameFS tcName (fsLit tycname))
 177                                                       ; lookupTyCon name
 178                                                       }
 179                                ; (ret,_) <- mon
 180                                ; return ret
 181                                }
 182                        else return final_pgm
 183
 184         ; (ds_binds2, ds_rules_for_imps2, ds_vects2) <- if dopt Opt_F_simpleopt_before_flatten dflags
 185                                                         then return (ds_binds1, rules_for_imps1, ds_vects1)
 186                                                         else simpleOptPgm dflags ds_binds1 rules_for_imps1 ds_vects1
 187                          -- The simpleOptPgm gets rid of type
 188                          -- bindings plus any stupid dead code
 189
 190         ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds1
 191
 192         ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds1)
 193
 194         ; (ds_binds3, ds_rules_for_imps3, ds_vects3)
 195             <- simpleOptPgm dflags ds_binds2 ds_rules_for_imps2 ds_vects2
 196                          -- The simpleOptPgm gets rid of type
 197                          -- bindings plus any stupid dead code
 198
 199         ; endPass dflags CoreDesugar ds_binds3 ds_rules_for_imps3
 200
 201         ; let used_names = mkUsedNames tcg_env
 202         ; deps <- mkDependencies tcg_env
 203
 204         ; let mod_guts = ModGuts {
 205                 mg_module       = mod,
 206                 mg_boot         = isHsBoot hsc_src,
 207                 mg_exports      = exports,
 208                 mg_deps         = deps,
 209                 mg_used_names   = used_names,
 210                 mg_dir_imps     = imp_mods imports,
 211                 mg_rdr_env      = rdr_env,
 212                 mg_fix_env      = fix_env,
 213                 mg_warns        = warns,
 214                 mg_anns         = anns,
 215                 mg_types        = type_env,
 216                 mg_insts        = insts,
 217                 mg_fam_insts    = fam_insts,
 218                 mg_inst_env     = inst_env,
 219                 mg_fam_inst_env = fam_inst_env,
 220                 mg_rules        = ds_rules_for_imps3,
 221                 mg_binds        = ds_binds3,
 222                 mg_foreign      = ds_fords,
 223                 mg_hpc_info     = ds_hpc_info,
 224                 mg_modBreaks    = modBreaks,
 225                 mg_vect_decls   = ds_vects2,
 226                 mg_vect_info    = noVectInfo
 227               }
 228         ; return (msgs, Just mod_guts)
 229         }}}
 230
 231 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
 232 dsImpSpecs imp_specs
 233  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
 234       ; let (spec_binds, spec_rules) = unzip spec_prs
 235       ; return (concatOL spec_binds, spec_rules) }
 236
 237 combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
 238 -- Top-level bindings can include coercion bindings, but not via superclasses
 239 -- See Note [Top-level evidence]
 240 combineEvBinds [] val_prs
 241   = [Rec val_prs]
 242 combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
 243   | isId b    = combineEvBinds bs ((b,r):val_prs)
 244   | otherwise = NonRec b r : combineEvBinds bs val_prs
 245 combineEvBinds (LetEvBind (Rec prs) : bs) val_prs
 246   = combineEvBinds bs (prs ++ val_prs)
 247 combineEvBinds (CaseEvBind x _ _ : _) _
 248   = pprPanic "topEvBindPairs" (ppr x)
 249 \end{code}
 250
 251 Note [Top-level evidence]
 252 ~~~~~~~~~~~~~~~~~~~~~~~~~
 253 Top-level evidence bindings may be mutually recursive with the top-level value
 254 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
 255 because the occurrence analyser doesn't teke account of type/coercion variables
 256 when computing dependencies.
 257
 258 So we pull out the type/coercion variables (which are in dependency order),
 259 and Rec the rest.
 260
 261
 262 \begin{code}
 263 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 264 mkAutoScc dflags mod exports
 265   | not opt_SccProfilingOn      -- No profiling
 266   = NoSccs
 267     -- Add auto-scc on all top-level things
 268   | dopt Opt_AutoSccsOnAllToplevs dflags
 269   = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id)
 270     -- See #1641.  This is pretty yucky, but I can't see a better way
 271     -- to identify compiler-generated Ids, and at least this should
 272     -- catch them all.
 273     -- Only on exported things
 274   | dopt Opt_AutoSccsOnExportedToplevs dflags
 275   = AddSccs mod (\id -> idName id `elemNameSet` exports)
 276   | otherwise
 277   = NoSccs
 278
 279 deSugarExpr :: HscEnv
 280             -> Module -> GlobalRdrEnv -> TypeEnv
 281             -> LHsExpr Id
 282             -> IO (Messages, Maybe CoreExpr)
 283 -- Prints its own errors; returns Nothing if error occurred
 284
 285 deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
 286     let dflags = hsc_dflags hsc_env
 287     showPass dflags "Desugar"
 288
 289     -- Do desugaring
 290     (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
 291                                    dsLExpr tc_expr
 292
 293     case mb_core_expr of
 294       Nothing   -> return (msgs, Nothing)
 295       Just expr -> do
 296
 297         -- Dump output
 298         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 299
 300         return (msgs, Just expr)
 301 \end{code}
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 %*              Add rules and export flags to binders
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 \begin{code}
 310 addExportFlagsAndRules
 311     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
 312     -> [(Id, t)] -> [(Id, t)]
 313 addExportFlagsAndRules target exports keep_alive rules prs
 314   = mapFst add_one prs
 315   where
 316     add_one bndr = add_rules name (add_export name bndr)
 317        where
 318          name = idName bndr
 319
 320     ---------- Rules --------
 321         -- See Note [Attach rules to local ids]
 322         -- NB: the binder might have some existing rules,
 323         -- arising from specialisation pragmas
 324     add_rules name bndr
 325         | Just rules <- lookupNameEnv rule_base name
 326         = bndr `addIdSpecialisations` rules
 327         | otherwise
 328         = bndr
 329     rule_base = extendRuleBaseList emptyRuleBase rules
 330
 331     ---------- Export flag --------
 332     -- See Note [Adding export flags]
 333     add_export name bndr
 334         | dont_discard name = setIdExported bndr
 335         | otherwise         = bndr
 336
 337     dont_discard :: Name -> Bool
 338     dont_discard name = is_exported name
 339                      || name `elemNameSet` keep_alive
 340
 341         -- In interactive mode, we don't want to discard any top-level
 342         -- entities at all (eg. do not inline them away during
 343         -- simplification), and retain them all in the TypeEnv so they are
 344         -- available from the command line.
 345         --
 346         -- isExternalName separates the user-defined top-level names from those
 347         -- introduced by the type checker.
 348     is_exported :: Name -> Bool
 349     is_exported | target == HscInterpreted = isExternalName
 350                 | otherwise                = (`elemNameSet` exports)
 351 \end{code}
 352
 353
 354 Note [Adding export flags]
 355 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 356 Set the no-discard flag if either
 357         a) the Id is exported
 358         b) it's mentioned in the RHS of an orphan rule
 359         c) it's in the keep-alive set
 360
 361 It means that the binding won't be discarded EVEN if the binding
 362 ends up being trivial (v = w) -- the simplifier would usually just
 363 substitute w for v throughout, but we don't apply the substitution to
 364 the rules (maybe we should?), so this substitution would make the rule
 365 bogus.
 366
 367 You might wonder why exported Ids aren't already marked as such;
 368 it's just because the type checker is rather busy already and
 369 I didn't want to pass in yet another mapping.
 370
 371 Note [Attach rules to local ids]
 372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 373 Find the rules for locally-defined Ids; then we can attach them
 374 to the binders in the top-level bindings
 375
 376 Reason
 377   - It makes the rules easier to look up
 378   - It means that transformation rules and specialisations for
 379     locally defined Ids are handled uniformly
 380   - It keeps alive things that are referred to only from a rule
 381     (the occurrence analyser knows about rules attached to Ids)
 382   - It makes sure that, when we apply a rule, the free vars
 383     of the RHS are more likely to be in scope
 384   - The imported rules are carried in the in-scope set
 385     which is extended on each iteration by the new wave of
 386     local binders; any rules which aren't on the binding will
 387     thereby get dropped
 388
 389
 390 %************************************************************************
 391 %*                                                                      *
 392 %*              Desugaring transformation rules
 393 %*                                                                      *
 394 %************************************************************************
 395
 396 \begin{code}
 397 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
 398 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
 399   = putSrcSpanDs loc $
 400     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 401
 402         ; lhs' <- unsetOptM Opt_EnableRewriteRules $
 403                   unsetOptM Opt_WarnIdentities $
 404                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 405
 406         ; rhs' <- dsLExpr rhs
 407
 408         -- Substitute the dict bindings eagerly,
 409         -- and take the body apart into a (f args) form
 410         ; case decomposeRuleLhs bndrs' lhs' of {
 411                 Left msg -> do { warnDs msg; return Nothing } ;
 412                 Right (final_bndrs, fn_id, args) -> do
 413
 414         { let is_local = isLocalId fn_id
 415                 -- NB: isLocalId is False of implicit Ids.  This is good becuase
 416                 -- we don't want to attach rules to the bindings of implicit Ids,
 417                 -- because they don't show up in the bindings until just before code gen
 418               fn_name   = idName fn_id
 419               final_rhs = simpleOptExpr rhs'    -- De-crap it
 420               rule      = mkRule False {- Not auto -} is_local
 421                                  name act fn_name final_bndrs args final_rhs
 422         ; return (Just rule)
 423         } } }
 424 \end{code}
 425
 426 Note [Desugaring RULE left hand sides]
 427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 428 For the LHS of a RULE we do *not* want to desugar
 429     [x]   to    build (\cn. x `c` n)
 430 We want to leave explicit lists simply as chains
 431 of cons's. We can achieve that slightly indirectly by
 432 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 433
 434 That keeps the desugaring of list comprehensions simple too.
 435
 436
 437
 438 Nor do we want to warn of conversion identities on the LHS;
 439 the rule is precisly to optimise them:
 440   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
 441
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 %*              Desugaring vectorisation declarations
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 dsVect :: LVectDecl Id -> DsM CoreVect
 451 dsVect (L loc (HsVect (L _ v) rhs))
 452   = putSrcSpanDs loc $
 453     do { rhs' <- fmapMaybeM dsLExpr rhs
 454        ; return $ Vect v rhs'
 455            }
 456 dsVect (L _loc (HsNoVect (L _ v)))
 457   = return $ NoVect v
 458 \end{code}
 459
 460
 461
 462 \begin{code}
 463 --
 464 -- Simplification routines run before the flattener.  We can't use
 465 -- simpleOptPgm -- it doesn't preserve the order of subexpressions or
 466 -- let-binding groups.
 467 --
 468 simplify :: Expr CoreBndr -> Expr CoreBndr
 469 simplify (Var v)                 = Var v
 470 simplify (App e1 e2)             = App (simplify e1) (simplify e2)
 471 simplify (Lit lit)               = Lit lit
 472 simplify (Note note e)           = Note note (simplify e)
 473 simplify (Cast e co)             = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
 474                                        then simplify e
 475                                        else Cast (simplify e) co
 476 simplify (Lam v e)               = Lam v (simplify e)
 477 simplify (Case e b ty as)        = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
 478 simplify (Let bind body)         = foldr Let (simplify body) (simplifyBind bind)
 479 simplify (Type t)                = Type t
 480 simplify (Coercion co)           = Coercion co
 481
 482 simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
 483 simplifyBind (NonRec b e)             = [NonRec b (simplify e)]
 484 simplifyBind (Rec [])                 = []
 485 simplifyBind (Rec (rbs@((b,e):rbs'))) =
 486     if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
 487     then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
 488     else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
 489
 490 simplifyBinds = concatMap simplifyBind
 491 \end{code}