{-
(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 pgm_cfg mod_loc tycons binds
  = return (implicit_binds ++ binds)
  where
    gen_debug_info = cpPgm_generateDebugInfo pgm_cfg
    implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons


mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind]
-- See Note [Data constructor workers]
-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
mkImplicitBinds gen_debug_info mod_loc tycon
  = classop_binds ++ datacon_binds
  where
    datacon_binds
      | isBoxedDataTyCon tycon
      = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon)
      | 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
      | Just cls <- tyConClass_maybe tycon
      = [ NonRec op (mkDictSelRhs cls val_index)
        | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
     | otherwise
     = []

dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind]
dataConBinds gen_debug_info mod_loc data_con
  = wrapper_bind ++ worker_bind
  where
    work_id = dataConWorkId data_con
    wrap_id = dataConWrapId data_con
    worker_bind  = [NonRec work_id (add_tick (Var work_id))]
      -- worker_bind: the ice is thin here, but it works:
      --              CorePrep will eta-expand it
    wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of
                     Nothing  -> []
                     Just rhs -> [NonRec wrap_id rhs]
    add_tick = tick_it gen_debug_info mod_loc (getName 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 generate_debug_info mod_loc name
  | not generate_debug_info               = id
  | RealSrcSpan span _ <- nameSrcSpan name = tick span
  | Just file <- ml_hs_file mod_loc       = tick (span1 file)
  | otherwise                             = tick (span1 "???")
  where
    tick span  = Tick $ SourceNote span $
                 LexicalFastString $ mkFastString $
                 renderWithContext defaultSDocContext $ ppr name
    span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1