[Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328)
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Mon May 1 08:40:05 UTC 2023
Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC
Commits:
24d527f4 by Josh Meredith at 2023-05-01T08:39:50+00:00
JS: refactor jsSaturate to return a saturated JStat (#23328)
- - - - -
6 changed files:
- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/FFI.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Monad.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
Changes:
=====================================
compiler/GHC/JS/Transform.hs
=====================================
@@ -22,7 +22,6 @@ module GHC.JS.Transform
, composOpM_
, composOpFold
, satJExpr
- , satJStat
)
where
@@ -200,8 +199,8 @@ jmcompos ret app f' v =
-- | Given an optional prefix, fills in all free variable names with a supply
-- of names generated by the prefix.
-jsSaturate :: (JMacro a) => Maybe FastString -> a -> a
-jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str)
+jsSaturate' :: (JMacro a) => Maybe FastString -> a -> a
+jsSaturate' str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str)
jsSaturate_ :: (JMacro a) => a -> IdentSupply a
jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
@@ -219,9 +218,9 @@ jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
--
-- This will be moved after GHC.JS.Syntax is removed
--------------------------------------------------------------------------------
-satJStat :: JStat -> Sat.JStat
-satJStat = witness . proof
- where proof = jsSaturate Nothing
+jsSaturate :: Maybe FastString -> JStat -> Sat.JStat
+jsSaturate str = witness . proof str
+ where proof = jsSaturate'
-- This is an Applicative but we can't use it because no type variables :(
witness :: JStat -> Sat.JStat
@@ -315,5 +314,5 @@ satJVal = go
go (JStr f) = Sat.JStr f
go (JRegEx f) = Sat.JRegEx f
go (JHash m) = Sat.JHash (satJExpr <$> m)
- go (JFunc args body) = Sat.JFunc args (satJStat body)
+ go (JFunc args body) = Sat.JFunc args (jsSaturate Nothing body)
go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly"
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -134,7 +134,6 @@ genUnits m ss spt_entries foreign_stubs = do
staticInit <-
initStaticPtrs spt_entries
let stat = ( -- O.optimize .
- satJStat .
jsSaturate (Just $ modulePrefix m 1)
$ mconcat (reverse glbl) <> staticInit)
let syms = [moduleGlobalSymbol m]
@@ -208,7 +207,7 @@ genUnits m ss spt_entries foreign_stubs = do
_extraTl <- State.gets (ggsToplevelStats . gsGroup)
si <- State.gets (ggsStatic . gsGroup)
let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
- let stat = satJStat $ jsSaturate (Just $ modulePrefix m n) body
+ let stat = jsSaturate (Just $ modulePrefix m n) body
let ids = [bnd]
syms <- (\(TxtI i) -> [i]) <$> identForId bnd
let oi = ObjUnit
@@ -246,7 +245,6 @@ genUnits m ss spt_entries foreign_stubs = do
topDeps = collectTopIds decl
required = hasExport decl
stat = -- Opt.optimize .
- satJStat .
jsSaturate (Just $ modulePrefix m n)
$ mconcat (reverse extraTl) <> tl
syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps
=====================================
compiler/GHC/StgToJS/FFI.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Prelude
import GHC.JS.Unsat.Syntax
import GHC.JS.Make
import GHC.JS.Transform
+import qualified GHC.JS.Syntax as Sat
import GHC.StgToJS.Arg
import GHC.StgToJS.ExprCtx
@@ -176,7 +177,7 @@ genFFIArg isJavaScriptCc a@(StgVarArg i)
arg_ty = stgArgType a
r = uTypeVt arg_ty
-saturateFFI :: JMacro a => Int -> a -> a
+saturateFFI :: Int -> JStat -> Sat.JStat
saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u)
genForeignCall :: HasDebugCallStack
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -332,7 +332,7 @@ renderLinker h mods jsFiles = do
pure (mod_mod, mod_size)
-- commoned up metadata
- !meta_length <- fromIntegral <$> putJS (satJStat meta)
+ !meta_length <- fromIntegral <$> putJS (jsSaturate Nothing meta)
-- module exports
mapM_ (putBS . cmc_exports) compacted_mods
=====================================
compiler/GHC/StgToJS/Monad.hs
=====================================
@@ -25,6 +25,7 @@ where
import GHC.Prelude
import GHC.JS.Unsat.Syntax
+import qualified GHC.JS.Syntax as Sat
import GHC.JS.Transform
import GHC.StgToJS.Types
@@ -160,7 +161,7 @@ data GlobalOcc = GlobalOcc
-- | Return number of occurrences of every global id used in the given JStat.
-- Sort by increasing occurrence count.
-globalOccs :: JStat -> G [GlobalOcc]
+globalOccs :: Sat.JStat -> G [GlobalOcc]
globalOccs jst = do
GlobalIdCache gidc <- getGlobalIdCache
-- build a map form Ident Unique to (Ident, Id, Count)
@@ -180,4 +181,4 @@ globalOccs jst = do
let g = GlobalOcc i gid 1
in go (addToUFM_C inc gids i g) is
- pure $ go emptyUFM (identsS $ satJStat jst)
+ pure $ go emptyUFM (identsS jst)
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -30,6 +30,7 @@ import GHC.Prelude
import GHC.JS.Unsat.Syntax
import GHC.JS.Make
import GHC.JS.Transform
+import qualified GHC.JS.Syntax as Sat
import GHC.StgToJS.Apply
import GHC.StgToJS.Closure
@@ -298,7 +299,7 @@ closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> clo
ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
-- | JS payload declaring the RTS functions.
-rtsDecls :: JStat
+rtsDecls :: Sat.JStat
rtsDecls = jsSaturate (Just "h$RTSD") $
mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread
, TxtI "h$stack" ||= null_ -- stack for the current thread
@@ -314,14 +315,14 @@ rtsDecls = jsSaturate (Just "h$RTSD") $
-- | print the embedded RTS to a String
rtsText :: StgToJSConfig -> String
-rtsText = show . pretty . satJStat . rts
+rtsText = show . pretty . rts
-- | print the RTS declarations to a String.
rtsDeclsText :: String
-rtsDeclsText = show . pretty . satJStat $ rtsDecls
+rtsDeclsText = show . pretty $ rtsDecls
-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
-rts :: StgToJSConfig -> JStat
+rts :: StgToJSConfig -> Sat.JStat
rts = jsSaturate (Just "h$RTS") . rts'
-- | JS Payload which defines the embedded RTS.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d527f470b0533ed3618e8094f0d0a512b2a291
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24d527f470b0533ed3618e8094f0d0a512b2a291
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/20230501/d805db46/attachment-0001.html>
More information about the ghc-commits
mailing list