{-# 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 :: forall a. G a -> G a
resetSlots G a
m = do
  [StackSlot]
s <- G [StackSlot]
getSlots
  Int
d <- G Int
getStackDepth
  [StackSlot] -> G ()
setSlots []
  a
a <- G a
m
  [StackSlot] -> G ()
setSlots [StackSlot]
s
  Int -> G ()
setStackDepth Int
d
  a -> G a
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | run the action, 'm', with current stack info, but don't let modifications
-- propagate
isolateSlots :: G a -> G a
isolateSlots :: forall a. G a -> G a
isolateSlots G a
m = do
  [StackSlot]
s <- G [StackSlot]
getSlots
  Int
d <- G Int
getStackDepth
  a
a <- G a
m
  [StackSlot] -> G ()
setSlots [StackSlot]
s
  Int -> G ()
setStackDepth Int
d
  a -> G a
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | Set stack depth
setStackDepth :: Int -> G ()
setStackDepth :: Int -> G ()
setStackDepth Int
d = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
s -> GenGroupState
s { ggsStackDepth = d})

-- | Get stack depth
getStackDepth :: G Int
getStackDepth :: G Int
getStackDepth = (GenState -> Int) -> G Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> Int
ggsStackDepth (GenGroupState -> Int)
-> (GenState -> GenGroupState) -> GenState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)

-- | Modify stack depth
modifyStackDepth :: (Int -> Int) -> G ()
modifyStackDepth :: (Int -> Int) -> G ()
modifyStackDepth Int -> Int
f = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
s -> GenGroupState
s { ggsStackDepth = f (ggsStackDepth s) })

-- | overwrite our stack knowledge
setSlots :: [StackSlot] -> G ()
setSlots :: [StackSlot] -> G ()
setSlots [StackSlot]
xs = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
g -> GenGroupState
g { ggsStack = xs})

-- | retrieve our current stack knowledge
getSlots :: G [StackSlot]
getSlots :: G [StackSlot]
getSlots = (GenState -> [StackSlot]) -> G [StackSlot]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets (GenGroupState -> [StackSlot]
ggsStack (GenGroupState -> [StackSlot])
-> (GenState -> GenGroupState) -> GenState -> [StackSlot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenState -> GenGroupState
gsGroup)

-- | Modify stack slots
modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
modifySlots [StackSlot] -> [StackSlot]
f = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
g -> GenGroupState
g { ggsStack = f (ggsStack g)})

-- | add `n` unknown slots to our stack knowledge
addUnknownSlots :: Int -> G ()
addUnknownSlots :: Int -> G ()
addUnknownSlots Int
n = [StackSlot] -> G ()
addSlots (Int -> StackSlot -> [StackSlot]
forall a. Int -> a -> [a]
replicate Int
n StackSlot
SlotUnknown)

-- | add knowledge about the stack slots
addSlots :: [StackSlot] -> G ()
addSlots :: [StackSlot] -> G ()
addSlots [StackSlot]
xs = do
  [StackSlot]
s <- G [StackSlot]
getSlots
  [StackSlot] -> G ()
setSlots ([StackSlot]
xs [StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++ [StackSlot]
s)

-- | drop 'n' slots from our stack knowledge
dropSlots :: Int -> G ()
dropSlots :: Int -> G ()
dropSlots Int
n = ([StackSlot] -> [StackSlot]) -> G ()
modifySlots (Int -> [StackSlot] -> [StackSlot]
forall a. Int -> [a] -> [a]
drop Int
n)

push :: [JExpr] -> G JStat
push :: [JExpr] -> G JStat
push [JExpr]
xs = do
  Int -> G ()
dropSlots ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
xs)
  (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
xs))
  (StgToJSConfig -> [JExpr] -> JStat)
-> [JExpr] -> StgToJSConfig -> JStat
forall a b c. (a -> b -> c) -> b -> a -> c
flip StgToJSConfig -> [JExpr] -> JStat
push' [JExpr]
xs (StgToJSConfig -> JStat)
-> StateT GenState IO StgToJSConfig -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings

