[Git][ghc/ghc][wip/T24744] 3 commits: Basic cleanup
Serge S. Gulin (@gulin.serge)
gitlab at gitlab.haskell.org
Tue Nov 12 08:40:00 UTC 2024
Serge S. Gulin pushed to branch wip/T24744 at Glasgow Haskell Compiler / GHC
Commits:
b4519be3 by Serge S. Gulin at 2024-11-12T11:39:39+03:00
Basic cleanup
- - - - -
235225c1 by Serge S. Gulin at 2024-11-12T11:39:48+03:00
Add trivial optimizations for `unpackCString` and `unpackCStringUtf8`
- - - - -
ae9b18fd by Serge S. Gulin at 2024-11-12T11:39:48+03:00
Enable static args
- - - - -
11 changed files:
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Arg.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Monad.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Symbols.hs
- compiler/GHC/StgToJS/Types.hs
- rts/js/string.js
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -157,6 +157,24 @@ genApp ctx i args
, ExprInline
)
+ | [StgLitArg (LitString bs)] <- args
+ , Just d <- decodeModifiedUTF8 bs
+ , idName i == unpackCStringName
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsStringA" [toJExpr d]
+ , ExprInline
+ )
+
+ | [StgLitArg (LitString bs)] <- args
+ , Just d <- decodeModifiedUTF8 bs
+ , idName i == unpackCStringUtf8Name
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsString" [toJExpr d]
+ , ExprInline
+ )
+
-- let-no-escape
| Just n <- ctxLneBindingStackSize ctx i
= do
=====================================
compiler/GHC/StgToJS/Arg.hs
=====================================
@@ -22,9 +22,6 @@ module GHC.StgToJS.Arg
, genIdArgI
, genIdStackArgI
, allocConStatic
- , allocUnboxedConStatic
- , allocateStaticList
- , jsStaticArg
, jsStaticArgs
)
where
@@ -215,7 +212,7 @@ allocConStatic (identFS -> to) cc con args = do
emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
| otherwise = do
e <- identFS <$> identForDataConWorker con
- emitStatic to (StaticData e []) cc'
+ emitStatic to (StaticScalar $ StaticApp SAKData e []) cc'
allocConStatic' cc' [x]
| isUnboxableCon con =
case x of
@@ -234,7 +231,7 @@ allocConStatic (identFS -> to) cc con args = do
_ -> panic "allocConStatic: invalid args for consDataCon"
else do
e <- identFS <$> identForDataConWorker con
- emitStatic to (StaticData e xs) cc'
+ emitStatic to (StaticScalar $ StaticApp SAKData e xs) cc'
-- | Allocate unboxed constructors
allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -329,7 +329,7 @@ genToplevelRhs i rhs = case rhs of
body <- genBody (initExprCtx i) R2 args body typ
global_occs <- globalOccs body
let eidt = identFS eid
- let lidents = map global_ident global_occs
+ let lidents = concatMap global_idents global_occs
let lids = map global_id global_occs
let lidents' = map identFS lidents
CIStaticRefs sr0 <- genStaticRefsRhs rhs
@@ -337,15 +337,15 @@ genToplevelRhs i rhs = case rhs of
sr = CIStaticRefs sri
et <- genEntryType args
ll <- loadLiveFun lids
- (static, regs, upd) <-
+ (appK, regs, upd) <-
if et == CIThunk
then do
r <- updateThunk
- pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
- else return (StaticFun eidt (map StaticObjArg lidents'),
- (if null lidents then CIRegs 1 (concatMap idJSRep args)
- else CIRegs 0 (PtrV : concatMap idJSRep args))
- , mempty)
+ pure (SAKThunk, CIRegs 0 [PtrV], r)
+ else
+ let regs = if null lidents then CIRegs 1 (concatMap idJSRep args)
+ else CIRegs 0 (PtrV : concatMap idJSRep args)
+ in pure (SAKFun, regs, mempty)
setcc <- ifProfiling $
if et == CIThunk
then enterCostCentreThunk
@@ -359,5 +359,5 @@ genToplevelRhs i rhs = case rhs of
, ciStatic = sr
}
ccId <- costCentreStackLbl cc
- emitStatic idt static ccId
+ emitStatic idt (StaticScalar $ StaticApp appK eidt $ map StaticObjArg lidents') ccId
return $ (FuncStat eid [] (ll <> upd <> setcc <> body))
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -606,6 +606,32 @@ genCase ctx bnd e at alts l
, ExprInline
)
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , idName i == unpackCStringName
+ , [StgVarArg b'] <- args
+ , bnd == b'
+ , Just d <- decodeModifiedUTF8 bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsStringA" [toJExpr d]
+ , ExprInline
+ )
+
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , idName i == unpackCStringUtf8Name
+ , [StgVarArg b'] <- args
+ , bnd == b'
+ , Just d <- decodeModifiedUTF8 bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = return
+ ( top |= app "h$toHsString" [toJExpr d]
+ , ExprInline
+ )
+
| isInlineExpr e = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
=====================================
compiler/GHC/StgToJS/Ids.hs
=====================================
@@ -155,7 +155,7 @@ cachedIdentForId i mi id_type = do
-- Now update the GlobalId cache, if required
- let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain
+ let update_global_cache = isGlobalId i && id_type == IdPlain
-- fixme also allow caching entries for lifting?
when (update_global_cache) $ do
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -24,8 +24,6 @@ module GHC.StgToJS.Linker.Linker
( jsLinkBinary
, jsLink
, embedJsFile
- , staticInitStat
- , staticDeclStat
, mkExportedFuns
, mkExportedModFuns
, computeLinkDependencies
@@ -1253,27 +1251,22 @@ staticInitStat :: StaticInfo -> JS.JStat
staticInitStat (StaticInfo i sv mcc) =
jStgStatToJS $
case sv of
- StaticData con args -> appS hdStiStr $ add_cc_arg
- [ global i
- , global con
- , jsStaticArgs args
- ]
- StaticFun f args -> appS hdStiStr $ add_cc_arg
- [ global i
- , global f
- , jsStaticArgs args
- ]
- StaticList args mt -> appS hdStlStr $ add_cc_arg
- [ global i
- , jsStaticArgs args
- , toJExpr $ maybe null_ (toJExpr . TxtI) mt
- ]
- StaticThunk (Just (f,args)) -> appS hdStcStr $ add_cc_arg
- [ global i
- , global f
- , jsStaticArgs args
- ]
- _ -> mempty
+ StaticScalar (StaticApp k app args) -> appS
+ (if k == SAKThunk then hdStcStr else hdStiStr)
+ $ add_cc_arg
+ [ global i
+ , global app
+ , jsStaticArgs args
+ ]
+
+ StaticList args mt -> appS hdStlStr
+ $ add_cc_arg
+ [ global i
+ , jsStaticArgs args
+ , toJExpr $ maybe null_ (toJExpr . TxtI) mt
+ ]
+
+ StaticUnboxed _ -> mempty
where
-- add optional cost-center argument
add_cc_arg as = case mcc of
@@ -1286,20 +1279,15 @@ staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl
where
global_ident = name global_name
decl_init v = global_ident ||= v
- decl_no_init = appS hdDiStr [toJExpr global_ident]
decl = case static_value of
StaticUnboxed u -> decl_init (unboxed_expr u)
- StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way
_ -> decl_init (app hdDStr [])
unboxed_expr = \case
StaticUnboxedBool b -> app hdPStr [toJExpr b]
StaticUnboxedInt i -> app hdPStr [toJExpr i]
StaticUnboxedDouble d -> app hdPStr [toJExpr (unSaneDouble d)]
- -- GHCJS used a function wrapper for this:
- -- StaticUnboxedString str -> ApplExpr (initStr str) []
- -- But we are defining it statically for now.
StaticUnboxedString str -> initStr str
StaticUnboxedStringOffset {} -> 0
=====================================
compiler/GHC/StgToJS/Monad.hs
=====================================
@@ -153,16 +153,16 @@ getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup)
setGlobalIdCache :: GlobalIdCache -> G ()
setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}})
-
data GlobalOcc = GlobalOcc
- { global_ident :: !Ident
+ { global_idents :: ![Ident]
+ -- ^ Some ids are represented by few idents. i.e. Addr#
, global_id :: !Id
, global_count :: !Word
}
instance Outputable GlobalOcc where
ppr g = hang (text "GlobalOcc") 2 $ vcat
- [ hcat [text "Ident: ", ppr (global_ident g)]
+ [ hcat [text "Idents: ", ppr (global_idents g)]
, hcat [text "Id:", ppr (global_id g)]
, hcat [text "Count:", ppr (global_count g)]
]
@@ -175,7 +175,12 @@ globalOccs jst = do
-- 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 }
+ inc g1 g2 = g1
+ { global_count = global_count g1 + global_count g2
+ , global_idents = global_idents g1 ++ global_idents g2
+ }
+
+ go :: UniqFM Id GlobalOcc -> [Ident] -> [GlobalOcc]
go gids = \case
[] -> -- return global Ids used locally sorted by increased use
L.sortBy cmp_cnt $ nonDetEltsUFM gids
@@ -186,7 +191,7 @@ globalOccs jst = do
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
+ let g = GlobalOcc [i] gid 1
+ in go (addToUFM_C inc gids gid g) is
pure $ go emptyUFM (identsS jst)
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -615,16 +615,16 @@ instance Binary StaticInfo where
get bh = StaticInfo <$> get bh <*> get bh <*> get bh
instance Binary StaticVal where
- put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args
- put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t
- put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u
- put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args
- put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t
+ put_ bh (StaticScalar (StaticApp SAKFun f args)) = putByte bh 1 >> put_ bh f >> put_ bh args
+ put_ bh (StaticScalar (StaticApp SAKThunk f args)) = putByte bh 2 >> put_ bh f >> put_ bh args
+ put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u
+ put_ bh (StaticScalar (StaticApp SAKData dc args)) = putByte bh 4 >> put_ bh dc >> put_ bh args
+ put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t
get bh = getByte bh >>= \case
- 1 -> StaticFun <$> get bh <*> get bh
- 2 -> StaticThunk <$> get bh
+ 1 -> StaticScalar <$> (StaticApp SAKFun <$> get bh <*> get bh)
+ 2 -> StaticScalar <$> (StaticApp SAKThunk <$> get bh <*> get bh)
3 -> StaticUnboxed <$> get bh
- 4 -> StaticData <$> get bh <*> get bh
+ 4 -> StaticScalar <$> (StaticApp SAKData <$> get bh <*> get bh)
5 -> StaticList <$> get bh <*> get bh
n -> error ("Binary get bh StaticVal: invalid tag " ++ show n)
=====================================
compiler/GHC/StgToJS/Symbols.hs
=====================================
@@ -849,9 +849,6 @@ unknown = fsLit "<unknown>"
typeof :: FastString
typeof = fsLit "typeof"
-hdRawStr :: FastString
-hdRawStr = fsLit "h$rstr"
-
throwStr :: FastString
throwStr = fsLit "throw"
@@ -1213,8 +1210,6 @@ hdStlStr = fsLit "h$stl"
hdStiStr :: FastString
hdStiStr = fsLit "h$sti"
-hdStrStr :: FastString
-hdStrStr = fsLit "h$str"
------------------------------ Pack/Unpack --------------------------------------------
hdDecodeUtf8Z :: FastString
=====================================
compiler/GHC/StgToJS/Types.hs
=====================================
@@ -231,18 +231,25 @@ data StaticInfo = StaticInfo
, siCC :: !(Maybe Ident) -- ^ optional CCS name
} deriving stock (Eq, Show)
+data StaticAppKind
+ = SAKFun
+ -- ^ heap object for function
+ | SAKThunk
+ -- ^ heap object for CAF
+ | SAKData
+ -- ^ regular datacon app
+ deriving stock (Eq, Show)
+
+-- Static scalar application
+data StaticApp = StaticApp StaticAppKind !FastString [StaticArg]
+ deriving stock (Eq, Show)
+
data StaticVal
- = StaticFun !FastString [StaticArg]
- -- ^ heap object for function
- | StaticThunk !(Maybe (FastString,[StaticArg]))
- -- ^ heap object for CAF (field is Nothing when thunk is initialized in an
- -- alternative way, like string thunks through h$str)
- | StaticUnboxed !StaticUnboxed
+ = StaticUnboxed !StaticUnboxed
-- ^ unboxed constructor (Bool, Int, Double etc)
- | StaticData !FastString [StaticArg]
- -- ^ regular datacon app
| StaticList [StaticArg] (Maybe FastString)
-- ^ list initializer (with optional tail)
+ | StaticScalar StaticApp
deriving stock (Eq, Show)
data StaticUnboxed
=====================================
rts/js/string.js
=====================================
@@ -1,53 +1,5 @@
//#OPTIONS: CPP
-// encode a string constant
-function h$str(s) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$encodeModifiedUtf8(s);
- }
- return enc;
- }
-}
-
-// encode a packed string
-// since \0 is used to separate strings (and a common occurrence)
-// we add the following mapping:
-// - \0 -> \cz\0
-// - \cz -> \cz\cz
-//
-// decoding to bytes, the following is produced:
-// - \cz\0 -> C0 80
-// - \cz\cz -> 1A
-//
-// additionally, for dealing with raw binary data we have an escape sequence
-// to pack base64 encoded runs:
-//
-// - \cz\xNN -> followed by NN-0x1f (31 decimal) bytes of base64 encoded
-// data. supported range: 0x20 .. 0x9f (1-128 bytes data)
-//
-
-function h$pstr(s) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$encodePackedUtf8(s);
- }
- return enc;
- }
-}
-// encode a raw string from bytes
-function h$rstr(d) {
- var enc = null;
- return function() {
- if(enc === null) {
- enc = h$rawStringData(d);
- }
- return enc;
- }
-}
-
// these aren't added to the CAFs, so the list stays in mem indefinitely, is that a problem?
#ifdef GHCJS_PROF
function h$strt(str, cc) { return MK_LAZY_CC(function() { return h$toHsString(str, cc); }, cc); }
@@ -265,10 +217,27 @@ function h$encodeUtf8(str) {
return h$encodeUtf8Internal(str, false, false);
}
+// encode a string constant
function h$encodeModifiedUtf8(str) {
return h$encodeUtf8Internal(str, true, false);
}
+// encode a packed string
+// since \0 is used to separate strings (and a common occurrence)
+// we add the following mapping:
+// - \0 -> \cz\0
+// - \cz -> \cz\cz
+//
+// decoding to bytes, the following is produced:
+// - \cz\0 -> C0 80
+// - \cz\cz -> 1A
+//
+// additionally, for dealing with raw binary data we have an escape sequence
+// to pack base64 encoded runs:
+//
+// - \cz\xNN -> followed by NN-0x1f (31 decimal) bytes of base64 encoded
+// data. supported range: 0x20 .. 0x9f (1-128 bytes data)
+//
function h$encodePackedUtf8(str) {
return h$encodeUtf8Internal(str, false, true);
}
@@ -759,6 +728,30 @@ function h$appendToHsStringA(str, appendTo) {
return r;
}
+// unpack utf8 string, append to existing Haskell string
+#ifdef GHCJS_PROF
+function h$appendToHsString(str, appendTo, cc) {
+#else
+function h$appendToHsString(str, appendTo) {
+#endif
+ var i = str.length - 1;
+ // we need to make an updatable thunk here
+ // if we embed the given closure in a CONS cell.
+ // (#24495)
+ var r = i == 0 ? appendTo : MK_UPD_THUNK(appendTo);
+ while(i>=0) {
+ // Copied from h$toHsString
+ var cp = str.charCodeAt(i);
+ if(cp >= 0xDC00 && cp <= 0xDFFF && i > 0) {
+ --i;
+ cp = (cp - 0xDC00) + (str.charCodeAt(i) - 0xD800) * 1024 + 0x10000;
+ }
+ r = MK_CONS_CC(cp, r, cc);
+ --i;
+ }
+ return r;
+}
+
// throw e wrapped in a GHCJS.Prim.JSException in the current thread
function h$throwJSException(e) {
// create a JSException object and wrap it in a SomeException
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/854f7ee90cd86fea634d23450805e590385c57c0...ae9b18fd3d13642423424f980b5c61866d40f453
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/854f7ee90cd86fea634d23450805e590385c57c0...ae9b18fd3d13642423424f980b5c61866d40f453
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/20241112/30dd30d0/attachment-0001.html>
More information about the ghc-commits
mailing list