[Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328)
Josh Meredith (@JoshMeredith)
gitlab at gitlab.haskell.org
Wed May 3 11:34:14 UTC 2023
Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC
Commits:
2f81fe5a by Josh Meredith at 2023-05-03T11:34:04+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
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TupleSections #-}
module GHC.JS.Transform
( identsS
@@ -22,7 +23,6 @@ module GHC.JS.Transform
, composOpM_
, composOpFold
, satJExpr
- , satJStat
)
where
@@ -33,11 +33,12 @@ import GHC.JS.Unsat.Syntax
import Data.Functor.Identity
import Control.Monad
-import Control.Arrow ((***))
+import Data.List (sortBy)
import GHC.Data.FastString
import GHC.Utils.Monad.State.Strict
import GHC.Types.Unique.Map
+import GHC.Types.Unique.FM
{-# INLINE identsS #-}
@@ -200,18 +201,53 @@ 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) => a -> IdentSupply a
-jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
- where
- go :: forall a. JMGadt a -> State [Ident] (JMGadt a)
- go v = case v of
- JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us)
- JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us)
- JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us)
- _ -> composOpM go v
+jsSaturate :: Maybe FastString -> JStat -> Sat.JStat
+jsSaturate str x = evalState (jsSaturateS x) (newIdentSupply str)
+
+jsSaturateS :: JStat -> State [Ident] Sat.JStat
+jsSaturateS = \case
+ DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs
+ ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e
+ IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e
+ WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e
+ ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body
+ SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct
+ <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps
+ <*> jsSaturateS def
+ TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f
+ BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs
+ ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand
+ UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand
+ AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> jsSaturateE rhs
+ LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt
+ BreakStat m_l -> return $ Sat.BreakStat $! m_l
+ ContinueStat m_l -> return $ Sat.ContinueStat $! m_l
+ UnsatBlock us -> jsSaturateS =<< runIdentSupply us
+
+jsSaturateE :: JExpr -> State [Ident] Sat.JExpr
+jsSaturateE = \case
+ ValExpr v -> Sat.ValExpr <$> jsSaturateV v
+ SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i
+ IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i
+ InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r
+ UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r
+ IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e
+ ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands
+ UnsatExpr us -> jsSaturateE =<< runIdentSupply us
+
+jsSaturateV :: JVal -> State [Ident] Sat.JVal
+jsSaturateV = \case
+ JVar i -> return $ Sat.JVar i
+ JList xs -> Sat.JList <$> mapM jsSaturateE xs
+ JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d))
+ JInt i -> return $ Sat.JInt i
+ JStr s -> return $ Sat.JStr s
+ JRegEx f -> return $ Sat.JRegEx f
+ JHash (UniqMap m) -> Sat.JHash . UniqMap . listToUFM
+ <$> ( mapM (\(f, x) -> jsSaturateE x >>= \x' -> return (f, (f, x')) )
+ . sortBy (\x y -> fst x `lexicalCompareFS` fst y) $ nonDetEltsUFM m )
+ JFunc args body -> Sat.JFunc args <$> jsSaturateS body
+ UnsatVal us -> jsSaturateV =<< runIdentSupply us
--------------------------------------------------------------------------------
@@ -219,47 +255,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
-
- -- This is an Applicative but we can't use it because no type variables :(
- witness :: JStat -> Sat.JStat
- witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs)
- witness (ReturnStat e) = Sat.ReturnStat (satJExpr e)
- witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e)
- witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e)
- witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i
- (satJExpr iter)
- (witness body)
- witness (SwitchStat struct ps def) = Sat.SwitchStat
- (satJExpr struct)
- (map (satJExpr *** witness) ps)
- (witness def)
- witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f)
- witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs
- witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand)
- witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand)
- witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) (satJExpr rhs)
- witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt)
- witness (BreakStat Nothing) = Sat.BreakStat Nothing
- witness (BreakStat (Just l)) = Sat.BreakStat $! Just l
- witness (ContinueStat Nothing) = Sat.ContinueStat Nothing
- witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l
- witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly"
-
satJExpr :: JExpr -> Sat.JExpr
-satJExpr = go
- where
- go (ValExpr v) = Sat.ValExpr (satJVal v)
- go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i
- go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i)
- go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r)
- go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r)
- go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e)
- go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands)
- go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly"
+satJExpr x = evalState (jsSaturateE x) (newIdentSupply $ error "satJExpr: discovered an Unsat...impossibly")
satJOp :: JOp -> Sat.Op
satJOp = go
@@ -305,15 +303,3 @@ satJUOp = go
go PreDecOp = Sat.PreDecOp
go PostDecOp = Sat.PostDecOp
-satJVal :: JVal -> Sat.JVal
-satJVal = go
- where
- go (JVar i) = Sat.JVar i
- go (JList xs) = Sat.JList (satJExpr <$> xs)
- go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d))
- go (JInt i) = Sat.JInt i
- 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 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/2f81fe5a13703ae2d57470238396f5d12bdce0cf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f81fe5a13703ae2d57470238396f5d12bdce0cf
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/20230503/187df215/attachment-0001.html>
More information about the ghc-commits
mailing list