push' :: StgToJSConfig -> [JExpr] -> JStat
push' :: StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
_ [] = JStat
forall a. Monoid a => a
mempty
push' StgToJSConfig
cs [JExpr]
xs
   | StgToJSConfig -> Bool
csInlinePush StgToJSConfig
cs Bool -> Bool -> Bool
|| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
32 Bool -> Bool -> Bool
|| Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Int -> JStat
adjSp' Int
l JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
items
   | Bool
otherwise                          = JExpr -> [JExpr] -> JStat
ApplStat (Ident -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Ident -> JExpr) -> Ident -> JExpr
forall a b. (a -> b) -> a -> b
$ Array Int Ident
pushN Array Int Ident -> Int -> Ident
forall i e. Ix i => Array i e -> i -> e
! Int
l) [JExpr]
xs
  where
    items :: [JStat]
items = (Int -> JExpr -> JStat) -> [Int] -> [JExpr] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> JExpr -> JStat
f [(Int
1::Int)..] [JExpr]
xs
    offset :: Int -> JExpr
offset Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l    = JExpr
sp
             | Bool
otherwise = JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
SubOp JExpr
sp (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i))
    l :: Int
l = [JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
xs
    f :: Int -> JExpr -> JStat
f Int
i JExpr
e = JExpr -> JExpr -> JStat
AssignStat ((JExpr -> JExpr -> JExpr
IdxExpr JExpr
stack) (JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int -> JExpr
offset Int
i))) (JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr JExpr
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' :: Int -> JStat
adjSp' Int
0 = JStat
forall a. Monoid a => a
mempty
adjSp' Int
n = JExpr
sp JExpr -> JExpr -> JStat
|= JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
AddOp JExpr
sp (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
n)

-- | Shrink the stack pointer by 'n'. The stack grows downward so substract
adjSpN' :: Int -> JStat
adjSpN' :: Int -> JStat
adjSpN' Int
0 = JStat
forall a. Monoid a => a
mempty
adjSpN' Int
n = JExpr
sp JExpr -> JExpr -> JStat
|= JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
SubOp JExpr
sp (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
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 :: Int -> G JStat
adjSp Int
0 = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
adjSp Int
n = do
  -- grow depth by n
  (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> JStat
adjSp' Int
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 :: Int -> G JStat
adjSpN Int
0 = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
adjSpN Int
n = do
  (Int -> Int) -> G ()
modifyStackDepth (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> JStat
adjSpN' Int
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 :: Array Int Ident
pushN = (Int, Int) -> [Ident] -> Array Int Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1,Int
32) ([Ident] -> Array Int Ident) -> [Ident] -> Array Int Ident
forall a b. (a -> b) -> a -> b
$ (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$p"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..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' :: Array Int JExpr
pushN' = (Ident -> JExpr) -> Array Int Ident -> Array Int JExpr
forall a b. (a -> b) -> Array Int a -> Array Int b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr (JVal -> JExpr) -> (Ident -> JVal) -> Ident -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) Array Int Ident
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 :: Array Integer Ident
pushNN = (Integer, Integer) -> [Ident] -> Array Integer Ident
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Integer
1,Integer
255) ([Ident] -> Array Integer Ident) -> [Ident] -> Array Integer Ident
forall a b. (a -> b) -> a -> b
$ (Int -> Ident) -> [Int] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FastString -> Ident
TxtI (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
mkFastString (String -> FastString) -> (Int -> String) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"h$pp"String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
1::Int)..Int
255]

-- | Like 'pushN'' but for the partial push functions
pushNN' :: Array Integer JExpr
pushNN' :: Array Integer JExpr
pushNN' = (Ident -> JExpr) -> Array Integer Ident -> Array Integer JExpr
forall a b. (a -> b) -> Array Integer a -> Array Integer b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (JVal -> JExpr
ValExpr (JVal -> JExpr) -> (Ident -> JVal) -> Ident -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) Array Integer Ident
pushNN

pushOptimized' :: [(Id,Int)] -> G JStat
pushOptimized' :: [(Id, Int)] -> G JStat
pushOptimized' [(Id, Int)]
xs = do
  [StackSlot]
slots  <- G [StackSlot]
getSlots
  [(JExpr, Bool)] -> G JStat
pushOptimized ([(JExpr, Bool)] -> G JStat)
-> StateT GenState IO [(JExpr, Bool)] -> G JStat
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (((Id, Int) -> StackSlot -> StateT GenState IO (JExpr, Bool))
-> [(Id, Int)] -> [StackSlot] -> StateT GenState IO [(JExpr, Bool)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Id, Int) -> StackSlot -> StateT GenState IO (JExpr, Bool)
f [(Id, Int)]
xs ([StackSlot]
slots[StackSlot] -> [StackSlot] -> [StackSlot]
forall a. [a] -> [a] -> [a]
++StackSlot -> [StackSlot]
forall a. a -> [a]
repeat StackSlot
SlotUnknown))
  where
    f :: (Id, Int) -> StackSlot -> StateT GenState IO (JExpr, Bool)
f (Id
i1,Int
n1) StackSlot
xs2 = do
      [JExpr]
xs <- Id -> G [JExpr]
varsForId Id
i1
      let !id_n1 :: JExpr
id_n1 = [JExpr]
xs [JExpr] -> Int -> JExpr
forall a. HasCallStack => [a] -> Int -> a
!! (Int
n1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

      case StackSlot
xs2 of
        SlotId Id
i2 Int
n2 -> (JExpr, Bool) -> StateT GenState IO (JExpr, Bool)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JExpr
id_n1,Id
i1Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
==Id
i2Bool -> Bool -> Bool
&&Int
n1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
n2)
        StackSlot
_            -> (JExpr, Bool) -> StateT GenState IO (JExpr, Bool)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JExpr
id_n1,Bool
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 :: [(JExpr, Bool)] -> G JStat
pushOptimized [] = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStat
forall a. Monoid a => a
mempty
pushOptimized [(JExpr, Bool)]
xs = do
  Int -> G ()
dropSlots Int
l
  (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(JExpr, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JExpr, Bool)]
xs)
  Bool -> JStat
