diff options
Diffstat (limited to 'compiler/GHC/StgToJS/Stack.hs')
| -rw-r--r-- | compiler/GHC/StgToJS/Stack.hs | 373 |
1 files changed, 373 insertions, 0 deletions
diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs new file mode 100644 index 0000000000..0250837f32 --- /dev/null +++ b/compiler/GHC/StgToJS/Stack.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Stack +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@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 JS array '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. +-- +-- The stack layout algorithm is slightly peculiar. It makes an effort to +-- remember recently popped things so that if these values need to be pushed +-- then they can be quickly. The implementation for this is storing these values +-- above the stack pointer, and the pushing will skip slots that we know we will +-- use and fill in slots marked as unknown. Thus, you may find that our push and +-- pop functions do some non-traditional stack manipulation such as adding slots +-- in pop or removing slots in push. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Stack + ( resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , push + , push' + , adjSpN + , adjSpN' + , adjSp' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , popN + , popSkip + , popSkipI + , loadSkip + -- * Thunk update + , updateThunk + , updateThunk' + , bhStats + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Regs + +import GHC.Types.Id +import GHC.Utils.Misc +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import qualified Data.List as L +import qualified Control.Monad.Trans.State.Strict as State +import Data.Array +import Data.Monoid +import Control.Monad + +-- | Run the action, 'm', with no stack info +resetSlots :: G a -> G a +resetSlots m = do + s <- getSlots + d <- getStackDepth + setSlots [] + a <- m + setSlots s + setStackDepth d + return a + +-- | run the action, 'm', with current stack info, but don't let modifications +-- propagate +isolateSlots :: G a -> G a +isolateSlots m = do + s <- getSlots + d <- getStackDepth + a <- m + setSlots s + setStackDepth d + pure a + +-- | Set stack depth +setStackDepth :: Int -> G () +setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d}) + +-- | Get stack depth +getStackDepth :: G Int +getStackDepth = State.gets (ggsStackDepth . gsGroup) + +-- | Modify stack depth +modifyStackDepth :: (Int -> Int) -> G () +modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) }) + +-- | overwrite our stack knowledge +setSlots :: [StackSlot] -> G () +setSlots xs = modifyGroup (\g -> g { ggsStack = xs}) + +-- | retrieve our current stack knowledge +getSlots :: G [StackSlot] +getSlots = State.gets (ggsStack . gsGroup) + +-- | Modify stack slots +modifySlots :: ([StackSlot] -> [StackSlot]) -> G () +modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)}) + +-- | add `n` unknown slots to our stack knowledge +addUnknownSlots :: Int -> G () +addUnknownSlots n = addSlots (replicate n SlotUnknown) + +-- | add knowledge about the stack slots +addSlots :: [StackSlot] -> G () +addSlots xs = do + s <- getSlots + setSlots (xs ++ s) + +-- | drop 'n' slots from our stack knowledge +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +push :: [JExpr] -> G JStat +push xs = do + dropSlots (length xs) + modifyStackDepth (+ (length xs)) + flip push' xs <$> getSettings + +push' :: StgToJSConfig -> [JExpr] -> JStat +push' _ [] = mempty +push' cs xs + | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items + | otherwise = ApplStat (toJExpr $ pushN ! l) xs + where + 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 + +-- | 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. See 'pushOptimized' and 'pushOptimized'' for use cases. +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 + +pushOptimized' :: [(Id,Int)] -> G JStat +pushOptimized' xs = do + slots <- getSlots + pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) + where + f (i1,n1) xs2 = do + xs <- varsForId i1 + let !id_n1 = xs !! (n1-1) + + case xs2 of + SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2) + _ -> pure (id_n1,False) + +-- | optimized push that reuses existing values on stack automatically chooses +-- an optimized partial push (h$ppN) function when possible. +pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there + -> G JStat +pushOptimized [] = return mempty +pushOptimized xs = do + dropSlots l + modifyStackDepth (+ length xs) + go . csInlinePush <$> getSettings + where + go True = inlinePush + go _ + | all snd xs = adjSp' l + | all (not.snd) xs && l <= 32 = + ApplStat (pushN' ! l) (map fst xs) + | l <= 8 && not (snd $ last xs) = + ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ] + | otherwise = inlinePush + l = length xs + sig :: Integer + sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..] + inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs) + pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex + pushSlot _ _ = mempty + 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') + +-- | 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) + +-- | 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 + 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 [] = 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) + +-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr' +loadSkipI :: Int -> [Ident] -> JStat +loadSkipI = loadSkipIFrom sp + 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 +bhStats s pushUpd = mconcat + [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty + , toJExpr R1 .^ closureEntry_ |= var "h$blackhole" + , toJExpr R1 .^ closureField1_ |= var "h$currentThread" + , 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 + -- 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") [] |