content: {-
  (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
  
  
  
  
  