    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
    --
    --  (c) The University of Glasgow 2002-2006
    --

    -- | Generate infotables for interpreter-made bytecodes
    module GHC.ByteCode.InfoTable ( mkITbls ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session

    import GHC.Platform
    import GHC.Platform.Profile

    import GHC.ByteCode.Types
    import GHC.Runtime.Interpreter

    import GHC.Types.Name       ( Name, getName )
    import GHC.Types.Name.Env
    import GHC.Types.RepType

    import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )
    import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
    import GHC.Core.Multiplicity     ( scaledThing )

    import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
    import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )

    import GHC.Utils.Misc
    import GHC.Utils.Panic

    {-
      Manufacturing of info tables for DataCons
    -}

    -- Make info tables for the data decls in this module
    mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
    mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
    mkITbls Interp
    interp Profile
    profile [TyCon]
    tcs =
      forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr forall a. NameEnv a -> NameEnv a -> NameEnv a
    plusNameEnv forall a. NameEnv a
    emptyNameEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$>
        forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM TyCon -> IO ItblEnv
    mkITbl (forall a. (a -> Bool) -> [a] -> [a]
    filter TyCon -> Bool
    isDataTyCon [TyCon]
    tcs)
     where
      mkITbl :: TyCon -> IO ItblEnv
      mkITbl :: TyCon -> IO ItblEnv
    mkITbl TyCon
    tc
        | [DataCon]
    dcs forall a. [a] -> WordOff -> Bool
    `lengthIs` WordOff
    n -- paranoia; this is an assertion.
        = Interp -> Profile -> [DataCon] -> IO ItblEnv
    make_constr_itbls Interp
    interp Profile
    profile [DataCon]
    dcs
           where
              dcs :: [DataCon]
    dcs = TyCon -> [DataCon]
    tyConDataCons TyCon
    tc
              n :: WordOff
    n   = TyCon -> WordOff
    tyConFamilySize TyCon
    tc
      mkITbl TyCon
    _ = forall a. String -> a
    panic String
    "mkITbl"

    mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
    mkItblEnv :: [(Name, ItblPtr)] -> ItblEnv
    mkItblEnv [(Name, ItblPtr)]
    pairs = forall a. [(Name, a)] -> NameEnv a
    mkNameEnv [(Name
    n, (Name
    n,ItblPtr
    p)) | (Name
    n,ItblPtr
    p) <- [(Name, ItblPtr)]
    pairs]

    -- Assumes constructors are numbered from zero, not one
    make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
    make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv
    make_constr_itbls Interp
    interp Profile
    profile [DataCon]
    cons =
      -- TODO: the profile should be bundled with the interpreter: the rts ways are
      -- fixed for an interpreter
      [(Name, ItblPtr)] -> ItblEnv
    mkItblEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry DataCon -> WordOff -> IO (Name, ItblPtr)
    mk_itbl) (forall a b. [a] -> [b] -> [(a, b)]
    zip [DataCon]
    cons [WordOff
    0..])
     where
      mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
      mk_itbl :: DataCon -> WordOff -> IO (Name, ItblPtr)
    mk_itbl DataCon
    dcon WordOff
    conNo = do
         let rep_args :: [NonVoid PrimRep]
    rep_args = [ forall a. a -> NonVoid a
    NonVoid PrimRep
    prim_rep
                        | Scaled Type
    arg <- DataCon -> [Scaled Type]
    dataConRepArgTys DataCon
    dcon
                        , PrimRep
    prim_rep <- HasDebugCallStack => Type -> [PrimRep]
    typePrimRep (forall a. Scaled a -> a
    scaledThing Scaled Type
    arg) ]

             (WordOff
    tot_wds, WordOff
    ptr_wds) =
                 Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
    mkVirtConstrSizes Profile
    profile [NonVoid PrimRep]
    rep_args

             ptrs' :: WordOff
    ptrs'  = WordOff
    ptr_wds
             nptrs' :: WordOff
    nptrs' = WordOff
    tot_wds forall a. Num a => a -> a -> a
    - WordOff
    ptr_wds
             nptrs_really :: WordOff
    nptrs_really
                | WordOff
    ptrs' forall a. Num a => a -> a -> a
    + WordOff
    nptrs' forall a. Ord a => a -> a -> Bool
    >= PlatformConstants -> WordOff
    pc_MIN_PAYLOAD_SIZE PlatformConstants
    constants = WordOff
    nptrs'
                | Bool
    otherwise = PlatformConstants -> WordOff
    pc_MIN_PAYLOAD_SIZE PlatformConstants
    constants forall a. Num a => a -> a -> a
    - WordOff
    ptrs'

             descr :: ByteString
    descr = DataCon -> ByteString
    dataConIdentity DataCon
    dcon

             platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
             constants :: PlatformConstants
    constants = Platform -> PlatformConstants
    platformConstants Platform
    platform
             tables_next_to_code :: Bool
    tables_next_to_code = Platform -> Bool
    platformTablesNextToCode Platform
    platform

         RemotePtr StgInfoTable
    r <- forall a. Binary a => Interp -> Message a -> IO a
    interpCmd Interp
    interp (Bool
    -> WordOff
    -> WordOff
    -> WordOff
    -> WordOff
    -> ByteString
    -> Message (RemotePtr StgInfoTable)
    MkConInfoTable Bool
    tables_next_to_code WordOff
    ptrs' WordOff
    nptrs_really
                                  WordOff
    conNo (Platform -> DataCon -> WordOff
    tagForCon Platform
    platform DataCon
    dcon) ByteString
    descr)
         forall (m :: * -> *) a. Monad m => a -> m a
    return (forall a. NamedThing a => a -> Name
    getName DataCon
    dcon, RemotePtr StgInfoTable -> ItblPtr
    ItblPtr RemotePtr StgInfoTable
    r)