[Git][ghc/ghc][wip/jsSaturate] JS: refactor jsSaturate to return a saturated JStat (#23328)

Josh Meredith (@JoshMeredith) gitlab at gitlab.haskell.org
Mon May 8 10:45:49 UTC 2023



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


Commits:
47e635e7 by Josh Meredith at 2023-05-08T10:45:33+00:00
JS: refactor jsSaturate to return a saturated JStat (#23328)

- - - - -


9 changed files:

- compiler/GHC/JS/Transform.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/CoreUtils.hs
- compiler/GHC/StgToJS/DataCon.hs
- compiler/GHC/StgToJS/Expr.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,13 +6,15 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TupleSections #-}
 
 module GHC.JS.Transform
   ( identsS
   , identsV
   , identsE
   -- * Saturation
-  , jsSaturate
+  , satJStat
+  , satJExpr
   -- * Generic traversal (via compos)
   , JMacro(..)
   , JMGadt(..)
@@ -21,8 +23,6 @@ module GHC.JS.Transform
   , composOpM
   , 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,66 +201,59 @@ 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)
+satJStat :: Maybe FastString -> JStat -> Sat.JStat
+satJStat str x = evalState (jsSaturateS x) (newIdentSupply str)
+
+satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr
+satJExpr str x = evalState (jsSaturateE 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   -> Sat.JHash <$> mapUniqMapM satHash m
     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
-
-
---------------------------------------------------------------------------------
---                            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"
+      satHash (i, x) = (i,) . (i,) <$> jsSaturateE x
+      compareHash (i,_) (j,_) = lexicalCompareFS i j
+      -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided
+      mapUniqMapM f (UniqMap m) = UniqMap . listToUFM <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m)
+  JFunc args body   -> Sat.JFunc args <$> jsSaturateS body
+  UnsatVal us       -> jsSaturateV =<< runIdentSupply us
 
 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,8 +134,7 @@ genUnits m ss spt_entries foreign_stubs = do
         staticInit <-
           initStaticPtrs spt_entries
         let stat = ( -- O.optimize .
-                     satJStat .
-                     jsSaturate (Just $ modulePrefix m 1)
+                     satJStat (Just $ modulePrefix m 1)
                    $ mconcat (reverse glbl) <> staticInit)
         let syms = [moduleGlobalSymbol m]
         let oi = ObjUnit
@@ -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 = satJStat (Just $ modulePrefix m n) body
               let ids = [bnd]
               syms <- (\(TxtI i) -> [i]) <$> identForId bnd
               let oi = ObjUnit
@@ -246,8 +245,7 @@ genUnits m ss spt_entries foreign_stubs = do
               topDeps  = collectTopIds decl
               required = hasExport decl
               stat     = -- Opt.optimize .
-                         satJStat .
-                         jsSaturate (Just $ modulePrefix m n)
+                         satJStat (Just $ modulePrefix m n)
                        $ mconcat (reverse extraTl) <> tl
           syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps
           let oi = ObjUnit
@@ -336,7 +334,7 @@ genToplevelRhs i rhs = case rhs of
     eid@(TxtI eidt) <- identForEntryId i
     (TxtI idt)   <- identForId i
     body <- genBody (initExprCtx i) R2 args body typ
-    global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body)
+    global_occs <- globalOccs (satJStat (Just "ghcjs_tmp_sat_") body)
     let lidents = map global_ident global_occs
     let lids    = map global_id    global_occs
     let lidents' = map identFS lidents


=====================================
compiler/GHC/StgToJS/CoreUtils.hs
=====================================
@@ -253,7 +253,7 @@ assocPrimReps (r:rs) vs = case (primRepSize r,vs) of
   (NoSlot,   xs)     -> (r,[])    : assocPrimReps rs xs
   (OneSlot,  x:xs)   -> (r,[x])   : assocPrimReps rs xs
   (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs
-  err                -> pprPanic "assocPrimReps" (ppr $ fmap (map satJExpr) $ err)
+  err                -> pprPanic "assocPrimReps" (ppr $ map (satJExpr Nothing) <$> err)
 
 -- | Associate the given values to the Id's PrimReps, taking into account the
 -- number of slots per PrimRep


=====================================
compiler/GHC/StgToJS/DataCon.hs
=====================================
@@ -60,8 +60,8 @@ genCon ctx con args
 
   | xs <- concatMap typex_expr (ctxTarget ctx)
   = pprPanic "genCon: unhandled DataCon" (ppr (con
-                                              , fmap satJExpr args
-                                              , fmap satJExpr xs
+                                              , satJExpr Nothing <$> args
+                                              , satJExpr Nothing <$> xs
                                               ))
 
 -- | Allocate a data constructor. Allocate in this context means bind the data
@@ -90,7 +90,7 @@ allocUnboxedCon con = \case
     | isBoolDataCon con && dataConTag con == 2 -> true_
   [x]
     | isUnboxableCon con -> x
-  xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, fmap satJExpr xs))
+  xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, satJExpr Nothing <$> xs))
 
 -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
 allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig


=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -900,7 +900,7 @@ caseCond = \case
   DataAlt da -> return $ Just (toJExpr $ dataConTag da)
   LitAlt l   -> genLit l >>= \case
     [e] -> pure (Just e)
-    es  -> pprPanic "caseCond: expected single-variable literal" (ppr $ fmap satJExpr es)
+    es  -> pprPanic "caseCond: expected single-variable literal" (ppr $ satJExpr Nothing <$> es)
 
 -- fixme use single tmp var for all branches
 -- | Load parameters from constructor


=====================================
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,8 +177,8 @@ genFFIArg isJavaScriptCc a@(StgVarArg i)
      arg_ty = stgArgType a
      r      = uTypeVt arg_ty
 
-saturateFFI :: JMacro a => Int -> a -> a
-saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u)
+saturateFFI :: Int -> JStat -> Sat.JStat
+saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u)
 
 genForeignCall :: HasDebugCallStack
                => ExprCtx


=====================================
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 (satJStat 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,8 +299,8 @@ 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 = jsSaturate (Just "h$RTSD") $
+rtsDecls :: Sat.JStat
+rtsDecls = satJStat (Just "h$RTSD") $
   mconcat [ TxtI "h$currentThread"   ||= null_                   -- thread state object for current thread
           , TxtI "h$stack"           ||= null_                   -- stack for the current thread
           , TxtI "h$sp"              ||= 0                       -- stack pointer for the current thread
@@ -314,15 +315,15 @@ 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 = jsSaturate (Just "h$RTS") . rts'
+rts :: StgToJSConfig -> Sat.JStat
+rts = satJStat (Just "h$RTS") . rts'
 
 -- | JS Payload which defines the embedded RTS.
 rts' :: StgToJSConfig -> JStat



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47e635e7b1a24e359ddd914086757b6b6640cc7c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47e635e7b1a24e359ddd914086757b6b6640cc7c
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/20230508/4b14245f/attachment-0001.html>


More information about the ghc-commits mailing list