[Git][ghc/ghc][wip/js-staging] StgToJS.Stack: Docs and cleanup

doyougnu (@doyougnu) gitlab at gitlab.haskell.org
Fri Sep 30 11:20:17 UTC 2022



doyougnu pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC


Commits:
36c7ed0b by doyougnu at 2022-09-30T07:19:34-04:00
StgToJS.Stack: Docs and cleanup

In particular:

-- Removing some single use functions
-- Some minor refactors related to these removals

- - - - -


3 changed files:

- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Stack.hs


Changes:

=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -740,7 +740,7 @@ stackApply s fun_name nargs nvars =
                ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)])
              ]
 
-    funExact c = popSkip' 1 (reverse $ take nvars jsRegsFromR2) <> returnS c
+    funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c
     stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars]
 
     papCase :: JExpr -> JStat


=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -644,13 +644,24 @@ genRet ctx e at as l = freshIdent >>= f
       MultiValAlt _n -> idVt e
       _              -> [PtrV]
 
+    -- special case for popping CCS but preserving stack size
+    pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
+    pop_handle_CCS [] = return mempty
+    pop_handle_CCS xs = do
+      -- grab the slots from 'xs' and push
+      addSlots (map snd xs)
+      -- move the stack pointer into the stack by ''length xs + n'
+      a <- adjSpN (length xs)
+      -- now load from the top of the stack
+      return (loadSkip 0 (map fst xs) <> a)
+
     fun free = resetSlots $ do
       decs          <- declVarsForId e
       load          <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e
       loadv         <- verifyRuntimeReps [e]
       ras           <- loadRetArgs free
       rasv          <- verifyRuntimeReps (map (\(x,_,_)->x) free)
-      restoreCCS    <- ifProfilingM $ popUnknown [jCurrentCCS]
+      restoreCCS    <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown)
       rlne          <- popLneFrame False lneLive ctx'
       rlnev         <- verifyRuntimeReps lneVars
       (alts, _altr) <- genAlts ctx' e at Nothing as


=====================================
compiler/GHC/StgToJS/Stack.hs
=====================================
@@ -1,7 +1,30 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 
--- | Stack manipulation
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.JS.Stack
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Jeffrey Young  <jeffrey.young at iohk.io>
+--                Luite Stegeman <luite.stegeman at iohk.io>
+--                Sylvain Henry  <sylvain.henry at iohk.io>
+--                Josh Meredith  <josh.meredith at iohk.io>
+-- Stability   :  experimental
+--
+-- Utilities and wrappers for Stack manipulation in JS Land.
+--
+-- In general, functions suffixed with a tick do the actual work, functions
+-- suffixed with an "I" are identical to the non-I versions but work on 'Ident's
+--
+-- The stack in JS land is held in the special variable 'h$stack' and the stack
+-- pointer is held in 'h$sp'. The top of the stack thus exists at
+-- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack
+-- into older entries, whereas h$stack[h$sp - i] moves towards the top of the
+-- stack.
+-----------------------------------------------------------------------------
+
 module GHC.StgToJS.Stack
   ( resetSlots
   , isolateSlots
@@ -10,7 +33,6 @@ module GHC.StgToJS.Stack
   , addSlots
   , dropSlots
   , addUnknownSlots
-  , adjPushStack
   , push
   , push'
   , adjSpN
@@ -24,12 +46,8 @@ module GHC.StgToJS.Stack
   , pushOptimized'
   , pushOptimized
   , pushLneFrame
-  , pop
-  , popn
-  , popUnknown
-  , popSkipUnknown
+  , popN
   , popSkip
-  , popSkip'
   , popSkipI
   , loadSkip
   -- * Thunk update
@@ -62,7 +80,7 @@ import Data.Array
 import Data.Monoid
 import Control.Monad
 
--- | Run the action with no stack info
+-- | Run the action, 'm', with no stack info
 resetSlots :: G a -> G a
 resetSlots m = do
   s <- getSlots
@@ -73,7 +91,8 @@ resetSlots m = do
   setStackDepth d
   return a
 
--- | run the action with current stack info, but don't let modifications propagate
+-- | run the action, 'm', with current stack info, but don't let modifications
+-- propagate
 isolateSlots :: G a -> G a
 isolateSlots m = do
   s <- getSlots
@@ -117,14 +136,10 @@ addSlots xs = do
   s <- getSlots
   setSlots (xs ++ s)
 
+-- | drop 'n' slots from our stack knowledge
 dropSlots :: Int -> G ()
 dropSlots n = modifySlots (drop n)
 
-adjPushStack :: Int -> G ()
-adjPushStack n = do
-  modifyStackDepth (+n)
-  dropSlots n
-
 push :: [JExpr] -> G JStat
 push xs = do
   dropSlots (length xs)
@@ -137,42 +152,85 @@ push' cs xs
    | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items
    | otherwise                          = ApplStat (toJExpr $ pushN ! l) xs
   where
-    items = zipWith (\i e -> AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e))
-                    [(1::Int)..] xs
+    items = zipWith f [(1::Int)..] xs
     offset i | i == l    = sp
              | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
     l = length xs
