[Git][ghc/ghc][wip/js-staging] 2 commits: Apply: remove commented case (wasn't optimized either in latest ghcjs)
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Mon Aug 15 23:42:43 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
84655973 by Sylvain Henry at 2022-08-15T23:17:13+02:00
Apply: remove commented case (wasn't optimized either in latest ghcjs)
- - - - -
14d2ed4f by Sylvain Henry at 2022-08-16T01:45:30+02:00
Doc: Apply
- - - - -
1 changed file:
- compiler/GHC/StgToJS/Apply.hs
Changes:
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -100,17 +100,6 @@ genApp
-> G (JStat, ExprResult)
genApp ctx i args
--- FIXME (sylvain 2022/02): what's our new equivalent of this?
--- -- special cases for JSString literals
--- -- we could handle unpackNBytes# here, but that's probably not common
--- -- enough to warrant a special case
--- | [StgVarArg v] <- args
--- , [top] <- concatMap snd (ctxTarget ctx)
--- -- , Just (Lit (MachStr bs)) <- expandUnfolding_maybe (idUnfolding v)
--- -- , Just t <- decodeModifiedUTF8 bs -- unpackFS fs -- Just t <- decodeModifiedUTF8 bs
--- , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i =
--- (,ExprInline Nothing) . (|=) top . app "h$decodeUtf8z" <$> varsForId v
-
-- Case: unpackCStringAppend# "some string"# str
--
-- Generates h$appendToHsStringA(str, "some string"), which has a faster
@@ -118,16 +107,15 @@ genApp ctx i args
| [StgLitArg (LitString bs), x] <- args
, [top] <- concatMap typex_expr (ctxTarget ctx)
, getUnique i == unpackCStringAppendIdKey
- -- , Just d <- decodeModifiedUTF8 bs
, d <- utf8DecodeByteString bs
-- FIXME (Sylvain, 2022/02): we assume that it decodes but it may not (e.g. embedded file)
= do
- -- fixme breaks assumption in codegen if bs doesn't decode
prof <- csProf <$> getSettings
let profArg = if prof then [jCafCCS] else []
a <- genArg x
- return (top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg)
- ,ExprInline Nothing)
+ return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg)
+ , ExprInline Nothing
+ )
-- let-no-escape
| Just n <- ctxLneBindingStackSize ctx i
@@ -395,8 +383,11 @@ pushCont as = do
-- efficiently than other more specialized functions.
--
-- Stack layout:
--- 0. tag: (regs << 8 | arity)
--- 1. args
+-- -x: ...
+-- -y: args...
+-- -3: ...
+-- -2: register values to enter R1
+-- -1: tag (number of register values << 8 | number of args)
--
-- Regs:
-- R1 = closure to apply to
@@ -440,51 +431,91 @@ genericStackApply cfg =
, returnS (app "h$blockOnBlackhole" [r1])
]
- fun_case c arity = jVar \myArity ar myAr myRegs regs newTag newAp p dat ->
- [ myArity |= stack .! (sp - 1)
- , ar |= mask8 arity
- , myAr |= mask8 myArity
- , myRegs |= myArity .>>. 8
- , traceRts cfg (jString "h$ap_gen: args: " + myAr
- + jString " regs: " + myRegs)
- , ifBlockS (myAr .===. ar)
- -- then
+ fun_case c arity = jVar \tag needed_args needed_regs given_args given_regs newTag newAp p dat ->
+ [ tag |= stack .! (sp - 1) -- tag on the stack
+ , given_args |= mask8 tag -- indicates the number of passed args
+ , given_regs |= tag .>>. 8 -- and the number of passed values for registers
+ , needed_args |= mask8 arity
+ , needed_regs |= arity .>>. 8
+ , traceRts cfg (jString "h$ap_gen: args: " + given_args
+ + jString " regs: " + given_regs)
+ , ifBlockS (given_args .===. needed_args)
+ --------------------------------
+ -- exactly saturated application
+ --------------------------------
[ traceRts cfg (jString "h$ap_gen: exact")
- , loop 0 (.<. myRegs)
- (\i -> appS "h$setReg" [i+2, stack .! (sp-2-i)]
- <> postIncrS i)
- , (sp |= sp - myRegs - 2)
+ -- Set registers to register values on the stack
+ , loop 0 (.<. given_regs) \i -> mconcat
+ [ appS "h$setReg" [i+2, stack .! (sp-2-i)]
+ , postIncrS i
+ ]
+ -- drop register values from the stack
+ , sp |= sp - given_regs - 2
+ -- enter closure in R1
, returnS c
]
- -- else
- [ ifBlockS (myAr .>. ar)
- --then
- [ regs |= arity .>>. 8
- , traceRts cfg (jString "h$ap_gen: oversat: arity: " + ar
- + jString " regs: " + regs)
- , loop 0 (.<. regs)
- (\i -> traceRts cfg (jString "h$ap_gen: loading register: " + i)
- <> appS "h$setReg" [i+2, stack .! (sp-2-i)]
- <> postIncrS i)
- , newTag |= ((myRegs-regs).<<.8).|.myAr - ar
+ [ ifBlockS (given_args .>. needed_args)
+ ----------------------------
+ -- oversaturated application
+ ----------------------------
+ [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args
+ + jString " regs: " + needed_regs)
+ -- load needed register values
+ , loop 0 (.<. needed_regs) \i -> mconcat
+ [ traceRts cfg (jString "h$ap_gen: loading register: " + i)
+ , appS "h$setReg" [i+2, stack .! (sp-2-i)]
+ , postIncrS i
+ ]
+ -- compute new tag with consumed register values and args removed
+ , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
+ -- find application function for the remaining regs/args
, newAp |= var "h$apply" .! newTag
, traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
+
+ -- Drop used registers from the stack.
+ -- Test if the application function needs a tag and push it.
, ifS (newAp .===. var "h$ap_gen")
- ((sp |= sp - regs) <> (stack .! (sp - 1) |= newTag))
- (sp |= sp - regs - 1)
+ ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
+ (sp |= sp - needed_regs - 1)
+ -- FIXME (Sylvain 2022-08): this is fragile and probably inefficient.
+ -- Instead of filling h$apply array with h$ap_gen, we should leave
+ -- it with empty items and match "undefined" here.
+
+ -- Push generic application function as continuation
, stack .! sp |= newAp
+
+ -- Push "current thread CCS restore" function as continuation
, profStat cfg pushRestoreCCS
+
+ -- enter closure in R1
, returnS c
]
- -- else
+
+ -----------------------------
+ -- undersaturated application
+ -----------------------------
[ traceRts cfg (jString "h$ap_gen: undersat")
- , p |= var "h$paps" .! myRegs
- , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
- , loop 0 (.<. myRegs)
- (\i -> (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)]
- <> postIncrS i)
- , sp |= sp - myRegs - 2
+ -- find PAP entry function corresponding to given_regs count
+ , p |= var "h$paps" .! given_regs
+
+ -- build PAP payload: R1 + tag + given register values
+ , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
+ , dat |= toJExpr [r1, newTag]
+ , loop 0 (.<. given_regs) \i -> mconcat
+ [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)]
+ , postIncrS i
+ ]
+
+ -- remove register values from the stack.
+ , sp |= sp - given_regs - 2
+
+ -- alloc PAP closure, store reference to it in R1.
, r1 |= initClosure cfg p dat jCurrentCCS
+
+ -- FIXME (Sylvain 2022-08): why don't we pop/store the given args
+ -- too?
+
+ -- return to the continuation on the stack
, returnStack
]
]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9716e7f23f01be535a8f211010dd2c5cedb8838d...14d2ed4f1c2f5f4f7c1a480ae40bef5e17879a99
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9716e7f23f01be535a8f211010dd2c5cedb8838d...14d2ed4f1c2f5f4f7c1a480ae40bef5e17879a99
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/20220815/f67b46c4/attachment-0001.html>
More information about the ghc-commits
mailing list