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

-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
module ByteCodeItbls ( mkITbls ) where

#include "HsVersions.h"

import GhcPrelude

import ByteCodeTypes
import GHCi
import DynFlags
import HscTypes
import Name             ( Name, getName )
import NameEnv
import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import RepType
import StgCmmLayout     ( mkVirtConstrSizes )
import StgCmmClosure    ( tagForCon, NonVoid (..) )
import Util
import Panic

{-
  Manufacturing of info tables for DataCons
-}

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

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

-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
make_constr_itbls hsc_env :: HscEnv
hsc_env cons :: [DataCon]
cons =
  [(Name, ItblPtr)] -> ItblEnv
mkItblEnv ([(Name, ItblPtr)] -> ItblEnv)
-> IO [(Name, ItblPtr)] -> IO ItblEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DataCon, Int) -> IO (Name, ItblPtr))
-> [(DataCon, Int)] -> IO [(Name, ItblPtr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((DataCon -> Int -> IO (Name, ItblPtr))
-> (DataCon, Int) -> IO (Name, ItblPtr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DataCon -> Int -> IO (Name, ItblPtr)
mk_itbl) ([DataCon] -> [Int] -> [(DataCon, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
cons [0..])
 where
  dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
  mk_itbl :: DataCon -> Int -> IO (Name, ItblPtr)
mk_itbl dcon :: DataCon
dcon conNo :: Int
conNo = do
     let rep_args :: [NonVoid PrimRep]
rep_args = [ PrimRep -> NonVoid PrimRep
forall a. a -> NonVoid a
NonVoid PrimRep
prim_rep
                    | Type
arg <- DataCon -> [Type]
dataConRepArgTys DataCon
dcon
                    , PrimRep
prim_rep <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg ]

         (tot_wds :: Int
tot_wds, ptr_wds :: Int
ptr_wds) =
             DynFlags -> [NonVoid PrimRep] -> (Int, Int)
mkVirtConstrSizes DynFlags
dflags [NonVoid PrimRep]
rep_args

         ptrs' :: Int
ptrs'  = Int
ptr_wds
         nptrs' :: Int
nptrs' = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds
         nptrs_really :: Int
nptrs_really
            | Int
ptrs' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nptrs' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= DynFlags -> Int
mIN_PAYLOAD_SIZE DynFlags
dflags = Int
nptrs'
            | Bool
otherwise = DynFlags -> Int
mIN_PAYLOAD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptrs'

         descr :: [Word8]
descr = DataCon -> [Word8]
dataConIdentity DataCon
dcon

     RemotePtr StgInfoTable
r <- HscEnv
-> Message (RemotePtr StgInfoTable) -> IO (RemotePtr StgInfoTable)
forall a. Binary a => HscEnv -> Message a -> IO a
iservCmd HscEnv
hsc_env (Int
-> Int -> Int -> Int -> [Word8] -> Message (RemotePtr StgInfoTable)
MkConInfoTable Int
ptrs' Int
nptrs_really
                              Int
conNo (DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags DataCon
dcon) [Word8]
descr)
     (Name, ItblPtr) -> IO (Name, ItblPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
dcon, RemotePtr StgInfoTable -> ItblPtr
ItblPtr RemotePtr StgInfoTable
r)