+    f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e)
 
 
+-- | Grow the stack pointer by 'n' without modifying the stack depth. The stack
+-- is just a JS array so we add to grow (instead of the traditional subtract)
 adjSp' :: Int -> JStat
 adjSp' 0 = mempty
 adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n)
 
+-- | Shrink the stack pointer by 'n'. The stack grows downward so substract
 adjSpN' :: Int -> JStat
 adjSpN' 0 = mempty
 adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n)
 
+-- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth
+-- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer
+-- manipulation.
 adjSp :: Int -> G JStat
 adjSp 0 = return mempty
 adjSp n = do
+  -- grow depth by n
   modifyStackDepth (+n)
   return (adjSp' n)
 
+-- | Shrink the stack and stack pointer. NB: This function is unsafe when the
+-- input 'n', is negative. This function wraps around 'adjSpN' which actually
+-- performs the work.
 adjSpN :: Int -> G JStat
 adjSpN 0 = return mempty
 adjSpN n = do
   modifyStackDepth (\x -> x - n)
   return (adjSpN' n)
 
+-- | A constant array that holds global function symbols which do N pushes onto
+-- the stack. For example:
+-- @
+-- function h$p1(x1) {
+--   ++h$sp;
+--   h$stack[(h$sp - 0)] = x1;
+-- };
+-- function h$p2(x1, x2) {
+--   h$sp += 2;
+--   h$stack[(h$sp - 1)] = x1;
+--   h$stack[(h$sp - 0)] = x2;
+-- };
+-- @
+--
+-- and so on up to 32.
 pushN :: Array Int Ident
 pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32]
 
+-- | Convert all function symbols in 'pushN' to global top-level functions. This
+-- is a hack which converts the function symbols to variables. This hack is
+-- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global
+-- functions.
 pushN' :: Array Int JExpr
 pushN' = fmap (ValExpr . JVar) pushN
+  where
 
+-- | Partial Push functions. Like 'pushN' except these push functions skip
+-- slots. For example,
+-- @
+-- function h$pp33(x1, x2) {
+--   h$sp += 6;
+--   h$stack[(h$sp - 5)] = x1;
+--   h$stack[(h$sp - 0)] = x2;
+-- };
+-- @
+--
+-- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th
+-- slot.
 pushNN :: Array Integer Ident
 pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255]
 
+-- | Like 'pushN'' but for the partial push functions
 pushNN' :: Array Integer JExpr
 pushNN' = fmap (ValExpr . JVar) pushNN
 
@@ -216,82 +274,67 @@ pushOptimized xs = do
     offset i | i == l    = sp
              | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
 
+-- | push a let-no-escape frame onto the stack
 pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
 pushLneFrame size ctx =
   let ctx' = ctxLneShrinkStack ctx size
   in pushOptimized' (ctxLneFrameVars ctx')
 
-popUnknown :: [JExpr] -> G JStat
-popUnknown xs = popSkipUnknown 0 xs
-
-popSkipUnknown :: Int -> [JExpr] -> G JStat
-popSkipUnknown n xs = popSkip n (map (,SlotUnknown) xs)
-
-pop :: [(JExpr,StackSlot)] -> G JStat
-pop = popSkip 0
-
--- | pop the expressions, but ignore the top n elements of the stack
-popSkip :: Int -> [(JExpr,StackSlot)] -> G JStat
-popSkip 0 [] = pure mempty
-popSkip n [] = addUnknownSlots n >> adjSpN n
-popSkip n xs = do
-  addUnknownSlots n
-  addSlots (map snd xs)
-  a <- adjSpN (length xs + n)
-  return (loadSkip n (map fst xs) <> a)
-
--- | pop things, don't upstate stack knowledge
-popSkip' :: Int     -- ^ number of slots to skip
+-- | Pop things, don't update the stack knowledge in 'G'
+popSkip :: Int     -- ^ number of slots to skip
          -> [JExpr] -- ^ assign stack slot values to these
          -> JStat