go (Bool -> JStat)
-> (StgToJSConfig -> Bool) -> StgToJSConfig -> JStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  StgToJSConfig -> Bool
csInlinePush (StgToJSConfig -> JStat)
-> StateT GenState IO StgToJSConfig -> G JStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  where
    go :: Bool -> JStat
go Bool
True = JStat
inlinePush
    go Bool
_
     | ((JExpr, Bool) -> Bool) -> [(JExpr, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (JExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd [(JExpr, Bool)]
xs                  = Int -> JStat
adjSp' Int
l
     | ((JExpr, Bool) -> Bool) -> [(JExpr, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not(Bool -> Bool) -> ((JExpr, Bool) -> Bool) -> (JExpr, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(JExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(JExpr, Bool)]
xs Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 =
        JExpr -> [JExpr] -> JStat
ApplStat (Array Int JExpr
pushN' Array Int JExpr -> Int -> JExpr
forall i e. Ix i => Array i e -> i -> e
! Int
l) (((JExpr, Bool) -> JExpr) -> [(JExpr, Bool)] -> [JExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JExpr, Bool) -> JExpr
forall a b. (a, b) -> a
fst [(JExpr, Bool)]
xs)
     | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&& Bool -> Bool
not ((JExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd ((JExpr, Bool) -> Bool) -> (JExpr, Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ [(JExpr, Bool)] -> (JExpr, Bool)
forall a. HasCallStack => [a] -> a
last [(JExpr, Bool)]
xs) =
        JExpr -> [JExpr] -> JStat
ApplStat (Array Integer JExpr
pushNN' Array Integer JExpr -> Integer -> JExpr
forall i e. Ix i => Array i e -> i -> e
! Integer
sig) [ JExpr
e | (JExpr
e,Bool
False) <- [(JExpr, Bool)]
xs ]
     | Bool
otherwise = JStat
inlinePush
    l :: Int
l   = [(JExpr, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JExpr, Bool)]
xs
    sig :: Integer
    sig :: Integer
sig = (Integer -> Integer -> Integer) -> [Integer] -> Integer
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
L.foldl1' Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
(Bits..|.) ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ ((JExpr, Bool) -> Int -> Integer)
-> [(JExpr, Bool)] -> [Int] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(JExpr
_e,Bool
b) Int
i -> if Bool -> Bool
not Bool
b then Int -> Integer
forall a. Bits a => Int -> a
Bits.bit Int
i else Integer
0) [(JExpr, Bool)]
xs [Int
0..]
    inlinePush :: JStat
inlinePush = Int -> JStat
adjSp' Int
l JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> (JExpr, Bool) -> JStat)
-> [Int] -> [(JExpr, Bool)] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (JExpr, Bool) -> JStat
pushSlot [Int
1..] [(JExpr, Bool)]
xs)
    pushSlot :: Int -> (JExpr, Bool) -> JStat
pushSlot Int
i (JExpr
ex, Bool
False) = JExpr -> JExpr -> JExpr
IdxExpr JExpr
stack (Int -> JExpr
offset Int
i) JExpr -> JExpr -> JStat
|= JExpr
ex
    pushSlot Int
_ (JExpr, Bool)
_           = JStat
forall a. Monoid a => a
mempty
    offset :: Int -> JExpr
offset Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l    = JExpr
sp
             | Bool
otherwise = JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
SubOp JExpr
sp (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i))

-- | push a let-no-escape frame onto the stack
pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
pushLneFrame Int
size ExprCtx
ctx =
  let ctx' :: ExprCtx
ctx' = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
size
  in [(Id, Int)] -> G JStat
pushOptimized' (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
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 :: Int -> [JExpr] -> JStat
popSkip Int
0 []  = JStat
forall a. Monoid a => a
mempty
popSkip Int
n []  = Int -> JStat
adjSpN' Int
n
popSkip Int
n [JExpr]
tgt = Int -> [JExpr] -> JStat
loadSkip Int
n [JExpr]
tgt JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStat
adjSpN' ([JExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JExpr]
tgt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 :: Int -> [JExpr] -> JStat
loadSkip = JExpr -> Int -> [JExpr] -> JStat
loadSkipFrom JExpr
sp
  where
    loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
    loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
loadSkipFrom JExpr
fr Int
n [JExpr]
xs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
items
      where
        items :: [JStat]
items = [JStat] -> [JStat]
forall a. [a] -> [a]
reverse ([JStat] -> [JStat]) -> [JStat] -> [JStat]
forall a b. (a -> b) -> a -> b
$ (Int -> JExpr -> JStat) -> [Int] -> [JExpr] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> JExpr -> JStat
f [(Int
0::Int)..] ([JExpr] -> [JExpr]
forall a. [a] -> [a]
reverse [JExpr]
xs)
        -- helper to generate sp - n offset to index with
        offset :: Int -> JExpr
offset Int
0 = JExpr
fr
        offset Int
n = JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
SubOp JExpr
fr  (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
n)
        -- helper to load stack .! i into ex, e.g., ex = stack[i]
        f :: Int -> JExpr -> JStat
f Int
i JExpr
ex   = JExpr
ex JExpr -> JExpr -> JStat
|= JExpr -> JExpr -> JExpr
IdxExpr JExpr
stack (JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int -> JExpr
offset (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)))


-- | Pop but preserve the first N slots
popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat
popSkipI :: Int -> [(Ident, StackSlot)] -> G JStat
popSkipI Int
0 [] = JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStat
forall a. Monoid a => a
mempty
popSkipI Int
n [] = Int -> G JStat
popN Int
n
popSkipI Int
n [(Ident, StackSlot)]
xs = do
  -- add N unknown slots
  Int -> G ()
addUnknownSlots Int
n
  -- now add the slots from xs, after this line the stack should look like
  -- [xs] ++ [Unknown...] ++ old_stack
  [StackSlot] -> G ()
addSlots (((Ident, StackSlot) -> StackSlot)
-> [(Ident, StackSlot)] -> [StackSlot]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, StackSlot) -> StackSlot
forall a b. (a, b) -> b
snd [(Ident, StackSlot)]
xs)
  -- move stack pointer into the stack by (length xs + n), basically resetting
  -- the stack pointer
  JStat
a <- Int -> G JStat
adjSpN ([(Ident, StackSlot)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Ident, StackSlot)]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
  -- now load skipping first N slots
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Ident] -> JStat
loadSkipI Int
n (((Ident, StackSlot) -> Ident) -> [(Ident, StackSlot)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, StackSlot) -> Ident
forall a b. (a, b) -> a
fst [(Ident, StackSlot)]
xs) JStat -> JStat -> JStat
forall a. Semigroup a => a -> a -> a
<> JStat
a)

