never executed always true always false
    1 
    2 {-# LANGUAGE FlexibleContexts #-}
    3 {-# LANGUAGE TypeFamilies #-}
    4 
    5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    6 
    7 {-
    8 (c) The University of Glasgow 2006
    9 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   10 
   11 
   12 Pattern-matching bindings (HsBinds and MonoBinds)
   13 
   14 Handles @HsBinds@; those at the top level require different handling,
   15 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
   16 lower levels it is preserved with @let@/@letrec@s).
   17 -}
   18 
   19 module GHC.HsToCore.Binds
   20    ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
   21    , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
   22    )
   23 where
   24 
   25 import GHC.Prelude
   26 
   27 import GHC.Driver.Session
   28 import GHC.Driver.Ppr
   29 import GHC.Driver.Config
   30 import qualified GHC.LanguageExtensions as LangExt
   31 import GHC.Unit.Module
   32 
   33 import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )
   34 import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )
   35 
   36 import GHC.HsToCore.Monad
   37 import GHC.HsToCore.Errors.Types
   38 import GHC.HsToCore.GuardedRHSs
   39 import GHC.HsToCore.Utils
   40 import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
   41 
   42 import GHC.Hs             -- lots of things
   43 import GHC.Core           -- lots of things
   44 import GHC.Core.SimpleOpt    ( simpleOptExpr )
   45 import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
   46 import GHC.Core.Make
   47 import GHC.Core.Utils
   48 import GHC.Core.Opt.Arity     ( etaExpand )
   49 import GHC.Core.Unfold.Make
   50 import GHC.Core.FVs
   51 import GHC.Core.Predicate
   52 import GHC.Core.TyCon
   53 import GHC.Core.Type
   54 import GHC.Core.Coercion
   55 import GHC.Core.Multiplicity
   56 import GHC.Core.Rules
   57 
   58 import GHC.Builtin.Names
   59 import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
   60 
   61 import GHC.Tc.Types.Evidence
   62 
   63 import GHC.Types.Id
   64 import GHC.Types.Name
   65 import GHC.Types.Var.Set
   66 import GHC.Types.Var.Env
   67 import GHC.Types.Var( EvVar )
   68 import GHC.Types.SrcLoc
   69 import GHC.Types.Basic
   70 import GHC.Types.Unique.Set( nonDetEltsUniqSet )
   71 
   72 import GHC.Data.Maybe
   73 import GHC.Data.OrdList
   74 import GHC.Data.Graph.Directed
   75 import GHC.Data.Bag
   76 import GHC.Data.FastString
   77 
   78 import GHC.Utils.Constants (debugIsOn)
   79 import GHC.Utils.Misc
   80 import GHC.Utils.Monad
   81 import GHC.Utils.Outputable
   82 import GHC.Utils.Panic
   83 import GHC.Utils.Panic.Plain
   84 import GHC.Utils.Trace
   85 
   86 import Control.Monad
   87 
   88 {-**********************************************************************
   89 *                                                                      *
   90            Desugaring a MonoBinds
   91 *                                                                      *
   92 **********************************************************************-}
   93 
   94 -- | Desugar top level binds, strict binds are treated like normal
   95 -- binds since there is no good time to force before first usage.
   96 dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
   97 dsTopLHsBinds binds
   98      -- see Note [Strict binds checks]
   99   | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
  100   = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds
  101        ; mapBagM_ (top_level_err StrictBinds)       bang_binds
  102        ; return nilOL }
  103 
  104   | otherwise
  105   = do { (force_vars, prs) <- dsLHsBinds binds
  106        ; when debugIsOn $
  107          do { xstrict <- xoptM LangExt.Strict
  108             ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }
  109               -- with -XStrict, even top-level vars are listed as force vars.
  110 
  111        ; return (toOL prs) }
  112 
  113   where
  114     unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
  115     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
  116 
  117     top_level_err bindsType (L loc bind)
  118       = putSrcSpanDs (locA loc) $
  119         diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
  120 
  121 
  122 -- | Desugar all other kind of bindings, Ids of strict binds are returned to
  123 -- later be forced in the binding group body, see Note [Desugar Strict binds]
  124 dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
  125 dsLHsBinds binds
  126   = do { ds_bs <- mapBagM dsLHsBind binds
  127        ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
  128                          id ([], []) ds_bs) }
  129 
  130 ------------------------
  131 dsLHsBind :: LHsBind GhcTc
  132           -> DsM ([Id], [(Id,CoreExpr)])
  133 dsLHsBind (L loc bind) = do dflags <- getDynFlags
  134                             putSrcSpanDs (locA loc) $ dsHsBind dflags bind
  135 
  136 -- | Desugar a single binding (or group of recursive binds).
  137 dsHsBind :: DynFlags
  138          -> HsBind GhcTc
  139          -> DsM ([Id], [(Id,CoreExpr)])
  140          -- ^ The Ids of strict binds, to be forced in the body of the
  141          -- binding group see Note [Desugar Strict binds] and all
  142          -- bindings and their desugared right hand sides.
  143 
  144 dsHsBind dflags (VarBind { var_id = var
  145                          , var_rhs = expr })
  146   = do  { core_expr <- dsLExpr expr
  147                 -- Dictionary bindings are always VarBinds,
  148                 -- so we only need do this here
  149         ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr
  150               force_var = if xopt LangExt.Strict dflags
  151                           then [id]
  152                           else []
  153         ; return (force_var, [core_bind]) }
  154 
  155 dsHsBind dflags b@(FunBind { fun_id = L loc fun
  156                            , fun_matches = matches
  157                            , fun_ext = co_fn
  158                            , fun_tick = tick })
  159  = do   { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $
  160                           -- FromSource might not be accurate (we don't have any
  161                           -- origin annotations for things in this module), but at
  162                           -- worst we do superfluous calls to the pattern match
  163                           -- oracle.
  164                           -- addTyCs: Add type evidence to the refinement type
  165                           --            predicate of the coverage checker
  166                           -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
  167                           matchWrapper
  168                            (mkPrefixFunRhs (L loc (idName fun)))
  169                            Nothing matches
  170 
  171         ; core_wrap <- dsHsWrapper co_fn
  172         ; let body' = mkOptTickBox tick body
  173               rhs   = core_wrap (mkLams args body')
  174               core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
  175               force_var
  176                   -- Bindings are strict when -XStrict is enabled
  177                 | xopt LangExt.Strict dflags
  178                 , matchGroupArity matches == 0 -- no need to force lambdas
  179                 = [id]
  180                 | isBangedHsBind b
  181                 = [id]
  182                 | otherwise
  183                 = []
  184         ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
  185           --                          , ppr (mg_alts matches)
  186           --                          , ppr args, ppr core_binds, ppr body']) $
  187           return (force_var, [core_binds]) }
  188 
  189 dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
  190                          , pat_ext = ty
  191                          , pat_ticks = (rhs_tick, var_ticks) })
  192   = do  { rhss_nablas <- pmcGRHSs PatBindGuards grhss
  193         ; body_expr <- dsGuarded grhss ty rhss_nablas
  194         ; let body' = mkOptTickBox rhs_tick body_expr
  195               pat'  = decideBangHood dflags pat
  196         ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
  197           -- We silently ignore inline pragmas; no makeCorePair
  198           -- Not so cool, but really doesn't matter
  199         ; let force_var' = if isBangedLPat pat'
  200                            then [force_var]
  201                            else []
  202         ; return (force_var', sel_binds) }
  203 
  204 dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
  205                           , abs_exports = exports
  206                           , abs_ev_binds = ev_binds
  207                           , abs_binds = binds, abs_sig = has_sig })
  208   = do { ds_binds <- addTyCs FromSource (listToBag dicts) $
  209                      dsLHsBinds binds
  210              -- addTyCs: push type constraints deeper
  211              --            for inner pattern match check
  212              -- See Check, Note [Long-distance information]
  213 
  214        ; ds_ev_binds <- dsTcEvBinds_s ev_binds
  215 
  216        -- dsAbsBinds does the hard work
  217        ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
  218 
  219 dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
  220 
  221 -----------------------
  222 dsAbsBinds :: DynFlags
  223            -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
  224            -> [CoreBind]                -- Desugared evidence bindings
  225            -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
  226            -> Bool                      -- Single binding with signature
  227            -> DsM ([Id], [(Id,CoreExpr)])
  228 
  229 dsAbsBinds dflags tyvars dicts exports
  230            ds_ev_binds (force_vars, bind_prs) has_sig
  231 
  232     -- A very important common case: one exported variable
  233     -- Non-recursive bindings come through this way
  234     -- So do self-recursive bindings
  235     --    gbl_id = wrap (/\tvs \dicts. let ev_binds
  236     --                                 letrec bind_prs
  237     --                                 in lcl_id)
  238   | [export] <- exports
  239   , ABE { abe_poly = global_id, abe_mono = local_id
  240         , abe_wrap = wrap, abe_prags = prags } <- export
  241   , Just force_vars' <- case force_vars of
  242                            []                  -> Just []
  243                            [v] | v == local_id -> Just [global_id]
  244                            _                   -> Nothing
  245        -- If there is a variable to force, it's just the
  246        -- single variable we are binding here
  247   = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
  248 
  249        ; let rhs = core_wrap $
  250                    mkLams tyvars $ mkLams dicts $
  251                    mkCoreLets ds_ev_binds $
  252                    body
  253 
  254              body | has_sig
  255                   , [(_, lrhs)] <- bind_prs
  256                   = lrhs
  257                   | otherwise
  258                   = mkLetRec bind_prs (Var local_id)
  259 
  260        ; (spec_binds, rules) <- dsSpecs rhs prags
  261 
  262        ; let global_id' = addIdSpecialisations global_id rules
  263              main_bind  = makeCorePair dflags global_id'
  264                                        (isDefaultMethod prags)
  265                                        (dictArity dicts) rhs
  266 
  267        ; return (force_vars', main_bind : fromOL spec_binds) }
  268 
  269     -- Another common case: no tyvars, no dicts
  270     -- In this case we can have a much simpler desugaring
  271     --    lcl_id{inl-prag} = rhs  -- Auxiliary binds
  272     --    gbl_id = lcl_id |> co   -- Main binds
  273   | null tyvars, null dicts
  274   = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr)
  275              mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
  276                           , abe_wrap = wrap })
  277                      -- No SpecPrags (no dicts)
  278                      -- Can't be a default method (default methods are singletons)
  279                = do { core_wrap <- dsHsWrapper wrap
  280                     ; return ( gbl_id `setInlinePragma` defaultInlinePragma
  281                              , core_wrap (Var lcl_id)) }
  282 
  283        ; main_prs <- mapM mk_main exports
  284        ; return (force_vars, flattenBinds ds_ev_binds
  285                               ++ mk_aux_binds bind_prs ++ main_prs ) }
  286 
  287     -- The general case
  288     -- See Note [Desugaring AbsBinds]
  289   | otherwise
  290   = do { let aux_binds = Rec (mk_aux_binds bind_prs)
  291                 -- Monomorphic recursion possible, hence Rec
  292 
  293              new_force_vars = get_new_force_vars force_vars
  294              locals       = map abe_mono exports
  295              all_locals   = locals ++ new_force_vars
  296              tup_expr     = mkBigCoreVarTup all_locals
  297              tup_ty       = exprType tup_expr
  298        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
  299                             mkCoreLets ds_ev_binds $
  300                             mkLet aux_binds $
  301                             tup_expr
  302 
  303        ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs)
  304 
  305         -- Find corresponding global or make up a new one: sometimes
  306         -- we need to make new export to desugar strict binds, see
  307         -- Note [Desugar Strict binds]
  308        ; (exported_force_vars, extra_exports) <- get_exports force_vars
  309 
  310        ; let mk_bind (ABE { abe_wrap = wrap
  311                           , abe_poly = global
  312                           , abe_mono = local, abe_prags = spec_prags })
  313                           -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds"
  314                 = do { tup_id  <- newSysLocalDs Many tup_ty
  315                      ; core_wrap <- dsHsWrapper wrap
  316                      ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
  317                                  mkTupleSelector all_locals local tup_id $
  318                                  mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
  319                            rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
  320                      ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
  321                      ; let global' = (global `setInlinePragma` defaultInlinePragma)
  322                                              `addIdSpecialisations` rules
  323                            -- Kill the INLINE pragma because it applies to
  324                            -- the user written (local) function.  The global
  325                            -- Id is just the selector.  Hmm.
  326                      ; return ((global', rhs) : fromOL spec_binds) }
  327 
  328        ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
  329 
  330        ; return ( exported_force_vars
  331                 , (poly_tup_id, poly_tup_rhs) :
  332                    concat export_binds_s) }
  333   where
  334     mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
  335     mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
  336                             | (lcl_id, rhs) <- bind_prs
  337                             , let lcl_w_inline = lookupVarEnv inline_env lcl_id
  338                                                  `orElse` lcl_id ]
  339 
  340     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
  341                            -- the inline pragma from the source
  342                            -- The type checker put the inline pragma
  343                            -- on the *global* Id, so we need to transfer it
  344     inline_env
  345       = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
  346                  | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
  347                  , let prag = idInlinePragma gbl_id ]
  348 
  349     global_env :: IdEnv Id -- Maps local Id to its global exported Id
  350     global_env =
  351       mkVarEnv [ (local, global)
  352                | ABE { abe_mono = local, abe_poly = global } <- exports
  353                ]
  354 
  355     -- find variables that are not exported
  356     get_new_force_vars lcls =
  357       foldr (\lcl acc -> case lookupVarEnv global_env lcl of
  358                            Just _ -> acc
  359                            Nothing -> lcl:acc)
  360             [] lcls
  361 
  362     -- find exports or make up new exports for force variables
  363     get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
  364     get_exports lcls =
  365       foldM (\(glbls, exports) lcl ->
  366               case lookupVarEnv global_env lcl of
  367                 Just glbl -> return (glbl:glbls, exports)
  368                 Nothing   -> do export <- mk_export lcl
  369                                 let glbl = abe_poly export
  370                                 return (glbl:glbls, export:exports))
  371             ([],[]) lcls
  372 
  373     mk_export local =
  374       do global <- newSysLocalDs Many
  375                      (exprType (mkLams tyvars (mkLams dicts (Var local))))
  376          return (ABE { abe_ext   = noExtField
  377                      , abe_poly  = global
  378                      , abe_mono  = local
  379                      , abe_wrap  = WpHole
  380                      , abe_prags = SpecPrags [] })
  381 
  382 -- | This is where we apply INLINE and INLINABLE pragmas. All we need to
  383 -- do is to attach the unfolding information to the Id.
  384 --
  385 -- Other decisions about whether to inline are made in
  386 -- `calcUnfoldingGuidance` but the decision about whether to then expose
  387 -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
  388 -- using this information.
  389 ------------------------
  390 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
  391              -> (Id, CoreExpr)
  392 makeCorePair dflags gbl_id is_default_method dict_arity rhs
  393   | is_default_method    -- Default methods are *always* inlined
  394                          -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
  395   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding simpl_opts rhs, rhs)
  396 
  397   | otherwise
  398   = case inlinePragmaSpec inline_prag of
  399           NoUserInlinePrag -> (gbl_id, rhs)
  400           NoInline  {}     -> (gbl_id, rhs)
  401           Inlinable {}     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
  402           Inline    {}     -> inline_pair
  403   where
  404     simpl_opts    = initSimpleOpts dflags
  405     inline_prag   = idInlinePragma gbl_id
  406     inlinable_unf = mkInlinableUnfolding simpl_opts rhs
  407     inline_pair
  408        | Just arity <- inlinePragmaSat inline_prag
  409         -- Add an Unfolding for an INLINE (but not for NOINLINE)
  410         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
  411        , let real_arity = dict_arity + arity
  412         -- NB: The arity in the InlineRule takes account of the dictionaries
  413        = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs
  414          , etaExpand real_arity rhs)
  415 
  416        | otherwise
  417        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
  418          (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts rhs, rhs)
  419 
  420 dictArity :: [Var] -> Arity
  421 -- Don't count coercion variables in arity
  422 dictArity dicts = count isId dicts
  423 
  424 {-
  425 Note [Desugaring AbsBinds]
  426 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  427 In the general AbsBinds case we desugar the binding to this:
  428 
  429        tup a (d:Num a) = let fm = ...gm...
  430                              gm = ...fm...
  431                          in (fm,gm)
  432        f a d = case tup a d of { (fm,gm) -> fm }
  433        g a d = case tup a d of { (fm,gm) -> fm }
  434 
  435 Note [Rules and inlining]
  436 ~~~~~~~~~~~~~~~~~~~~~~~~~
  437 Common special case: no type or dictionary abstraction
  438 This is a bit less trivial than you might suppose
  439 The naive way would be to desugar to something like
  440         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
  441         M.f = f_lcl             -- Generated from "exports"
  442 But we don't want that, because if M.f isn't exported,
  443 it'll be inlined unconditionally at every call site (its rhs is
  444 trivial).  That would be ok unless it has RULES, which would
  445 thereby be completely lost.  Bad, bad, bad.
  446 
  447 Instead we want to generate
  448         M.f = ...f_lcl...
  449         f_lcl = M.f
  450 Now all is cool. The RULES are attached to M.f (by SimplCore),
  451 and f_lcl is rapidly inlined away.
  452 
  453 This does not happen in the same way to polymorphic binds,
  454 because they desugar to
  455         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
  456 Although I'm a bit worried about whether full laziness might
  457 float the f_lcl binding out and then inline M.f at its call site
  458 
  459 Note [Specialising in no-dict case]
  460 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  461 Even if there are no tyvars or dicts, we may have specialisation pragmas.
  462 Class methods can generate
  463       AbsBinds [] [] [( ... spec-prag]
  464          { AbsBinds [tvs] [dicts] ...blah }
  465 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
  466 
  467   class  (Real a, Fractional a) => RealFrac a  where
  468     round :: (Integral b) => a -> b
  469 
  470   instance  RealFrac Float  where
  471     {-# SPECIALIZE round :: Float -> Int #-}
  472 
  473 The top-level AbsBinds for $cround has no tyvars or dicts (because the
  474 instance does not).  But the method is locally overloaded!
  475 
  476 Note [Abstracting over tyvars only]
  477 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  478 When abstracting over type variable only (not dictionaries), we don't really need to
  479 built a tuple and select from it, as we do in the general case. Instead we can take
  480 
  481         AbsBinds [a,b] [ ([a,b], fg, fl, _),
  482                          ([b],   gg, gl, _) ]
  483                 { fl = e1
  484                   gl = e2
  485                    h = e3 }
  486 
  487 and desugar it to
  488 
  489         fg = /\ab. let B in e1
  490         gg = /\b. let a = () in let B in S(e2)
  491         h  = /\ab. let B in e3
  492 
  493 where B is the *non-recursive* binding
  494         fl = fg a b
  495         gl = gg b
  496         h  = h a b    -- See (b); note shadowing!
  497 
  498 Notice (a) g has a different number of type variables to f, so we must
  499              use the mkArbitraryType thing to fill in the gaps.
  500              We use a type-let to do that.
  501 
  502          (b) The local variable h isn't in the exports, and rather than
  503              clone a fresh copy we simply replace h by (h a b), where
  504              the two h's have different types!  Shadowing happens here,
  505              which looks confusing but works fine.
  506 
  507          (c) The result is *still* quadratic-sized if there are a lot of
  508              small bindings.  So if there are more than some small
  509              number (10), we filter the binding set B by the free
  510              variables of the particular RHS.  Tiresome.
  511 
  512 Why got to this trouble?  It's a common case, and it removes the
  513 quadratic-sized tuple desugaring.  Less clutter, hopefully faster
  514 compilation, especially in a case where there are a *lot* of
  515 bindings.
  516 
  517 
  518 Note [Eta-expanding INLINE things]
  519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  520 Consider
  521    foo :: Eq a => a -> a
  522    {-# INLINE foo #-}
  523    foo x = ...
  524 
  525 If (foo d) ever gets floated out as a common sub-expression (which can
  526 happen as a result of method sharing), there's a danger that we never
  527 get to do the inlining, which is a Terribly Bad thing given that the
  528 user said "inline"!
  529 
  530 To avoid this we pre-emptively eta-expand the definition, so that foo
  531 has the arity with which it is declared in the source code.  In this
  532 example it has arity 2 (one for the Eq and one for x). Doing this
  533 should mean that (foo d) is a PAP and we don't share it.
  534 
  535 Note [Nested arities]
  536 ~~~~~~~~~~~~~~~~~~~~~
  537 For reasons that are not entirely clear, method bindings come out looking like
  538 this:
  539 
  540   AbsBinds [] [] [$cfromT <= [] fromT]
  541     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
  542     { AbsBinds [] [] [fromT <= [] fromT_1]
  543         fromT :: T Bool -> Bool
  544         { fromT_1 ((TBool b)) = not b } } }
  545 
  546 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
  547 gotten from the binding for fromT_1.
  548 
  549 It might be better to have just one level of AbsBinds, but that requires more
  550 thought!
  551 
  552 
  553 Note [Desugar Strict binds]
  554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  555 See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma
  556 
  557 Desugaring strict variable bindings looks as follows (core below ==>)
  558 
  559   let !x = rhs
  560   in  body
  561 ==>
  562   let x = rhs
  563   in x `seq` body -- seq the variable
  564 
  565 and if it is a pattern binding the desugaring looks like
  566 
  567   let !pat = rhs
  568   in body
  569 ==>
  570   let x = rhs -- bind the rhs to a new variable
  571       pat = x
  572   in x `seq` body -- seq the new variable
  573 
  574 if there is no variable in the pattern desugaring looks like
  575 
  576   let False = rhs
  577   in body
  578 ==>
  579   let x = case rhs of {False -> (); _ -> error "Match failed"}
  580   in x `seq` body
  581 
  582 In order to force the Ids in the binding group they are passed around
  583 in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.
  584 
  585 Consider a recursive group like this
  586 
  587   letrec
  588      f : g = rhs[f,g]
  589   in <body>
  590 
  591 Without `Strict`, we get a translation like this:
  592 
  593   let t = /\a. letrec tm = rhs[fm,gm]
  594                       fm = case t of fm:_ -> fm
  595                       gm = case t of _:gm -> gm
  596                 in
  597                 (fm,gm)
  598 
  599   in let f = /\a. case t a of (fm,_) -> fm
  600   in let g = /\a. case t a of (_,gm) -> gm
  601   in <body>
  602 
  603 Here `tm` is the monomorphic binding for `rhs`.
  604 
  605 With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
  606 Alas, `tm` isn't in scope in the `in <body>` part.
  607 
  608 The simplest thing is to return it in the polymorphic
  609 tuple `t`, thus:
  610 
  611   let t = /\a. letrec tm = rhs[fm,gm]
  612                       fm = case t of fm:_ -> fm
  613                       gm = case t of _:gm -> gm
  614                 in
  615                 (tm, fm, gm)
  616 
  617   in let f = /\a. case t a of (_,fm,_) -> fm
  618   in let g = /\a. case t a of (_,_,gm) -> gm
  619   in let tm = /\a. case t a of (tm,_,_) -> tm
  620   in tm `seq` <body>
  621 
  622 
  623 See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
  624 detailed explanation of the desugaring of strict bindings.
  625 
  626 Note [Strict binds checks]
  627 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  628 There are several checks around properly formed strict bindings. They
  629 all link to this Note. These checks must be here in the desugarer because
  630 we cannot know whether or not a type is unlifted until after zonking, due
  631 to representation polymorphism. These checks all used to be handled in the
  632 typechecker in checkStrictBinds (before Jan '17).
  633 
  634 We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
  635 
  636   x :: Char
  637   (# True, x #) = blah
  638 
  639 is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.
  640 
  641 Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.
  642 Define a "strict bind" to be either an unlifted bind or a banged bind.
  643 
  644 The restrictions are:
  645   1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
  646 
  647   2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
  648      unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
  649      surprised by the strictness of an unlifted bind.) Checked in first clause
  650      of GHC.HsToCore.Expr.ds_val_bind.
  651 
  652   3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
  653      variables or constraints.) Checked in first clause
  654      of GHC.HsToCore.Expr.ds_val_bind.
  655 
  656   4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
  657 
  658 -}
  659 
  660 ------------------------
  661 dsSpecs :: CoreExpr     -- Its rhs
  662         -> TcSpecPrags
  663         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
  664                , [CoreRule] )           -- Rules for the Global Ids
  665 -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
  666 dsSpecs _ IsDefaultMethod = return (nilOL, [])
  667 dsSpecs poly_rhs (SpecPrags sps)
  668   = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
  669        ; let (spec_binds_s, rules) = unzip pairs
  670        ; return (concatOL spec_binds_s, rules) }
  671 
  672 dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
  673                                 -- Nothing => RULE is for an imported Id
  674                                 --            rhs is in the Id's unfolding
  675        -> Located TcSpecPrag
  676        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
  677 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
  678   | isJust (isClassOpId_maybe poly_id)
  679   = putSrcSpanDs loc $
  680     do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
  681        ; return Nothing  }  -- There is no point in trying to specialise a class op
  682                             -- Moreover, classops don't (currently) have an inl_sat arity set
  683                             -- (it would be Just 0) and that in turn makes makeCorePair bleat
  684 
  685   | no_act_spec && isNeverActive rule_act
  686   = putSrcSpanDs loc $
  687     do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
  688        ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
  689                             -- See Note [Activation pragmas for SPECIALISE]
  690 
  691   | otherwise
  692   = putSrcSpanDs loc $
  693     do { uniq <- newUnique
  694        ; let poly_name = idName poly_id
  695              spec_occ  = mkSpecOcc (getOccName poly_name)
  696              spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
  697              (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
  698                -- spec_co looks like
  699                --         \spec_bndrs. [] spec_args
  700                -- perhaps with the body of the lambda wrapped in some WpLets
  701                -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
  702 
  703        ; core_app <- dsHsWrapper spec_app
  704 
  705        ; let ds_lhs  = core_app (Var poly_id)
  706              spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
  707        ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
  708          --                         , text "spec_co:" <+> ppr spec_co
  709          --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
  710          dflags <- getDynFlags
  711        ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
  712            Left msg -> do { diagnosticDs msg; return Nothing } ;
  713            Right (rule_bndrs, _fn, rule_lhs_args) -> do
  714 
  715        { this_mod <- getModule
  716        ; let fn_unf    = realIdUnfolding poly_id
  717              simpl_opts = initSimpleOpts dflags
  718              spec_unf   = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
  719              spec_id    = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.
  720                             `setInlinePragma` inl_prag
  721                             `setIdUnfolding`  spec_unf
  722 
  723        ; rule <- dsMkUserRule this_mod is_local_id
  724                         (mkFastString ("SPEC " ++ showPpr dflags poly_name))
  725                         rule_act poly_name
  726                         rule_bndrs rule_lhs_args
  727                         (mkVarApps (Var spec_id) spec_bndrs)
  728 
  729        ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
  730 
  731 -- Commented out: see Note [SPECIALISE on INLINE functions]
  732 --       ; when (isInlinePragma id_inl)
  733 --              (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
  734 --                        <+> quotes (ppr poly_name))
  735 
  736        ; return (Just (unitOL (spec_id, spec_rhs), rule))
  737             -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
  738             --     makeCorePair overwrites the unfolding, which we have
  739             --     just created using specUnfolding
  740        } } }
  741   where
  742     is_local_id = isJust mb_poly_rhs
  743     poly_rhs | Just rhs <-  mb_poly_rhs
  744              = rhs          -- Local Id; this is its rhs
  745              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
  746              = unfolding    -- Imported Id; this is its unfolding
  747                             -- Use realIdUnfolding so we get the unfolding
  748                             -- even when it is a loop breaker.
  749                             -- We want to specialise recursive functions!
  750              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
  751                             -- The type checker has checked that it *has* an unfolding
  752 
  753     id_inl = idInlinePragma poly_id
  754 
  755     -- See Note [Activation pragmas for SPECIALISE]
  756     inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
  757              | not is_local_id  -- See Note [Specialising imported functions]
  758                                  -- in OccurAnal
  759              , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
  760              | otherwise                               = id_inl
  761      -- Get the INLINE pragma from SPECIALISE declaration, or,
  762      -- failing that, from the original Id
  763 
  764     spec_prag_act = inlinePragmaActivation spec_inl
  765 
  766     -- See Note [Activation pragmas for SPECIALISE]
  767     -- no_act_spec is True if the user didn't write an explicit
  768     -- phase specification in the SPECIALISE pragma
  769     no_act_spec = case inlinePragmaSpec spec_inl of
  770                     NoInline _   -> isNeverActive  spec_prag_act
  771                     _            -> isAlwaysActive spec_prag_act
  772     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
  773              | otherwise   = spec_prag_act                   -- Specified by user
  774 
  775 
  776 dsMkUserRule :: Module -> Bool -> RuleName -> Activation
  777        -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
  778 dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
  779     let rule = mkRule this_mod False is_local name act fn bndrs args rhs
  780     when (isOrphan (ru_orphan rule)) $
  781         diagnosticDs (DsOrphanRule rule)
  782     return rule
  783 
  784 {- Note [SPECIALISE on INLINE functions]
  785 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  786 We used to warn that using SPECIALISE for a function marked INLINE
  787 would be a no-op; but it isn't!  Especially with worker/wrapper split
  788 we might have
  789    {-# INLINE f #-}
  790    f :: Ord a => Int -> a -> ...
  791    f d x y = case x of I# x' -> $wf d x' y
  792 
  793 We might want to specialise 'f' so that we in turn specialise '$wf'.
  794 We can't even /name/ '$wf' in the source code, so we can't specialise
  795 it even if we wanted to.  #10721 is a case in point.
  796 
  797 Note [Activation pragmas for SPECIALISE]
  798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  799 From a user SPECIALISE pragma for f, we generate
  800   a) A top-level binding    spec_fn = rhs
  801   b) A RULE                 f dOrd = spec_fn
  802 
  803 We need two pragma-like things:
  804 
  805 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring
  806                            activation on SPEC), unless overridden by SPEC INLINE
  807 
  808 * Activation of RULE: from SPECIALISE pragma (if activation given)
  809                       otherwise from f's inline pragma
  810 
  811 This is not obvious (see #5237)!
  812 
  813 Examples      Rule activation   Inline prag on spec'd fn
  814 ---------------------------------------------------------------------
  815 SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
  816                                   copy f's prag
  817 
  818 NOINLINE f
  819 SPEC [n] f :: ty            [n]   NOINLINE
  820                                   copy f's prag
  821 
  822 NOINLINE [k] f
  823 SPEC [n] f :: ty            [n]   NOINLINE [k]
  824                                   copy f's prag
  825 
  826 INLINE [k] f
  827 SPEC [n] f :: ty            [n]   INLINE [k]
  828                                   copy f's prag
  829 
  830 SPEC INLINE [n] f :: ty     [n]   INLINE [n]
  831                                   (ignore INLINE prag on f,
  832                                   same activation for rule and spec'd fn)
  833 
  834 NOINLINE [k] f
  835 SPEC f :: ty                [n]   INLINE [k]
  836 
  837 
  838 ************************************************************************
  839 *                                                                      *
  840 \subsection{Adding inline pragmas}
  841 *                                                                      *
  842 ************************************************************************
  843 -}
  844 
  845 decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
  846                  -> Either DsMessage ([Var], Id, [CoreExpr])
  847 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
  848 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
  849 -- may add some extra dictionary binders (see Note [Free dictionaries])
  850 --
  851 -- Returns an error message if the LHS isn't of the expected shape
  852 -- Note [Decomposing the left-hand side of a RULE]
  853 decomposeRuleLhs dflags orig_bndrs orig_lhs
  854   | not (null unbound)    -- Check for things unbound on LHS
  855                           -- See Note [Unused spec binders]
  856   = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)
  857   | Var funId <- fun2
  858   , Just con <- isDataConId_maybe funId
  859   = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]
  860   | Just (fn_id, args) <- decompose fun2 args2
  861   , let extra_bndrs = mk_extra_bndrs fn_id args
  862   = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
  863     --                                  , text "orig_lhs:" <+> ppr orig_lhs
  864     --                                  , text "lhs1:"     <+> ppr lhs1
  865     --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
  866     --                                  , text "fn_id:" <+> ppr fn_id
  867     --                                  , text "args:"   <+> ppr args]) $
  868     Right (orig_bndrs ++ extra_bndrs, fn_id, args)
  869 
  870   | otherwise
  871   = Left (DsRuleLhsTooComplicated orig_lhs lhs2)
  872  where
  873    simpl_opts   = initSimpleOpts dflags
  874    lhs1         = drop_dicts orig_lhs
  875    lhs2         = simpleOptExpr simpl_opts lhs1  -- See Note [Simplify rule LHS]
  876    (fun2,args2) = collectArgs lhs2
  877 
  878    lhs_fvs    = exprFreeVars lhs2
  879    unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
  880 
  881    orig_bndr_set = mkVarSet orig_bndrs
  882 
  883         -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
  884         -- and extra dict binders: Note [Free dictionaries in rule LHS]
  885    mk_extra_bndrs fn_id args
  886      = scopedSort unbound_tvs ++ unbound_dicts
  887      where
  888        unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]
  889        unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d)
  890                        | d <- unbound_vars, isDictId d ]
  891        unbound_vars  = [ v | v <- exprsFreeVarsList args
  892                            , not (v `elemVarSet` orig_bndr_set)
  893                            , not (v == fn_id) ]
  894          -- fn_id: do not quantify over the function itself, which may
  895          -- itself be a dictionary (in pathological cases, #10251)
  896 
  897    decompose (Var fn_id) args
  898       | not (fn_id `elemVarSet` orig_bndr_set)
  899       = Just (fn_id, args)
  900 
  901    decompose _ _ = Nothing
  902 
  903    drop_dicts :: CoreExpr -> CoreExpr
  904    drop_dicts e
  905        = wrap_lets needed bnds body
  906      where
  907        needed = orig_bndr_set `minusVarSet` exprFreeVars body
  908        (bnds, body) = split_lets (occurAnalyseExpr e)
  909            -- The occurAnalyseExpr drops dead bindings which is
  910            -- crucial to ensure that every binding is used later;
  911            -- which in turn makes wrap_lets work right
  912 
  913    split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
  914    split_lets (Let (NonRec d r) body)
  915      | isDictId d
  916      = ((d,r):bs, body')
  917      where (bs, body') = split_lets body
  918 
  919     -- handle "unlifted lets" too, needed for "map/coerce"
  920    split_lets (Case r d _ [Alt DEFAULT _ body])
  921      | isCoVar d
  922      = ((d,r):bs, body')
  923      where (bs, body') = split_lets body
  924 
  925    split_lets e = ([], e)
  926 
  927    wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
  928    wrap_lets _ [] body = body
  929    wrap_lets needed ((d, r) : bs) body
  930      | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
  931      | otherwise                         = wrap_lets needed bs body
  932      where
  933        rhs_fvs = exprFreeVars r
  934        needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
  935 
  936 {-
  937 Note [Decomposing the left-hand side of a RULE]
  938 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  939 There are several things going on here.
  940 * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
  941 * simpleOptExpr: see Note [Simplify rule LHS]
  942 * extra_dict_bndrs: see Note [Free dictionaries]
  943 
  944 Note [Free tyvars on rule LHS]
  945 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  946 Consider
  947   data T a = C
  948 
  949   foo :: T a -> Int
  950   foo C = 1
  951 
  952   {-# RULES "myrule"  foo C = 1 #-}
  953 
  954 After type checking the LHS becomes (foo alpha (C alpha)), where alpha
  955 is an unbound meta-tyvar.  The zonker in GHC.Tc.Utils.Zonk is careful not to
  956 turn the free alpha into Any (as it usually does).  Instead it turns it
  957 into a TyVar 'a'.  See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk".
  958 
  959 Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
  960 in the zonker, because the HsExpr data type is very large.  But it's /easy/
  961 to do it here in the desugarer.
  962 
  963 Moreover, we have to do something rather similar for dictionaries;
  964 see Note [Free dictionaries on rule LHS].   So that's why we look for
  965 type variables free on the LHS, and quantify over them.
  966 
  967 Note [Free dictionaries on rule LHS]
  968 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  969 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
  970 which is presumably in scope at the function definition site, we can quantify
  971 over it too.  *Any* dict with that type will do.
  972 
  973 So for example when you have
  974         f :: Eq a => a -> a
  975         f = <rhs>
  976         ... SPECIALISE f :: Int -> Int ...
  977 
  978 Then we get the SpecPrag
  979         SpecPrag (f Int dInt)
  980 
  981 And from that we want the rule
  982 
  983         RULE forall dInt. f Int dInt = f_spec
  984         f_spec = let f = <rhs> in f Int dInt
  985 
  986 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
  987 Name, and you can't bind them in a lambda or forall without getting things
  988 confused.   Likewise it might have an InlineRule or something, which would be
  989 utterly bogus. So we really make a fresh Id, with the same unique and type
  990 as the old one, but with an Internal name and no IdInfo.
  991 
  992 Note [Drop dictionary bindings on rule LHS]
  993 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  994 drop_dicts drops dictionary bindings on the LHS where possible.
  995    E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
  996      --> f d
  997    Reasoning here is that there is only one d:Eq [Int], and so we can
  998    quantify over it. That makes 'd' free in the LHS, but that is later
  999    picked up by extra_dict_bndrs (Note [Dead spec binders]).
 1000 
 1001    NB 1: We can only drop the binding if the RHS doesn't bind
 1002          one of the orig_bndrs, which we assume occur on RHS.
 1003          Example
 1004             f :: (Eq a) => b -> a -> a
 1005             {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
 1006          Here we want to end up with
 1007             RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
 1008          Of course, the ($dfEqlist d) in the pattern makes it less likely
 1009          to match, but there is no other way to get d:Eq a
 1010 
 1011    NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
 1012          the evidence bindings to be wrapped around the outside of the
 1013          LHS.  (After simplOptExpr they'll usually have been inlined.)
 1014          dsHsWrapper does dependency analysis, so that civilised ones
 1015          will be simple NonRec bindings.  We don't handle recursive
 1016          dictionaries!
 1017 
 1018     NB3: In the common case of a non-overloaded, but perhaps-polymorphic
 1019          specialisation, we don't need to bind *any* dictionaries for use
 1020          in the RHS. For example (#8331)
 1021              {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
 1022              useAbstractMonad :: MonadAbstractIOST m => m Int
 1023          Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
 1024          but the RHS uses no dictionaries, so we want to end up with
 1025              RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
 1026                 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
 1027 
 1028    #8848 is a good example of where there are some interesting
 1029    dictionary bindings to discard.
 1030 
 1031 The drop_dicts algorithm is based on these observations:
 1032 
 1033   * Given (let d = rhs in e) where d is a DictId,
 1034     matching 'e' will bind e's free variables.
 1035 
 1036   * So we want to keep the binding if one of the needed variables (for
 1037     which we need a binding) is in fv(rhs) but not already in fv(e).
 1038 
 1039   * The "needed variables" are simply the orig_bndrs.  Consider
 1040        f :: (Eq a, Show b) => a -> b -> String
 1041        ... SPECIALISE f :: (Show b) => Int -> b -> String ...
 1042     Then orig_bndrs includes the *quantified* dictionaries of the type
 1043     namely (dsb::Show b), but not the one for Eq Int
 1044 
 1045 So we work inside out, applying the above criterion at each step.
 1046 
 1047 
 1048 Note [Simplify rule LHS]
 1049 ~~~~~~~~~~~~~~~~~~~~~~~~
 1050 simplOptExpr occurrence-analyses and simplifies the LHS:
 1051 
 1052    (a) Inline any remaining dictionary bindings (which hopefully
 1053        occur just once)
 1054 
 1055    (b) Substitute trivial lets, so that they don't get in the way.
 1056        Note that we substitute the function too; we might
 1057        have this as a LHS:  let f71 = M.f Int in f71
 1058 
 1059    (c) Do eta reduction.  To see why, consider the fold/build rule,
 1060        which without simplification looked like:
 1061           fold k z (build (/\a. g a))  ==>  ...
 1062        This doesn't match unless you do eta reduction on the build argument.
 1063        Similarly for a LHS like
 1064          augment g (build h)
 1065        we do not want to get
 1066          augment (\a. g a) (build h)
 1067        otherwise we don't match when given an argument like
 1068           augment (\a. h a a) (build h)
 1069 
 1070 Note [Unused spec binders]
 1071 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 1072 Consider
 1073         f :: a -> a
 1074         ... SPECIALISE f :: Eq a => a -> a ...
 1075 It's true that this *is* a more specialised type, but the rule
 1076 we get is something like this:
 1077         f_spec d = f
 1078         RULE: f = f_spec d
 1079 Note that the rule is bogus, because it mentions a 'd' that is
 1080 not bound on the LHS!  But it's a silly specialisation anyway, because
 1081 the constraint is unused.  We could bind 'd' to (error "unused")
 1082 but it seems better to reject the program because it's almost certainly
 1083 a mistake.  That's what the isDeadBinder call detects.
 1084 
 1085 Note [No RULES on datacons]
 1086 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1087 
 1088 Previously, `RULES` like
 1089 
 1090     "JustNothing" forall x . Just x = Nothing
 1091 
 1092 were allowed. Simon Peyton Jones says this seems to have been a
 1093 mistake, that such rules have never been supported intentionally,
 1094 and that he doesn't know if they can break in horrible ways.
 1095 Furthermore, Ben Gamari and Reid Barton are considering trying to
 1096 detect the presence of "static data" that the simplifier doesn't
 1097 need to traverse at all. Such rules do not play well with that.
 1098 So for now, we ban them altogether as requested by #13290. See also #7398.
 1099 
 1100 
 1101 ************************************************************************
 1102 *                                                                      *
 1103                 Desugaring evidence
 1104 *                                                                      *
 1105 ************************************************************************
 1106 
 1107 -}
 1108 
 1109 dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 1110 dsHsWrapper WpHole            = return $ \e -> e
 1111 dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)
 1112 dsHsWrapper (WpEvLam ev)      = return $ Lam ev
 1113 dsHsWrapper (WpTyLam tv)      = return $ Lam tv
 1114 dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
 1115                                    ; return (mkCoreLets bs) }
 1116 dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
 1117                                    ; w2 <- dsHsWrapper c2
 1118                                    ; return (w1 . w2) }
 1119  -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what
 1120  -- the specification of this clause is
 1121 dsHsWrapper (WpFun c1 c2 (Scaled w t1))
 1122                               = do { x <- newSysLocalDs w t1
 1123                                    ; w1 <- dsHsWrapper c1
 1124                                    ; w2 <- dsHsWrapper c2
 1125                                    ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
 1126                                          arg     = w1 (Var x)
 1127                                    ; return (\e -> (Lam x (w2 (app e arg)))) }
 1128 dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $
 1129                                 return $ \e -> mkCastDs e co
 1130 dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
 1131                                    ; return (\e -> App e core_tm) }
 1132   -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
 1133 dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $
 1134                                          diagnosticDs DsMultiplicityCoercionsNotSupported
 1135                                      ; return $ \e -> e }
 1136 --------------------------------------
 1137 dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
 1138 dsTcEvBinds_s []       = return []
 1139 dsTcEvBinds_s (b:rest) = assert (null rest) $  -- Zonker ensures null
 1140                          dsTcEvBinds b
 1141 
 1142 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 1143 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
 1144 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 1145 
 1146 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
 1147 dsEvBinds bs
 1148   = do { ds_bs <- mapBagM dsEvBind bs
 1149        ; return (mk_ev_binds ds_bs) }
 1150 
 1151 mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
 1152 -- We do SCC analysis of the evidence bindings, /after/ desugaring
 1153 -- them. This is convenient: it means we can use the GHC.Core
 1154 -- free-variable functions rather than having to do accurate free vars
 1155 -- for EvTerm.
 1156 mk_ev_binds ds_binds
 1157   = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
 1158   where
 1159     edges :: [ Node EvVar (EvVar,CoreExpr) ]
 1160     edges = foldr ((:) . mk_node) [] ds_binds
 1161 
 1162     mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
 1163     mk_node b@(var, rhs)
 1164       = DigraphNode { node_payload = b
 1165                     , node_key = var
 1166                     , node_dependencies = nonDetEltsUniqSet $
 1167                                           exprFreeVars rhs `unionVarSet`
 1168                                           coVarsOfType (varType var) }
 1169       -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
 1170       -- is still deterministic even if the edges are in nondeterministic order
 1171       -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
 1172 
 1173     ds_scc (AcyclicSCC (v,r)) = NonRec v r
 1174     ds_scc (CyclicSCC prs)    = Rec prs
 1175 
 1176 dsEvBind :: EvBind -> DsM (Id, CoreExpr)
 1177 dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
 1178 
 1179 
 1180 {-**********************************************************************
 1181 *                                                                      *
 1182            Desugaring EvTerms
 1183 *                                                                      *
 1184 **********************************************************************-}
 1185 
 1186 dsEvTerm :: EvTerm -> DsM CoreExpr
 1187 dsEvTerm (EvExpr e)          = return e
 1188 dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
 1189 dsEvTerm (EvFun { et_tvs = tvs, et_given = given
 1190                 , et_binds = ev_binds, et_body = wanted_id })
 1191   = do { ds_ev_binds <- dsTcEvBinds ev_binds
 1192        ; return $ (mkLams (tvs ++ given) $
 1193                    mkCoreLets ds_ev_binds $
 1194                    Var wanted_id) }
 1195 
 1196 
 1197 {-**********************************************************************
 1198 *                                                                      *
 1199            Desugaring Typeable dictionaries
 1200 *                                                                      *
 1201 **********************************************************************-}
 1202 
 1203 dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
 1204 -- Return a CoreExpr :: Typeable ty
 1205 -- This code is tightly coupled to the representation
 1206 -- of TypeRep, in base library Data.Typeable.Internal
 1207 dsEvTypeable ty ev
 1208   = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable
 1209        ; let kind = typeKind ty
 1210              Just typeable_data_con
 1211                  = tyConSingleDataCon_maybe tyCl    -- "Data constructor"
 1212                                                     -- for Typeable
 1213 
 1214        ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a
 1215 
 1216        -- Package up the method as `Typeable` dictionary
 1217        ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
 1218 
 1219 type TypeRepExpr = CoreExpr
 1220 
 1221 -- | Returns a @CoreExpr :: TypeRep ty@
 1222 ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
 1223 ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
 1224   = do { mkTrCon <- dsLookupGlobalId mkTrConName
 1225                     -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
 1226        ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
 1227        ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
 1228                     -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
 1229 
 1230        ; tc_rep <- tyConRep tc                      -- :: TyCon
 1231        ; let ks = tyConAppArgs ty
 1232              -- Construct a SomeTypeRep
 1233              toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
 1234              toSomeTypeRep t ev = do
 1235                  rep <- getRep ev t
 1236                  return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
 1237        ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
 1238        ; let -- :: [SomeTypeRep]
 1239              kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
 1240 
 1241          -- Note that we use the kind of the type, not the TyCon from which it
 1242          -- is constructed since the latter may be kind polymorphic whereas the
 1243          -- former we know is not (we checked in the solver).
 1244        ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
 1245                                          , Type ty
 1246                                          , tc_rep
 1247                                          , kind_args ]
 1248        -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
 1249        ; return expr
 1250        }
 1251 
 1252 ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
 1253   | Just (t1,t2) <- splitAppTy_maybe ty
 1254   = do { e1  <- getRep ev1 t1
 1255        ; e2  <- getRep ev2 t2
 1256        ; mkTrApp <- dsLookupGlobalId mkTrAppName
 1257                     -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
 1258                     --            TypeRep a -> TypeRep b -> TypeRep (a b)
 1259        ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,
 1260                                                      -- since it's a kind
 1261        ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
 1262                             [ e1, e2 ]
 1263        -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
 1264        ; return expr
 1265        }
 1266 
 1267 ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)
 1268   | Just (m,t1,t2) <- splitFunTy_maybe ty
 1269   = do { e1 <- getRep ev1 t1
 1270        ; e2 <- getRep ev2 t2
 1271        ; em <- getRep evm m
 1272        ; mkTrFun <- dsLookupGlobalId mkTrFunName
 1273                     -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).
 1274                     --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a # m -> b)
 1275        ; let r1 = getRuntimeRep t1
 1276              r2 = getRuntimeRep t2
 1277        ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
 1278                          [ em, e1, e2 ]
 1279        }
 1280 
 1281 ds_ev_typeable ty (EvTypeableTyLit ev)
 1282   = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact
 1283     do { fun  <- dsLookupGlobalId tr_fun
 1284        ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
 1285        ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
 1286   where
 1287     ty_kind = typeKind ty
 1288 
 1289     -- tr_fun is the Name of
 1290     --       typeNatTypeRep    :: KnownNat    a => TypeRep a
 1291     -- of    typeSymbolTypeRep :: KnownSymbol a => TypeRep a
 1292     tr_fun | ty_kind `eqType` naturalTy      = typeNatTypeRepName
 1293            | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
 1294            | ty_kind `eqType` charTy         = typeCharTypeRepName
 1295            | otherwise = panic "dsEvTypeable: unknown type lit kind"
 1296 
 1297 ds_ev_typeable ty ev
 1298   = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
 1299 
 1300 getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
 1301        -> Type            -- ^ The type @ty@
 1302        -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
 1303                           -- namely @typeRep# dict@
 1304 -- Remember that
 1305 --   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
 1306 getRep ev ty
 1307   = do { typeable_expr <- dsEvTerm ev
 1308        ; typeRepId     <- dsLookupGlobalId typeRepIdName
 1309        ; let ty_args = [typeKind ty, ty]
 1310        ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
 1311 
 1312 tyConRep :: TyCon -> DsM CoreExpr
 1313 -- Returns CoreExpr :: TyCon
 1314 tyConRep tc
 1315   | Just tc_rep_nm <- tyConRepName_maybe tc
 1316   = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
 1317        ; return (Var tc_rep_id) }
 1318   | otherwise
 1319   = pprPanic "tyConRep" (ppr tc)