-popSkip' 0 []  = mempty
-popSkip' n []  = adjSpN' n
-popSkip' n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
+popSkip 0 []  = mempty
+popSkip n []  = adjSpN' n
+popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
 
--- | like popSkip, but without modifying the stack pointer
+-- | Load 'length (xs :: [JExpr])' things from the stack at offset 'n :: Int'.
+-- This function does no stack pointer manipulation, it merely indexes into the
+-- stack and loads payloads into 'xs'.
 loadSkip :: Int -> [JExpr] -> JStat
 loadSkip = loadSkipFrom sp
-
-loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
-loadSkipFrom fr n xs = mconcat items
-    where
-      items = reverse $ zipWith (\i ex -> ex |= IdxExpr stack (toJExpr (offset (i+n))))
-                                [(0::Int)..]
-                                (reverse xs)
-      offset 0 = toJExpr fr
-      offset n = InfixExpr SubOp (toJExpr fr) (toJExpr n)
-
-
--- declare and pop
+  where
+    loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
+    loadSkipFrom fr n xs = mconcat items
+      where
+        items = reverse $ zipWith f [(0::Int)..] (reverse xs)
+        -- helper to generate sp - n offset to index with
+        offset 0 = fr
+        offset n = InfixExpr SubOp fr  (toJExpr n)
+        -- helper to load stack .! i into ex, e.g., ex = stack[i]
+        f i ex   = ex |= IdxExpr stack (toJExpr (offset (i+n)))
+
+
+-- | Pop but preserve the first N slots
 popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat
 popSkipI 0 [] = pure mempty
-popSkipI n [] = adjSpN n
+popSkipI n [] = popN n
 popSkipI n xs = do
+  -- add N unknown slots
   addUnknownSlots n
+  -- now add the slots from xs, after this line the stack should look like
+  -- [xs] ++ [Unknown...] ++ old_stack
   addSlots (map snd xs)
+  -- move stack pointer into the stack by (length xs + n), basically resetting
+  -- the stack pointer
   a <- adjSpN (length xs + n)
+  -- now load skipping first N slots
   return (loadSkipI n (map fst xs) <> a)
 
--- like popSkip, but without modifying sp
+-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr'
 loadSkipI :: Int -> [Ident] -> JStat
 loadSkipI = loadSkipIFrom sp
-
-loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
-loadSkipIFrom fr n xs = mconcat items
-    where
-      items = reverse $ zipWith f [(0::Int)..] (reverse xs)
-      offset 0 = fr
-      offset n = InfixExpr SubOp fr (toJExpr n)
-      f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n)))
-
-popn :: Int -> G JStat
-popn n = addUnknownSlots n >> adjSpN n
-
-updateThunk' :: StgToJSConfig -> JStat
-updateThunk' settings =
-  if csInlineBlackhole settings
-    then bhStats settings True
-    else ApplStat (var "h$bh") []
+  where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
+        loadSkipIFrom fr n xs = mconcat items
+          where
+            items = reverse $ zipWith f [(0::Int)..] (reverse xs)
+            offset 0 = fr
+            offset n = InfixExpr SubOp fr (toJExpr n)
+            f i ex   = ex ||= IdxExpr stack (toJExpr (offset (i+n)))
+
+-- | Blindly pop N slots
+popN :: Int -> G JStat
+popN n = addUnknownSlots n >> adjSpN n
 
 -- | Generate statements to update the current node with a blackhole
 bhStats :: StgToJSConfig -> Bool -> JStat
@@ -302,8 +345,23 @@ bhStats s pushUpd = mconcat
   , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array
   ]
 
+-- | Wrapper around 'updateThunk'', performs the stack manipulation before
+-- updating the Thunk.
 updateThunk :: G JStat
 updateThunk = do
   settings <- getSettings
-  adjPushStack 2 -- update frame size
+  -- update frame size
+  let adjPushStack :: Int -> G ()
+      adjPushStack n = do modifyStackDepth (+n)
+                          dropSlots n
+  adjPushStack 2
   return $ (updateThunk' settings)
+
+-- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black
+-- holes then update inline, else make an explicit call to the black hole
+-- handler.
+updateThunk' :: StgToJSConfig -> JStat
+updateThunk' settings =
+  if csInlineBlackhole settings
+    then bhStats settings True
+    else ApplStat (var "h$bh") []



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36c7ed0b2bd2c257b55704015e1b6fee963b33d7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36c7ed0b2bd2c257b55704015e1b6fee963b33d7
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/20220930/fda27771/attachment-0001.html>


More information about the ghc-commits mailing list