-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr'
loadSkipI :: Int -> [Ident] -> JStat
loadSkipI :: Int -> [Ident] -> JStat
loadSkipI = JExpr -> Int -> [Ident] -> JStat
loadSkipIFrom JExpr
sp
  where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
        loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
loadSkipIFrom JExpr
fr Int
n [Ident]
xs = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat [JStat]
items
          where
            items :: [JStat]
items = [JStat] -> [JStat]
forall a. [a] -> [a]
reverse ([JStat] -> [JStat]) -> [JStat] -> [JStat]
forall a b. (a -> b) -> a -> b
$ (Int -> Ident -> JStat) -> [Int] -> [Ident] -> [JStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Ident -> JStat
f [(Int
0::Int)..] ([Ident] -> [Ident]
forall a. [a] -> [a]
reverse [Ident]
xs)
            offset :: Int -> JExpr
offset Int
0 = JExpr
fr
            offset Int
n = JOp -> JExpr -> JExpr -> JExpr
InfixExpr JOp
SubOp JExpr
fr (Int -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr Int
n)
            f :: Int -> Ident -> JStat
f Int
i Ident
ex   = Ident
ex Ident -> JExpr -> JStat
||= JExpr -> JExpr -> JExpr
IdxExpr JExpr
stack (JExpr -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (Int -> JExpr
offset (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)))

-- | Blindly pop N slots
popN :: Int -> G JStat
popN :: Int -> G JStat
popN Int
n = Int -> G ()
addUnknownSlots Int
n G () -> G JStat -> G JStat
forall a b.
StateT GenState IO a
-> StateT GenState IO b -> StateT GenState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> G JStat
adjSpN Int
n

-- | Generate statements to update the current node with a blackhole
bhStats :: StgToJSConfig -> Bool -> JStat
bhStats :: StgToJSConfig -> Bool -> JStat
bhStats StgToJSConfig
s Bool
pushUpd = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
  [ if Bool
pushUpd then StgToJSConfig -> [JExpr] -> JStat
push' StgToJSConfig
s [JExpr
r1, FastString -> JExpr
var FastString
"h$upd_frame"] else JStat
forall a. Monoid a => a
mempty
  , StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
R1 JExpr -> FastString -> JExpr
.^ FastString
closureEntry_  JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$blackhole"
  , StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
R1 JExpr -> FastString -> JExpr
.^ FastString
closureField1_ JExpr -> JExpr -> JStat
|= FastString -> JExpr
var FastString
"h$currentThread"
  , StgReg -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr StgReg
R1 JExpr -> FastString -> JExpr
.^ FastString
closureField2_ JExpr -> JExpr -> JStat
|= JExpr
null_ -- will be filled with waiters array
  ]

-- | Wrapper around 'updateThunk'', performs the stack manipulation before
-- updating the Thunk.
updateThunk :: G JStat
updateThunk :: G JStat
updateThunk = do
  StgToJSConfig
settings <- StateT GenState IO StgToJSConfig
getSettings
  -- update frame size
  let adjPushStack :: Int -> G ()
      adjPushStack :: Int -> G ()
adjPushStack Int
n = do (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n)
                          Int -> G ()
dropSlots Int
n
  Int -> G ()
adjPushStack Int
2
  JStat -> G JStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStat -> G JStat) -> JStat -> G JStat
forall a b. (a -> b) -> a -> b
$ (StgToJSConfig -> JStat
updateThunk' StgToJSConfig
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' :: StgToJSConfig -> JStat
updateThunk' StgToJSConfig
settings =
  if StgToJSConfig -> Bool
csInlineBlackhole StgToJSConfig
settings
    then StgToJSConfig -> Bool -> JStat
bhStats StgToJSConfig
settings Bool
True
    else JExpr -> [JExpr] -> JStat
ApplStat (FastString -> JExpr
var FastString
"h$bh") []