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