    {-
    (c) The University of Glasgow, 1994-2006

    Add implicit bindings
    -}

    module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where

    import GHC.Prelude

    import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) )

    import GHC.Unit( ModLocation(..) )

    import GHC.Core
    import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId )
    import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe )
    import GHC.Core.Class( classAllSelIds )

    import GHC.Types.Name
    import GHC.Types.Tickish( GenTickish( SourceNote ) )
    import GHC.Types.Id( dataConWrapUnfolding_maybe )
    import GHC.Types.Id.Make( mkDictSelRhs )
    import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )

    import GHC.Utils.Outputable
    import GHC.Data.FastString

    {- *********************************************************************
    *                                                                      *
            Implicit bindings
    *                                                                      *
    ********************************************************************* -}

    {- Note [Injecting implicit bindings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    `addImplicitBinds` injects the so-called "implicit bindings" generated by
    the TyCons of the module. Specifically:

     * Data constructor wrappers
     * Data constructor workers: see Note [Data constructor workers]
     * Class op selectors: we want curriedn versions of these too

    Note that /record selector/ are injected much earlier, at the beginning
    of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils.

    At one time I tried injecting the implicit bindings *early*, at the
    beginning of SimplCore.  But that gave rise to real difficulty,
    because GlobalIds are supposed to have *fixed* IdInfo, but the
    simplifier and other core-to-core passes mess with IdInfo all the
    time.  The straw that broke the camels back was when a class selector
    got the wrong arity -- ie the simplifier gave it arity 2, whereas
    importing modules were expecting it to have arity 1 (#2844).
    It's much safer just to inject them right at the end, after tidying.

    Oh: two other reasons for injecting them late:

      - If implicit Ids are already in the bindings when we start tidying,
        we'd have to be careful not to treat them as external Ids (in
        the sense of chooseExternalIds); else the Ids mentioned in *their*
        RHSs will be treated as external and you get an interface file
        saying      a18 = <blah>
        but nothing referring to a18 (because the implicit Id is the
        one that does, and implicit Ids don't appear in interface files).

      - More seriously, the tidied type-envt will include the implicit
        Id replete with a18 in its unfolding; but we won't take account
        of a18 when computing a fingerprint for the class; result chaos.

    Note [Data constructor workers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Create any necessary "implicit" bindings for data con workers.  We
    create the rather strange (non-recursive!) binding

            $wC = \x y -> $wC x y

    i.e. a curried constructor that allocates.  This means that we can
    treat the worker for a constructor like any other function in the rest
    of the compiler.  The point here is that CoreToStg will generate a
    StgConApp for the RHS, rather than a call to the worker (which would
    give a loop).  As Lennart says: the ice is thin here, but it works.

    Hmm.  Should we create bindings for dictionary constructors?  They are
    always fully applied, and the bindings are just there to support
    partial applications. But it's easier to let them through.
    -}

    addImplicitBinds :: CorePrepPgmConfig -> ModLocation
                     -> [TyCon] -> CoreProgram -> IO CoreProgram
    addImplicitBinds :: CorePrepPgmConfig
    -> ModLocation -> [TyCon] -> CoreProgram -> IO CoreProgram
    addImplicitBinds CorePrepPgmConfig
    pgm_cfg ModLocation
    mod_loc [TyCon]
    tycons CoreProgram
    binds
      = CoreProgram -> IO CoreProgram
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CoreProgram
    implicit_binds CoreProgram -> CoreProgram -> CoreProgram
    forall a. [a] -> [a] -> [a]
    ++ CoreProgram
    binds)
      where
        gen_debug_info :: Bool
    gen_debug_info = CorePrepPgmConfig -> Bool
    cpPgm_generateDebugInfo CorePrepPgmConfig
    pgm_cfg
        implicit_binds :: CoreProgram
    implicit_binds = (TyCon -> CoreProgram) -> [TyCon] -> CoreProgram
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Bool -> ModLocation -> TyCon -> CoreProgram
    mkImplicitBinds Bool
    gen_debug_info ModLocation
    mod_loc) [TyCon]
    tycons

    mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind]
    -- See Note [Data constructor workers]
    -- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
    mkImplicitBinds :: Bool -> ModLocation -> TyCon -> CoreProgram
    mkImplicitBinds Bool
    gen_debug_info ModLocation
    mod_loc TyCon
    tycon
      = CoreProgram
    classop_binds CoreProgram -> CoreProgram -> CoreProgram
    forall a. [a] -> [a] -> [a]
    ++ CoreProgram
    datacon_binds
      where
        datacon_binds :: CoreProgram
    datacon_binds
          | TyCon -> Bool
    isBoxedDataTyCon TyCon
    tycon
          = (DataCon -> CoreProgram) -> [DataCon] -> CoreProgram
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Bool -> ModLocation -> DataCon -> CoreProgram
    dataConBinds Bool
    gen_debug_info ModLocation
    mod_loc) (TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon)
          | Bool
    otherwise
          = []
          -- The 'otherwise' includes family TyCons of course, but also (less obviously)
          --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
          --  * type data: we don't want any code for type-only stuff (#24620)

        classop_binds :: CoreProgram
    classop_binds
          | Just Class
    cls <- TyCon -> Maybe Class
    tyConClass_maybe TyCon
    tycon
          = [ Id -> Expr Id -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec Id
    op (Class -> Int -> Expr Id
    mkDictSelRhs Class
    cls Int
    val_index)
            | (Id
    op, Int
    val_index) <- Class -> [Id]
    classAllSelIds Class
    cls [Id] -> [Int] -> [(Id, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    `zip` [Int
    0..] ]
         | Bool
    otherwise
         = []

    dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind]
    dataConBinds :: Bool -> ModLocation -> DataCon -> CoreProgram
    dataConBinds Bool
    gen_debug_info ModLocation
    mod_loc DataCon
    data_con
      = CoreProgram
    wrapper_bind CoreProgram -> CoreProgram -> CoreProgram
    forall a. [a] -> [a] -> [a]
    ++ CoreProgram
    worker_bind
      where
        work_id :: Id
    work_id = DataCon -> Id
    dataConWorkId DataCon
    data_con
        wrap_id :: Id
    wrap_id = DataCon -> Id
    dataConWrapId DataCon
    data_con
        worker_bind :: CoreProgram
    worker_bind  = [Id -> Expr Id -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec Id
    work_id (Expr Id -> Expr Id
    add_tick (Id -> Expr Id
    forall b. Id -> Expr b
    Var Id
    work_id))]
          -- worker_bind: the ice is thin here, but it works:
          --              CorePrep will eta-expand it
        wrapper_bind :: CoreProgram
    wrapper_bind = case Id -> Maybe (Expr Id)
    dataConWrapUnfolding_maybe Id
    wrap_id of
                         Maybe (Expr Id)
    Nothing  -> []
                         Just Expr Id
    rhs -> [Id -> Expr Id -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec Id
    wrap_id Expr Id
    rhs]
        add_tick :: Expr Id -> Expr Id
    add_tick = Bool -> ModLocation -> Name -> Expr Id -> Expr Id
    tick_it Bool
    gen_debug_info ModLocation
    mod_loc (DataCon -> Name
    forall a. NamedThing a => a -> Name
    getName DataCon
    data_con)

    tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr
    -- If we want to generate debug info, we put a source note on the
    -- worker. This is useful, especially for heap profiling.
    tick_it :: Bool -> ModLocation -> Name -> Expr Id -> Expr Id
    tick_it Bool
    generate_debug_info ModLocation
    mod_loc Name
    name
      | Bool -> Bool
    not Bool
    generate_debug_info               = Expr Id -> Expr Id
    forall a. a -> a
    id
      | RealSrcSpan RealSrcSpan
    span Maybe BufSpan
    _ <- Name -> SrcSpan
    nameSrcSpan Name
    name = RealSrcSpan -> Expr Id -> Expr Id
    tick RealSrcSpan
    span
      | Just FilePath
    file <- ModLocation -> Maybe FilePath
    ml_hs_file ModLocation
    mod_loc       = RealSrcSpan -> Expr Id -> Expr Id
    tick (FilePath -> RealSrcSpan
    span1 FilePath
    file)
      | Bool
    otherwise                             = RealSrcSpan -> Expr Id -> Expr Id
    tick (FilePath -> RealSrcSpan
    span1 FilePath
    "???")
      where
        tick :: RealSrcSpan -> Expr Id -> Expr Id
    tick RealSrcSpan
    span  = CoreTickish -> Expr Id -> Expr Id
    forall b. CoreTickish -> Expr b -> Expr b
    Tick (CoreTickish -> Expr Id -> Expr Id)
    -> CoreTickish -> Expr Id -> Expr Id
    forall a b. (a -> b) -> a -> b
    $ RealSrcSpan -> LexicalFastString -> CoreTickish
    forall (pass :: TickishPass).
    RealSrcSpan -> LexicalFastString -> GenTickish pass
    SourceNote RealSrcSpan
    span (LexicalFastString -> CoreTickish)
    -> LexicalFastString -> CoreTickish
    forall a b. (a -> b) -> a -> b
    $
                     FastString -> LexicalFastString
    LexicalFastString (FastString -> LexicalFastString)
    -> FastString -> LexicalFastString
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FastString
    mkFastString (FilePath -> FastString) -> FilePath -> FastString
    forall a b. (a -> b) -> a -> b
    $
                     SDocContext -> SDoc -> FilePath
    renderWithContext SDocContext
    defaultSDocContext (SDoc -> FilePath) -> SDoc -> FilePath
    forall a b. (a -> b) -> a -> b
    $ Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name
        span1 :: FilePath -> RealSrcSpan
    span1 FilePath
    file = RealSrcLoc -> RealSrcSpan
    realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
    forall a b. (a -> b) -> a -> b
    $ FastString -> Int -> Int -> RealSrcLoc
    mkRealSrcLoc (FilePath -> FastString
    mkFastString FilePath
    file) Int
    1 Int
    1