[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 10:26:11 UTC 2023



Josh Meredith pushed to branch wip/jsSaturate at Glasgow Haskell Compiler / GHC


Commits:
721877cf by Josh Meredith at 2023-05-03T10:25:58+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,7 +33,6 @@ import GHC.JS.Unsat.Syntax
 
 import Data.Functor.Identity
 import Control.Monad
-import Control.Arrow ((***))
 
 import GHC.Data.FastString
 import GHC.Utils.Monad.State.Strict
@@ -200,66 +199,61 @@ 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 m   -> return $ Sat.JHash (satJExpr <$> m)
+  JFunc args body -> Sat.JFunc args <$> jsSaturateS body
+  UnsatVal us     -> jsSaturateV =<< runIdentSupply us
+  
 
 --------------------------------------------------------------------------------
 --                            Translation
 --
 -- 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 +299,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/721877cffd0db35e95f1dd93a176baa35232c5d3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/721877cffd0db35e95f1dd93a176baa35232c5d3
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/d445a0c1/attachment-0001.html>


More information about the ghc-commits mailing list