module GHC.StgToJS.Ids
( freshUnique
, freshIdent
, makeIdentForId
, cachedIdentForId
, identForId
, identForIdN
, identsForId
, identForEntryId
, identForDataConEntryId
, identForDataConWorker
, varForId
, varForIdN
, varsForId
, varForEntryId
, varForDataConEntryId
, varForDataConWorker
, declVarsForId
)
where
import GHC.Prelude
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Utils
import GHC.StgToJS.Symbols
import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.Core.DataCon
import GHC.Types.Id
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Data.FastString
import GHC.Data.FastMutInt
import Control.Monad
import Control.Monad.IO.Class
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Map as M
import Data.Maybe
import qualified Data.ByteString.Char8 as BSC
freshUnique :: G Int
freshUnique :: G Int
freshUnique = do
id_gen <- (GenState -> FastMutInt) -> StateT GenState IO FastMutInt
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> FastMutInt
gsId
liftIO $ do
v <- readFastMutInt id_gen
writeFastMutInt id_gen (v+1)
pure v
freshIdent :: G Ident
freshIdent :: G Ident
freshIdent = do
i <- G Int
freshUnique
mod <- State.gets gsModule
let !sym_name = Module -> Int -> FastString
mkFreshJsSymbol Module
mod Int
i
return (name sym_name)
makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId Id
i Maybe Int
num IdType
id_type Module
current_module = FastString -> Ident
name FastString
ident
where
exported :: Bool
exported = Id -> Bool
isExportedId Id
i
name' :: Name
name' = Id -> Name
forall a. NamedThing a => a -> Name
getName Id
i
mod :: Module
mod
| Bool
exported
, Just Module
m <- Name -> Maybe Module
nameModule_maybe Name
name'
= Module
m
| Bool
otherwise
= Module
current_module
!ident :: FastString
ident = ByteString -> FastString
mkFastStringByteString (ByteString -> FastString) -> ByteString -> FastString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
[ Bool -> Module -> FastString -> ByteString
mkJsSymbolBS Bool
exported Module
mod (OccName -> FastString
occNameMangledFS (Name -> OccName
nameOccName Name
name'))
, case Maybe Int
num of
Maybe Int
Nothing -> ByteString
forall a. Monoid a => a
mempty
Just Int
v -> [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [String -> ByteString
BSC.pack String
"_", Int -> ByteString
intBS Int
v]
, case IdType
id_type of
IdType
IdPlain -> ByteString
forall a. Monoid a => a
mempty
IdType
IdEntry -> String -> ByteString
BSC.pack String
"_e"
IdType
IdConEntry -> String -> ByteString
BSC.pack String
"_con_e"
, if Bool
exported
then ByteString
forall a. Monoid a => a
mempty
else let (Char
c,Word64
u) = Unique -> (Char, Word64)
unpkUnique (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
i)
in [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [String -> ByteString
BSC.pack [Char
'_',Char
c,Char
'_'], Word64 -> ByteString
word64BS Word64
u]
]
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
mi IdType
id_type = do
let !key :: IdKey
key = Word64 -> Int -> IdType -> IdKey
IdKey (Unique -> Word64
getKey (Unique -> Word64) -> (Id -> Unique) -> Id -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique (Id -> Word64) -> Id -> Word64
forall a b. (a -> b) -> a -> b
$ Id
i) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
mi) IdType
id_type
IdCache cache <- (GenState -> IdCache) -> StateT GenState IO IdCache
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> IdCache
gsIdents
ident <- case M.lookup key cache of
Just Ident
ident -> Ident -> G Ident
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ident
ident
Maybe Ident
Nothing -> do
mod <- (GenState -> Module) -> StateT GenState IO Module
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets GenState -> Module
gsModule
let !ident = Id -> Maybe Int -> IdType -> Module -> Ident
makeIdentForId Id
i Maybe Int
mi IdType
id_type Module
mod
let !cache' = Map IdKey Ident -> IdCache
IdCache (IdKey -> Ident -> Map IdKey Ident -> Map IdKey Ident
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert IdKey
key Ident
ident Map IdKey Ident
cache)
State.modify (\GenState
s -> GenState
s { gsIdents = cache' })
pure ident
let update_global_cache = Id -> Bool
isGlobalId Id
i Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
mi Bool -> Bool -> Bool
&& IdType
id_type IdType -> IdType -> Bool
forall a. Eq a => a -> a -> Bool
== IdType
IdPlain
when (update_global_cache) $ do
GlobalIdCache gidc <- getGlobalIdCache
case elemUFM ident gidc of
Bool
False -> GlobalIdCache -> StateT GenState IO ()
setGlobalIdCache (GlobalIdCache -> StateT GenState IO ())
-> GlobalIdCache -> StateT GenState IO ()
forall a b. (a -> b) -> a -> b
$ UniqFM Ident (IdKey, Id) -> GlobalIdCache
GlobalIdCache (UniqFM Ident (IdKey, Id)
-> Ident -> (IdKey, Id) -> UniqFM Ident (IdKey, Id)
forall key elt.
Uniquable key =>
UniqFM key elt -> key -> elt -> UniqFM key elt
addToUFM UniqFM Ident (IdKey, Id)
gidc Ident
ident (IdKey
key, Id
i))
Bool
True -> () -> StateT GenState IO ()
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
pure ident
identForId :: Id -> G Ident
identForId :: Id -> G Ident
identForId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdPlain
identForIdN :: Id -> Int -> G Ident
identForIdN :: Id -> Int -> G Ident
identForIdN Id
i Int
n = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n) IdType
IdPlain
identsForId :: Id -> G [Ident]
identsForId :: Id -> G [Ident]
identsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> [Ident] -> G [Ident]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Ident]
forall a. Monoid a => a
mempty
Int
1 -> (Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[]) (Ident -> [Ident]) -> G Ident -> G [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
Int
s -> (Int -> G Ident) -> [Int] -> G [Ident]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> Int -> G Ident
identForIdN Id
i) [Int
1..Int
s]
identForEntryId :: Id -> G Ident
identForEntryId :: Id -> G Ident
identForEntryId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdEntry
identForDataConEntryId :: Id -> G Ident
identForDataConEntryId :: Id -> G Ident
identForDataConEntryId Id
i = Id -> Maybe Int -> IdType -> G Ident
cachedIdentForId Id
i Maybe Int
forall a. Maybe a
Nothing IdType
IdConEntry
varForId :: Id -> G JStgExpr
varForId :: Id -> G JStgExpr
varForId Id
i = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
varForIdN :: Id -> Int -> G JStgExpr
varForIdN :: Id -> Int -> G JStgExpr
varForIdN Id
i Int
n = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> G Ident
identForIdN Id
i Int
n
varsForId :: Id -> G [JStgExpr]
varsForId :: Id -> G [JStgExpr]
varsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> [JStgExpr] -> G [JStgExpr]
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [JStgExpr]
forall a. Monoid a => a
mempty
Int
1 -> (JStgExpr -> [JStgExpr] -> [JStgExpr]
forall a. a -> [a] -> [a]
:[]) (JStgExpr -> [JStgExpr]) -> G JStgExpr -> G [JStgExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G JStgExpr
varForId Id
i
Int
s -> (Int -> G JStgExpr) -> [Int] -> G [JStgExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Id -> Int -> G JStgExpr
varForIdN Id
i) [Int
1..Int
s]
varForEntryId :: Id -> G JStgExpr
varForEntryId :: Id -> G JStgExpr
varForEntryId Id
i = Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> G Ident -> G JStgExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForEntryId Id
i
varForDataConEntryId :: Id -> G JStgExpr
varForDataConEntryId :: Id -> G JStgExpr
varForDataConEntryId Id
i = JVal -> JStgExpr
ValExpr (JVal -> JStgExpr) -> (Ident -> JVal) -> Ident -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar (Ident -> JStgExpr) -> G Ident -> G JStgExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForDataConEntryId Id
i
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker :: DataCon -> G Ident
identForDataConWorker DataCon
d = Id -> G Ident
identForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)
varForDataConWorker :: DataCon -> G JStgExpr
varForDataConWorker :: DataCon -> G JStgExpr
varForDataConWorker DataCon
d = Id -> G JStgExpr
varForDataConEntryId (DataCon -> Id
dataConWorkId DataCon
d)
declVarsForId :: Id -> G JStgStat
declVarsForId :: Id -> G JStgStat
declVarsForId Id
i = case Type -> Int
typeSize (Id -> Type
idType Id
i) of
Int
0 -> JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
Int
1 -> Ident -> JStgStat
decl (Ident -> JStgStat) -> G Ident -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> G Ident
identForId Id
i
Int
s -> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat)
-> StateT GenState IO [JStgStat] -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> G JStgStat) -> [Int] -> StateT GenState IO [JStgStat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
n -> Ident -> JStgStat
decl (Ident -> JStgStat) -> G Ident -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> Int -> G Ident
identForIdN Id
i Int
n) [Int
1..Int
s]