[Git][ghc/ghc][wip/js-staging] 5 commits: Minor refactoring: avoid unpacking ShortText too soon
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Fri Oct 14 22:35:41 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
7e236701 by Sylvain Henry at 2022-10-14T22:55:14+02:00
Minor refactoring: avoid unpacking ShortText too soon
- - - - -
51a4181a by Sylvain Henry at 2022-10-14T23:00:35+02:00
Remove unused derived instances
- - - - -
9454d0c9 by Sylvain Henry at 2022-10-14T23:17:31+02:00
Use Ident in ClosureInfo instead of FastString
- - - - -
70a041f6 by Sylvain Henry at 2022-10-14T23:49:12+02:00
Add identFS helper
- - - - -
01e0ca4f by Sylvain Henry at 2022-10-15T00:35:39+02:00
Fix liftToGlobal
identsS wasn't correctly ported: it has to return all the Ident
occurences, not only one. Fixed this and simplified liftToGlobal
implementation.
Used UniqFM instead of Map forn the global ident cache.
- - - - -
13 changed files:
- compiler/GHC/JS/Syntax.hs
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Closure.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Monad.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Types.hs
Changes:
=====================================
compiler/GHC/JS/Syntax.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
@@ -57,6 +57,7 @@ module GHC.JS.Syntax
, JOp(..)
, JUOp(..)
, Ident(..)
+ , identFS
, JsLabel
-- * pattern synonyms over JS operators
, pattern New
@@ -383,8 +384,9 @@ instance Show SaneDouble where
-- | A newtype wrapper around 'FastString' for JS identifiers.
newtype Ident = TxtI { itxt :: FastString }
- deriving stock (Show, Typeable, Eq, Generic)
+ deriving stock (Show, Eq)
deriving newtype (Uniquable)
-instance Ord Ident where
- compare (TxtI fs1) (TxtI fs2) = lexicalCompareFS fs1 fs2
+identFS :: Ident -> FastString
+identFS = \case
+ TxtI fs -> fs
=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -38,9 +38,7 @@ import Data.Bifunctor
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
-import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
-import GHC.Types.Unique.DSet
mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr
mapExprIdent f = fst (mapIdent f)
@@ -91,51 +89,48 @@ mapIdent f = (map_expr, map_stat)
ContinueStat{} -> s
{-# INLINE identsS #-}
-identsS :: JStat -> UniqDSet Ident
+identsS :: JStat -> [Ident]
identsS = \case
- DeclStat i e -> unitUniqDSet i `unionUniqDSets` maybe emptyUniqDSet identsE e
+ DeclStat i e -> [i] ++ maybe [] identsE e
ReturnStat e -> identsE e
- IfStat e s1 s2 -> identsE e `unionUniqDSets` identsS s1 `unionUniqDSets` identsS s2
- WhileStat _ e s -> identsE e `unionUniqDSets` identsS s
- ForInStat _ i e s -> unitUniqDSet i `unionUniqDSets` identsE e `unionUniqDSets` identsS s
- SwitchStat e xs s -> identsE e `unionUniqDSets` foldl' unionUniqDSets emptyUniqDSet (map traverseCase xs) `unionUniqDSets` identsS s
- where traverseCase (e,s) = identsE e `unionUniqDSets` identsS s
- TryStat s1 i s2 s3 -> identsS s1 `unionUniqDSets` unitUniqDSet i `unionUniqDSets` identsS s2 `unionUniqDSets` identsS s3
- BlockStat xs -> foldl' unionUniqDSets emptyUniqDSet (map identsS xs)
- ApplStat e es -> identsE e `unionUniqDSets` foldl' unionUniqDSets emptyUniqDSet (map identsE es)
+ IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2
+ WhileStat _ e s -> identsE e ++ identsS s
+ ForInStat _ i e s -> [i] ++ identsE e ++ identsS s
+ SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s
+ where traverseCase (e,s) = identsE e ++ identsS s
+ TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3
+ BlockStat xs -> concatMap identsS xs
+ ApplStat e es -> identsE e ++ concatMap identsE es
UOpStat _op e -> identsE e
- AssignStat e1 e2 -> identsE e1 `unionUniqDSets` identsE e2
+ AssignStat e1 e2 -> identsE e1 ++ identsE e2
UnsatBlock{} -> error "identsS: UnsatBlock"
LabelStat _l s -> identsS s
- BreakStat{} -> emptyUniqDSet
- ContinueStat{} -> emptyUniqDSet
+ BreakStat{} -> []
+ ContinueStat{} -> []
{-# INLINE identsE #-}
-identsE :: JExpr -> UniqDSet Ident
+identsE :: JExpr -> [Ident]
identsE = \case
ValExpr v -> identsV v
SelExpr e _i -> identsE e -- do not rename properties
- IdxExpr e1 e2 -> identsE e1 `unionUniqDSets` identsE e2
- InfixExpr _ e1 e2 -> identsE e1 `unionUniqDSets` identsE e2
+ IdxExpr e1 e2 -> identsE e1 ++ identsE e2
+ InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2
UOpExpr _ e -> identsE e
- IfExpr e1 e2 e3 -> identsE e1 `unionUniqDSets` identsE e2 `unionUniqDSets` identsE e3
- ApplExpr e es -> identsE e `unionUniqDSets` foldl' unionUniqDSets emptyUniqDSet (map identsE es)
+ IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3
+ ApplExpr e es -> identsE e ++ concatMap identsE es
UnsatExpr{} -> error "identsE: UnsatExpr"
{-# INLINE identsV #-}
-identsV :: JVal -> UniqDSet Ident
+identsV :: JVal -> [Ident]
identsV = \case
- JVar i -> unitUniqDSet i
- JList xs -> foldl' unionUniqDSets emptyUniqDSet (map identsE xs)
- JDouble{} -> emptyUniqDSet
- JInt{} -> emptyUniqDSet
- JStr{} -> emptyUniqDSet
- JRegEx{} -> emptyUniqDSet
- -- nonDetEltsUniqMap doesn't introduce non-determinism because the Set ignores
- -- the List's ordering in favour of lexical comparisons
- -- foldl' (<>) Set.empty (map (identsE . snd) $ nonDetEltsUniqMap m)
- JHash m -> foldUFM unionUniqDSets emptyUniqDSet (mapUFM snd . getUniqMap $ mapUniqMap identsE m)
- JFunc args s -> mkUniqDSet args `unionUniqDSets` identsS s
+ JVar i -> [i]
+ JList xs -> concatMap identsE xs
+ JDouble{} -> []
+ JInt{} -> []
+ JStr{} -> []
+ JRegEx{} -> []
+ JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m)
+ JFunc args s -> args ++ identsS s
UnsatVal{} -> error "identsV: UnsatVal"
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -482,7 +482,7 @@ genericStackApply cfg = closure info body
-- info table for h$ap_gen
info = ClosureInfo
- { ciVar = "h$ap_gen"
+ { ciVar = TxtI "h$ap_gen"
, ciRegs = CIRegs 0 [PtrV] -- closure to apply to
, ciName = "h$ap_gen"
, ciLayout = CILayoutVariable
@@ -720,8 +720,8 @@ stackApply s fun_name nargs nvars =
then closure info0 body0
else closure info body
where
- info = ClosureInfo fun_name (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty
- info0 = ClosureInfo fun_name (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty
+ info = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty
+ info0 = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty
body0 = adjSpN' 1 <> enter s r1
@@ -905,7 +905,7 @@ enter s ex = jVar \c ->
updates :: StgToJSConfig -> JStat
updates s = BlockStat
[ closure
- (ClosureInfo "h$upd_frame" (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ (ClosureInfo (TxtI "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
$ jVar \updatee waiters ss si sir ->
let unbox_closure = Closure
{ clEntry = var "h$unbox_e"
@@ -952,7 +952,7 @@ updates s = BlockStat
]
, closure
- (ClosureInfo "h$upd_frame_lne" (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ (ClosureInfo (TxtI "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
$ jVar \updateePos ->
[ updateePos |= stack .! (sp - 1)
, (stack .! updateePos |= r1)
@@ -991,7 +991,7 @@ selectors s =
, returnS (sel r)
]
, closure
- (ClosureInfo entryName (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ (ClosureInfo (TxtI entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar \tgt ->
[ tgt |= closureField1 r1
, traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc"))
@@ -1002,7 +1002,7 @@ selectors s =
(returnS (app "h$e" [sel tgt]))
])
, closure
- (ClosureInfo frameName (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)
+ (ClosureInfo (TxtI frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)
$ mconcat [ traceRts s (toJExpr ("selector frame: " <> name))
, postDecrS sp
, returnS (app "h$e" [sel r1])
@@ -1054,8 +1054,9 @@ specPapIdents = listArray (0,numSpecPap) $ map (TxtI . mkFastString . ("h$pap_"+
pap :: StgToJSConfig
-> Int
-> JStat
-pap s r = closure (ClosureInfo funcName CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body
+pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body
where
+ funcIdent = TxtI funcName
funcName = mkFastString ("h$pap_" ++ show r)
body = jVar \c d f extra ->
@@ -1081,7 +1082,7 @@ pap s r = closure (ClosureInfo funcName CIRegsUnknown funcName (CILayoutUnknown
-- Construct a generic PAP
papGen :: StgToJSConfig -> JStat
papGen cfg =
- closure (ClosureInfo funcName CIRegsUnknown funcName CILayoutVariable CIPap mempty)
+ closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty)
(jVar \c f d pr or r ->
[ c |= closureField1 r1
, d |= closureField2 r1
@@ -1102,6 +1103,7 @@ papGen cfg =
where
+ funcIdent = TxtI funcName
funcName = "h$pap_gen"
loadOwnArgs d r =
let prop n = d .^ ("d" <> mkFastString (show $ n+1))
=====================================
compiler/GHC/StgToJS/Closure.hs
=====================================
@@ -49,7 +49,7 @@ closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs)
setObjInfoL :: Bool -- ^ debug: output symbol names
- -> FastString -- ^ the object name
+ -> Ident -- ^ the object name
-> CIRegs -- ^ things in registers
-> CILayout -- ^ layout of the object
-> ClosureType -- ^ closure type
@@ -70,7 +70,7 @@ setObjInfoL debug obj rs layout t n a
CILayoutFixed _ fs -> toTypeList fs
setObjInfo :: Bool -- ^ debug: output all symbol names
- -> FastString -- ^ the thing to modify
+ -> Ident -- ^ the thing to modify
-> ClosureType -- ^ closure type
-> FastString -- ^ object name, for printing
-> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields)
@@ -80,7 +80,7 @@ setObjInfo :: Bool -- ^ debug: output all symbol names
-> CIStatic -- ^ static refs
-> JStat
setObjInfo debug obj t name fields a size regs static
- | debug = appS "h$setObjInfo" [ var obj
+ | debug = appS "h$setObjInfo" [ toJExpr obj
, toJExpr t
, toJExpr name
, toJExpr fields
@@ -89,7 +89,7 @@ setObjInfo debug obj t name fields a size regs static
, toJExpr (regTag regs)
, toJExpr static
]
- | otherwise = appS "h$o" [ var obj
+ | otherwise = appS "h$o" [ toJExpr obj
, toJExpr t
, toJExpr a
, toJExpr size
@@ -105,9 +105,9 @@ setObjInfo debug obj t name fields a size regs static
closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
-> JStat -- ^ rhs
-> JStat
-closure ci body = (TxtI (ciVar ci) ||= jLam body) `mappend` closureInfoStat False ci
+closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci
-conClosure :: FastString -> FastString -> CILayout -> Int -> JStat
+conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
conClosure symbol name layout constr =
closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty)
(returnS (stack .! sp))
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -296,9 +296,9 @@ genToplevelConEntry i rhs = case rhs of
genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
genSetConInfo i d l {- srt -} = do
- ei@(TxtI eii) <- identForDataConEntryId i
+ ei <- identForDataConEntryId i
sr <- genStaticRefs l
- emitClosureInfo $ ClosureInfo eii
+ emitClosureInfo $ ClosureInfo ei
(CIRegs 0 [PtrV])
(mkFastString $ renderWithContext defaultSDocContext (ppr d))
(fixedLayout $ map uTypeVt fields)
@@ -332,8 +332,10 @@ genToplevelRhs i rhs = case rhs of
eid@(TxtI eidt) <- identForEntryId i
(TxtI idt) <- identForId i
body <- genBody (initExprCtx i) i R2 args body
- (lidents, lids) <- unzip <$> liftToGlobal (jsSaturate (Just "ghcjs_tmp_sat_") body)
- let lidents' = map (\(TxtI t) -> t) lidents
+ global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body)
+ let lidents = map global_ident global_occs
+ let lids = map global_id global_occs
+ let lidents' = map identFS lidents
CIStaticRefs sr0 <- genStaticRefsRhs rhs
let sri = filter (`notElem` lidents') sr0
sr = CIStaticRefs sri
@@ -352,7 +354,7 @@ genToplevelRhs i rhs = case rhs of
if et == CIThunk
then enterCostCentreThunk
else enterCostCentreFun cc
- emitClosureInfo (ClosureInfo eidt
+ emitClosureInfo (ClosureInfo eid
regs
idt
(fixedLayout $ map (uTypeVt . idType) lids)
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -238,11 +238,11 @@ genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
| otherwise = mempty
lvs <- popLneFrame True payloadSize ctx
body <- genBody ctx i R1 args body
- ei@(TxtI eii) <- identForEntryId i
+ ei@(TxtI eii) <- identForEntryId i
sr <- genStaticRefsRhs rhs
let f = JFunc [] (bh <> lvs <> body)
emitClosureInfo $
- ClosureInfo eii
+ ClosureInfo ei
(CIRegs 0 $ concatMap idVt args)
(eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
(fixedLayout . reverse $
@@ -277,7 +277,7 @@ genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = res
then enterCostCentreThunk
else enterCostCentreFun cc
sr <- genStaticRefsRhs rhs
- emitClosureInfo $ ClosureInfo eii
+ emitClosureInfo $ ClosureInfo ei
(CIRegs 0 $ PtrV : concatMap idVt args)
(eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
(fixedLayout $ map (uTypeVt . idType) live)
@@ -631,7 +631,7 @@ genRet ctx e at as l = freshIdent >>= f
sr <- genStaticRefs l -- srt
prof <- profiling
emitClosureInfo $
- ClosureInfo ri
+ ClosureInfo r
(CIRegs 0 altRegs)
ri
(fixedLayout . reverse $
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -28,6 +28,7 @@ import GHC.StgToJS.Ids
import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Unique.Map
+import GHC.Types.Unique.FM
import GHC.Stg.Syntax
@@ -45,7 +46,6 @@ import Data.Char
import Data.Monoid
import Data.Maybe
import qualified Data.List as L
-import qualified Data.Map as M
import Control.Monad
import Control.Applicative
import qualified Text.ParserCombinators.ReadP as P
@@ -147,7 +147,7 @@ parseFFIPattern' callback javascriptCc pat t ret args
Right expr | not async && length tgt < 2 -> do
(statPre, ap) <- argPlaceholders javascriptCc args
let rp = resultPlaceholders async t ret
- env = M.fromList (rp ++ ap)
+ env = addListToUFM emptyUFM (rp ++ ap)
if length tgt == 1
then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr))
else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr))
@@ -159,7 +159,7 @@ parseFFIPattern' callback javascriptCc pat t ret args
let rp = resultPlaceholders async t ret
let cp = callbackPlaceholders callback
(statPre, ap) <- argPlaceholders javascriptCc args
- let env = M.fromList (rp ++ ap ++ cp)
+ let env = addListToUFM emptyUFM (rp ++ ap ++ cp)
return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace?
where
async = isJust callback
@@ -186,9 +186,10 @@ parseFFIPattern' callback javascriptCc pat t ret args
where f' = toJExpr (TxtI $ mkFastString f)
copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs
p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e)
- replaceIdent :: M.Map Ident JExpr -> Ident -> JExpr
+
+ replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr
replaceIdent env i
- | isFFIPlaceholder i = fromMaybe err (M.lookup i env)
+ | isFFIPlaceholder i = fromMaybe err (lookupUFM env i)
| otherwise = ValExpr (JVar i)
where
(TxtI i') = i
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -49,6 +49,7 @@ 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.Utils.Encoding (zEncodeString)
@@ -158,9 +159,9 @@ cachedIdentForId i mi id_type = do
when (update_global_cache) $ do
GlobalIdCache gidc <- getGlobalIdCache
- case M.lookup ident gidc of
- Nothing -> setGlobalIdCache $ GlobalIdCache (M.insert ident (key, i) gidc)
- Just _ -> pure ()
+ case elemUFM ident gidc of
+ False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i))
+ True -> pure ()
pure ident
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -70,6 +70,7 @@ import GHC.Types.Unique.Set
import qualified GHC.SysTools.Ar as Ar
+import qualified GHC.Data.ShortText as ST
import GHC.Data.FastString
import Control.Concurrent.MVar
@@ -382,7 +383,7 @@ renderLinkerStats s =
getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
getPackageArchives cfg unit_env units =
- filterM doesFileExist [ p </> "lib" ++ l ++ profSuff <.> "a"
+ filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"
| u <- units
, p <- getInstalledPackageLibDirs ue_state u
, l <- getInstalledPackageHsLibs ue_state u
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -47,12 +47,12 @@ import Data.Char (isSpace)
import qualified Control.Exception as Exception
-- | Retrieve library directories provided by the @UnitId@ in @UnitState@
-getInstalledPackageLibDirs :: UnitState -> UnitId -> [FilePath]
-getInstalledPackageLibDirs us = fmap unpack . maybe mempty unitLibraryDirs . lookupUnitId us
+getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText]
+getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us
-- | Retrieve the names of the libraries provided by @UnitId@
-getInstalledPackageHsLibs :: UnitState -> UnitId -> [String]
-getInstalledPackageHsLibs us = fmap unpack . maybe mempty unitLibraries . lookupUnitId us
+getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText]
+getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us
-- | A constant holding the JavaScript executable Filename extension
jsexeExtension :: String
=====================================
compiler/GHC/StgToJS/Monad.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
-- | JS codegen state monad
module GHC.StgToJS.Monad
@@ -13,9 +14,10 @@ module GHC.StgToJS.Monad
, emitForeign
, assertRtsStat
, getSettings
- , liftToGlobal
+ , globalOccs
, setGlobalIdCache
, getGlobalIdCache
+ , GlobalOcc(..)
-- * Group
, modifyGroup
, resetGroup
@@ -44,9 +46,6 @@ import GHC.Data.FastMutInt
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.List as L
-import Data.Function
-
-import GHC.Types.Unique.DSet
runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
runG config m unfloat action = State.evalStateT action =<< initState config m unfloat
@@ -133,7 +132,7 @@ defaultGenGroupState :: GenGroupState
defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache []
emptyGlobalIdCache :: GlobalIdCache
-emptyGlobalIdCache = GlobalIdCache M.empty
+emptyGlobalIdCache = GlobalIdCache emptyUFM
emptyIdCache :: IdCache
emptyIdCache = IdCache M.empty
@@ -155,17 +154,32 @@ setGlobalIdCache :: GlobalIdCache -> G ()
setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}})
-liftToGlobal :: JStat -> G [(Ident, Id)]
-liftToGlobal jst = do
- GlobalIdCache gidc <- getGlobalIdCache
- let sids = filterUniqDSet (`M.member` gidc) (identsS jst)
- cnt = M.fromListWith (+) (map (,(1::Integer)) $ uniqDSetToList sids)
- sids' = L.sortBy (compare `on` (cnt M.!)) (nub' $ uniqDSetToList sids)
- pure $ map (\s -> (s, snd $ gidc M.! s)) sids'
+data GlobalOcc = GlobalOcc
+ { global_ident :: !Ident
+ , global_id :: !Id
+ , global_count :: !Word
+ }
-nub' :: (Ord a, Eq a) => [a] -> [a]
-nub' xs = go S.empty xs
- where
- go _ [] = []
- go s (x:xs) | S.member x s = go s xs
- | otherwise = x : go (S.insert x s) xs
+-- | Return number of occurrences of every global id used in the given JStat.
+-- Sort by increasing occurrence count.
+globalOccs :: JStat -> G [GlobalOcc]
+globalOccs jst = do
+ GlobalIdCache gidc <- getGlobalIdCache
+ -- build a map form Ident Unique to (Ident, Id, Count)
+ let
+ cmp_cnt g1 g2 = compare (global_count g1) (global_count g2)
+ inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 }
+ go gids = \case
+ [] -> -- return global Ids used locally sorted by increased use
+ L.sortBy cmp_cnt $ nonDetEltsUFM gids
+ (i:is) ->
+ -- check if the Id is global
+ case lookupUFM gidc i of
+ Nothing -> go gids is
+ Just (_k,gid) ->
+ -- add it to the list of already found global ids. Increasing
+ -- count by 1
+ let g = GlobalOcc i gid 1
+ in go (addToUFM_C inc gids i g) is
+
+ pure $ go emptyUFM (identsS jst)
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -392,35 +392,32 @@ rts' s =
, TxtI "h$vt_arr" ||= toJExpr ArrV
, TxtI "h$bh" ||= jLam (bhStats s True)
, TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize)
- , closure (ClosureInfo "h$blackhole" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
+ , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
(appS "throw" [jString "oops: entered black hole"])
- , closure (ClosureInfo "h$blackholeTrap" (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)
(appS "throw" [jString "oops: entered multiple times"])
- , closure (ClosureInfo "h$done" (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)
(appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule"))
- , closure (ClosureInfo "h$doneMain_e" (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)
(returnS (var "h$doneMain"))
- , conClosure "h$false_e" "GHC.Types.False" (CILayoutFixed 0 []) 1
- , conClosure "h$true_e" "GHC.Types.True" (CILayoutFixed 0 []) 2
- , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziSzh_con_e" "GHC.Integer.Type.S#" (CILayoutFixed 1 [IntV]) 1
- , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJpzh_con_e" "GHC.Integer.Type.Jp#" (CILayoutFixed 1 [ObjV]) 2
- , conClosure "h$integerzmwiredzminZCGHCziIntegerziTypeziJnzh_con_e" "GHC.Integer.Type.Jn#" (CILayoutFixed 1 [ObjV]) 3
+ , conClosure (TxtI "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1
+ , conClosure (TxtI "h$true_e" ) "GHC.Types.True" (CILayoutFixed 0 []) 2
-- generic data constructor with 1 non-heapobj field
- , conClosure "h$data1_e" "data1" (CILayoutFixed 1 [ObjV]) 1
+ , conClosure (TxtI "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1
-- generic data constructor with 2 non-heapobj fields
- , conClosure "h$data2_e" "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1
- , closure (ClosureInfo "h$noop_e" (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)
+ , conClosure (TxtI "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1
+ , closure (ClosureInfo (TxtI "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)
(returnS (stack .! sp))
<> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s]))
- , closure (ClosureInfo "h$catch_e" (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)
(adjSpN' 3 <> returnS (stack .! sp))
- , closure (ClosureInfo "h$dataToTag_e" (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)
$ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0)
, adjSpN' 1
, returnS (stack .! sp)
]
-- function application to one argument
- , closure (ClosureInfo "h$ap1_e" (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)
(jVar $ \d1 d2 ->
mconcat [ d1 |= closureField1 r1
, d2 |= closureField2 r1
@@ -431,7 +428,7 @@ rts' s =
, returnS (app "h$ap_1_1_fast" [])
])
-- function application to two arguments
- , closure (ClosureInfo "h$ap2_e" (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)
(jVar $ \d1 d2 d3 ->
mconcat [ d1 |= closureField1 r1
, d2 |= closureField2 r1 .^ "d1"
@@ -444,7 +441,7 @@ rts' s =
, returnS (app "h$ap_2_2_fast" [])
])
-- function application to three arguments
- , closure (ClosureInfo "h$ap3_e" (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)
(jVar $ \d1 d2 d3 d4 ->
mconcat [ d1 |= closureField1 r1
, d2 |= closureField2 r1 .^ "d1"
@@ -458,7 +455,7 @@ rts' s =
, returnS (app "h$ap_3_3_fast" [])
])
-- select first field
- , closure (ClosureInfo "h$select1_e" (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar $ \t ->
mconcat [ t |= closureField1 r1
, adjSp' 3
@@ -471,13 +468,13 @@ rts' s =
, r1 |= t
, returnS (app "h$ap_0_0_fast" [])
])
- , closure (ClosureInfo "h$select1_ret" (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)
((r1 |= closureField1 r1)
<> adjSpN' 1
<> returnS (app "h$ap_0_0_fast" [])
)
-- select second field of a two-field constructor
- , closure (ClosureInfo "h$select2_e" (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar $ \t ->
mconcat [t |= closureField1 r1
, adjSp' 3
@@ -491,22 +488,22 @@ rts' s =
, returnS (app "h$ap_0_0_fast" [])
]
)
- , closure (ClosureInfo "h$select2_ret" (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)
$ mconcat [ r1 |= closureField2 r1
, adjSpN' 1
, returnS (app "h$ap_0_0_fast" [])
]
- , closure (ClosureInfo "h$keepAlive_e" (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
(mconcat [ adjSpN' 2
, returnS (stack .! sp)
]
)
-- a thunk that just raises a synchronous exception
- , closure (ClosureInfo "h$raise_e" (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)
(returnS (app "h$throw" [closureField1 r1, false_]))
- , closure (ClosureInfo "h$raiseAsync_e" (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty)
(returnS (app "h$throw" [closureField1 r1, true_]))
- , closure (ClosureInfo "h$raiseAsync_frame" (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty)
(jVar $ \ex ->
mconcat [ ex |= stack .! (sp - 1)
, adjSpN' 2
@@ -516,19 +513,19 @@ rts' s =
add this to the stack if you want the outermost result
to always be reduced to whnf, and not an ind
-}
- , closure (ClosureInfo "h$reduce" (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty)
(ifS (isThunk r1)
(returnS (r1 .^ "f"))
(adjSpN' 1 <> returnS (stack .! sp))
)
, rtsApply s
, closureTypes
- , closure (ClosureInfo "h$runio_e" (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
$ mconcat [ r1 |= closureField1 r1
, stack .! PreInc sp |= var "h$ap_1_0"
, returnS (var "h$ap_1_0")
]
- , closure (ClosureInfo "h$flushStdout_e" (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)
$ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush"
, r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout"
, returnS (app "h$ap_1_1_fast" [])
@@ -536,7 +533,7 @@ rts' s =
, TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"]
-- the scheduler pushes this frame when suspending a thread that
-- has not called h$reschedule explicitly
- , closure (ClosureInfo "h$restoreThread" (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)
(jVar $ \f frameSize nregs ->
mconcat [f |= stack .! (sp - 2)
, frameSize |= stack .! (sp - 1)
@@ -547,12 +544,12 @@ rts' s =
, returnS f
])
-- return a closure in the stack frame to the next thing on the stack
- , closure (ClosureInfo "h$return" (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
((r1 |= stack .! (sp - 1))
<> adjSpN' 2
<> returnS (stack .! sp))
-- return a function in the stack frame for the next call
- , closure (ClosureInfo "h$returnf" (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
(jVar $ \r ->
mconcat [ r |= stack .! (sp - 1)
, adjSpN' 2
@@ -561,10 +558,10 @@ rts' s =
-- return this function when the scheduler needs to come into action
-- (yield, delay etc), returning thread needs to push all relevant
-- registers to stack frame, thread will be resumed by calling the stack top
- , closure (ClosureInfo "h$reschedule" (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)
(returnS $ var "h$reschedule")
-- debug thing, insert on stack to dump current result, should be boxed
- , closure (ClosureInfo "h$dumpRes" (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)
(jVar $ \re ->
mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)]
, appS "h$log" [r1]
@@ -584,7 +581,7 @@ rts' s =
, r1 |= null_
, returnS (stack .! sp)
])
- , closure (ClosureInfo "h$resume_e" (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty)
(jVar $ \ss ->
mconcat [ss |= closureField1 r1
, updateThunk' s
@@ -594,52 +591,52 @@ rts' s =
, r1 |= null_
, returnS (stack .! sp)
])
- , closure (ClosureInfo "h$unmaskFrame" (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty)
((var "h$currentThread" .^ "mask" |= 0)
<> adjSpN' 1
-- back to scheduler to give us async exception if pending
<> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0)
(push' s [r1, var "h$return"] <> returnS (var "h$reschedule"))
(returnS (stack .! sp)))
- , closure (ClosureInfo "h$maskFrame" (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty)
((var "h$currentThread" .^ "mask" |= 2)
<> adjSpN' 1
<> returnS (stack .! sp))
- , closure (ClosureInfo "h$maskUnintFrame" (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)
((var "h$currentThread" .^ "mask" |= 1)
<> adjSpN' 1
<> returnS (stack .! sp))
- , closure (ClosureInfo "h$unboxFFIResult" (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)
(jVar $ \d ->
mconcat [d |= closureField1 r1
, loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i)
, adjSpN' 1
, returnS (stack .! sp)
])
- , closure (ClosureInfo "h$unbox_e" (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)
((r1 |= closureField1 r1) <> returnS (stack .! sp))
- , closure (ClosureInfo "h$retryInterrupted" (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
(jVar $ \a ->
mconcat [ a |= stack .! (sp - 1)
, adjSpN' 2
, returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]])
])
- , closure (ClosureInfo "h$atomically_e" (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
(ifS (app "h$stmValidateTransaction" [])
(appS "h$stmCommitTransaction" []
<> adjSpN' 2
<> returnS (stack .! sp))
(returnS (app "h$stmStartTransaction" [stack .! (sp - 2)])))
- , closure (ClosureInfo "h$stmCatchRetry_e" (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
(adjSpN' 2
<> appS "h$stmCommitTransaction" []
<> returnS (stack .! sp))
- , closure (ClosureInfo "h$catchStm_e" (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)
(adjSpN' 4
<> appS "h$stmCommitTransaction" []
<> returnS (stack .! sp))
- , closure (ClosureInfo "h$stmResumeRetry_e" (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)
+ , closure (ClosureInfo (TxtI "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)
(jVar $ \blocked ->
mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e")
(appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"])
@@ -648,7 +645,7 @@ rts' s =
, appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"]
, returnS (app "h$stmStartTransaction" [stack .! (sp - 2)])
])
- , closure (ClosureInfo "h$lazy_e" (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)
+ , closure (ClosureInfo (TxtI "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)
(jVar $ \x ->
mconcat [x |= ApplExpr (closureField1 r1) []
, appS "h$bh" []
@@ -657,7 +654,7 @@ rts' s =
, returnS (stack .! sp)
])
-- Top-level statements to generate only in profiling mode
- , profStat s (closure (ClosureInfo "h$setCcs_e" (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
+ , profStat s (closure (ClosureInfo (TxtI "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
(appS "h$restoreCCS" [ stack .! (sp - 1)]
<> adjSpN' 2
<> returnS (stack .! sp)))
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -98,7 +98,7 @@ data StgToJSConfig = StgToJSConfig
-- | Information relevenat to code generation for closures.
data ClosureInfo = ClosureInfo
- { ciVar :: FastString -- ^ object being infod
+ { ciVar :: Ident -- ^ object being infod
, ciRegs :: CIRegs -- ^ size of the payload (in number of JS values)
, ciName :: FastString -- ^ friendly name for printing
, ciLayout :: CILayout -- ^ heap/stack layout of the object
@@ -216,7 +216,7 @@ instance Ord OtherSymb where
newtype IdCache = IdCache (M.Map IdKey Ident)
-- | The global Identifier Cache
-newtype GlobalIdCache = GlobalIdCache (M.Map Ident (IdKey, Id))
+newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id))
-- | A Stack Slot is either known or unknown. We avoid maybe here for more
-- strictness.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a95716a5c4133e3fe6c9e1552295823c17e3b49...01e0ca4f31e6eccb0420a8763b9064cd1e99172d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a95716a5c4133e3fe6c9e1552295823c17e3b49...01e0ca4f31e6eccb0420a8763b9064cd1e99172d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221014/1c758beb/attachment-0001.html>
More information about the ghc-commits
mailing list