{-# 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.JStg.Syntax
import GHC.JS.Make
import GHC.JS.Ident

import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Heap
import GHC.StgToJS.Ids
import GHC.StgToJS.Monad
import GHC.StgToJS.Regs
import GHC.StgToJS.Symbols
import GHC.StgToJS.Types

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
  s <- G [StackSlot]
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 :: forall a. G a -> G a
isolateSlots G a
m = do
  s <- G [StackSlot]
getSlots
  d <- getStackDepth
  a <- m
  setSlots s
  setStackDepth d
  pure 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
  s <- G [StackSlot]
getSlots
  setSlots (xs ++ 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 :: [JStgExpr] -> G JStgStat
push :: [JStgExpr] -> G JStgStat
push [JStgExpr]
xs = do
  Int -> G ()
dropSlots ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs)
  (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs))
  (StgToJSConfig -> [JStgExpr] -> JStgStat)
-> [JStgExpr] -> StgToJSConfig -> JStgStat
forall a b c. (a -> b -> c) -> b -> a -> c
flip StgToJSConfig -> [JStgExpr] -> JStgStat
push' [JStgExpr]
xs (StgToJSConfig -> JStgStat)
-> StateT GenState IO StgToJSConfig -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings

push' :: StgToJSConfig -> [JStgExpr] -> JStgStat
push' :: StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
_ [] = JStgStat
forall a. Monoid a => a
mempty
push' StgToJSConfig
cs [JStgExpr]
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 -> JStgStat
adjSp' Int
l JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat]
items
   | Bool
otherwise                          = JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (Ident -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Ident -> JStgExpr) -> Ident -> JStgExpr
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) [JStgExpr]
xs
  where
    items :: [JStgStat]
items = (Int -> JStgExpr -> JStgStat) -> [Int] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> JStgExpr -> JStgStat
f [(Int
1::Int)..] [JStgExpr]
xs
    offset :: Int -> JStgExpr
offset Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l    = JStgExpr
sp
             | Bool
otherwise = Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
SubOp JStgExpr
sp (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i))
    l :: Int
l = [JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
xs
    f :: Int -> JStgExpr -> JStgStat
f Int
i JStgExpr
e = JStgExpr -> AOp -> JStgExpr -> JStgStat
AssignStat ((JStgExpr -> JStgExpr -> JStgExpr
IdxExpr JStgExpr
stack) (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr
offset Int
i))) AOp
AssignOp (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr JStgExpr
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 -> JStgStat
adjSp' :: Int -> JStgStat
adjSp' Int
0 = JStgStat
forall a. Monoid a => a
mempty
adjSp' Int
n = JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
AddOp JStgExpr
sp (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
n)

-- | Shrink the stack pointer by 'n'. The stack grows downward so substract
adjSpN' :: Int -> JStgStat
adjSpN' :: Int -> JStgStat
adjSpN' Int
0 = JStgStat
forall a. Monoid a => a
mempty
adjSpN' Int
n = JStgExpr
sp JStgExpr -> JStgExpr -> JStgStat
|= Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
SubOp JStgExpr
sp (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
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 JStgStat
adjSp :: Int -> G JStgStat
adjSp Int
0 = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
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)
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> JStgStat
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 JStgStat
adjSpN :: Int -> G JStgStat
adjSpN Int
0 = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
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)
  JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> JStgStat
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
name (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$p"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
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 JStgExpr
pushN' :: Array Int JStgExpr
pushN' = (Ident -> JStgExpr) -> Array Int Ident -> Array Int JStgExpr
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 -> JStgExpr
ValExpr (JVal -> JStgExpr) -> (Ident -> JVal) -> Ident -> JStgExpr
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
name (FastString -> Ident) -> (Int -> FastString) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString ([Char] -> FastString) -> (Int -> [Char]) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"h$pp"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [(Int
1::Int)..Int
255]

-- | Like 'pushN'' but for the partial push functions
pushNN' :: Array Integer JStgExpr
pushNN' :: Array Integer JStgExpr
pushNN' = (Ident -> JStgExpr)
-> Array Integer Ident -> Array Integer JStgExpr
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 -> JStgExpr
ValExpr (JVal -> JStgExpr) -> (Ident -> JVal) -> Ident -> JStgExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> JVal
JVar) Array Integer Ident
pushNN

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

      case xs2 of
        SlotId Id
i2 Int
n2 -> (JStgExpr, Bool) -> StateT GenState IO (JStgExpr, Bool)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgExpr
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
_            -> (JStgExpr, Bool) -> StateT GenState IO (JStgExpr, Bool)
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgExpr
id_n1,Bool
False)

-- | optimized push that reuses existing values on stack automatically chooses
-- an optimized partial push (h$ppN) function when possible.
pushOptimized :: [(JStgExpr,Bool)] -- ^ contents of the slots, True if same value is already there
              -> G JStgStat
pushOptimized :: [(JStgExpr, Bool)] -> G JStgStat
pushOptimized [] = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JStgStat
forall a. Monoid a => a
mempty
pushOptimized [(JStgExpr, Bool)]
xs = do
  Int -> G ()
dropSlots Int
l
  (Int -> Int) -> G ()
modifyStackDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(JStgExpr, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JStgExpr, Bool)]
xs)
  Bool -> JStgStat
go (Bool -> JStgStat)
-> (StgToJSConfig -> Bool) -> StgToJSConfig -> JStgStat
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  StgToJSConfig -> Bool
csInlinePush (StgToJSConfig -> JStgStat)
-> StateT GenState IO StgToJSConfig -> G JStgStat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT GenState IO StgToJSConfig
getSettings
  where
    go :: Bool -> JStgStat
go Bool
True = JStgStat
inlinePush
    go Bool
_
     | ((JStgExpr, Bool) -> Bool) -> [(JStgExpr, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (JStgExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd [(JStgExpr, Bool)]
xs                  = Int -> JStgStat
adjSp' Int
l
     | ((JStgExpr, Bool) -> Bool) -> [(JStgExpr, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not(Bool -> Bool)
-> ((JStgExpr, Bool) -> Bool) -> (JStgExpr, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(JStgExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd) [(JStgExpr, Bool)]
xs Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32 =
        JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (Array Int JStgExpr
pushN' Array Int JStgExpr -> Int -> JStgExpr
forall i e. Ix i => Array i e -> i -> e
! Int
l) (((JStgExpr, Bool) -> JStgExpr) -> [(JStgExpr, Bool)] -> [JStgExpr]
forall a b. (a -> b) -> [a] -> [b]
map (JStgExpr, Bool) -> JStgExpr
forall a b. (a, b) -> a
fst [(JStgExpr, Bool)]
xs)
     | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 Bool -> Bool -> Bool
&& Bool -> Bool
not ((JStgExpr, Bool) -> Bool
forall a b. (a, b) -> b
snd ((JStgExpr, Bool) -> Bool) -> (JStgExpr, Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ [(JStgExpr, Bool)] -> (JStgExpr, Bool)
forall a. HasCallStack => [a] -> a
last [(JStgExpr, Bool)]
xs) =
        JStgExpr -> [JStgExpr] -> JStgStat
ApplStat (Array Integer JStgExpr
pushNN' Array Integer JStgExpr -> Integer -> JStgExpr
forall i e. Ix i => Array i e -> i -> e
! Integer
sig) [ JStgExpr
e | (JStgExpr
e,Bool
False) <- [(JStgExpr, Bool)]
xs ]
     | Bool
otherwise = JStgStat
inlinePush
    l :: Int
l   = [(JStgExpr, Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JStgExpr, 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
$ ((JStgExpr, Bool) -> Int -> Integer)
-> [(JStgExpr, Bool)] -> [Int] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(JStgExpr
_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) [(JStgExpr, Bool)]
xs [Int
0..]
    inlinePush :: JStgStat
inlinePush = Int -> JStgStat
adjSp' Int
l JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ((Int -> (JStgExpr, Bool) -> JStgStat)
-> [Int] -> [(JStgExpr, Bool)] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (JStgExpr, Bool) -> JStgStat
pushSlot [Int
1..] [(JStgExpr, Bool)]
xs)
    pushSlot :: Int -> (JStgExpr, Bool) -> JStgStat
pushSlot Int
i (JStgExpr
ex, Bool
False) = JStgExpr -> JStgExpr -> JStgExpr
IdxExpr JStgExpr
stack (Int -> JStgExpr
offset Int
i) JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
ex
    pushSlot Int
_ (JStgExpr, Bool)
_           = JStgStat
forall a. Monoid a => a
mempty
    offset :: Int -> JStgExpr
offset Int
i | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l    = JStgExpr
sp
             | Bool
otherwise = Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
SubOp JStgExpr
sp (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
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 JStgStat
pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStgStat
pushLneFrame Int
size ExprCtx
ctx =
  let ctx' :: ExprCtx
ctx' = ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
size
  in [(Id, Int)] -> G JStgStat
pushOptimized' (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx')

-- | Pop things, don't update the stack knowledge in 'G'
popSkip :: Int      -- ^ number of slots to skip
         -> [JStgExpr] -- ^ assign stack slot values to these
         -> JStgStat
popSkip :: Int -> [JStgExpr] -> JStgStat
popSkip Int
0 []  = JStgStat
forall a. Monoid a => a
mempty
popSkip Int
n []  = Int -> JStgStat
adjSpN' Int
n
popSkip Int
n [JStgExpr]
tgt = Int -> [JStgExpr] -> JStgStat
loadSkip Int
n [JStgExpr]
tgt JStgStat -> JStgStat -> JStgStat
forall a. Semigroup a => a -> a -> a
<> Int -> JStgStat
adjSpN' ([JStgExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [JStgExpr]
tgt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

-- | Load 'length (xs :: [JStgExpr])' 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 -> [JStgExpr] -> JStgStat
loadSkip :: Int -> [JStgExpr] -> JStgStat
loadSkip = JStgExpr -> Int -> [JStgExpr] -> JStgStat
loadSkipFrom JStgExpr
sp
  where
    loadSkipFrom :: JStgExpr -> Int -> [JStgExpr] -> JStgStat
    loadSkipFrom :: JStgExpr -> Int -> [JStgExpr] -> JStgStat
loadSkipFrom JStgExpr
fr Int
n [JStgExpr]
xs = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat [JStgStat]
items
      where
        items :: [JStgStat]
items = [JStgStat] -> [JStgStat]
forall a. [a] -> [a]
reverse ([JStgStat] -> [JStgStat]) -> [JStgStat] -> [JStgStat]
forall a b. (a -> b) -> a -> b
$ (Int -> JStgExpr -> JStgStat) -> [Int] -> [JStgExpr] -> [JStgStat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> JStgExpr -> JStgStat
f [(Int
0::Int)..] ([JStgExpr] -> [JStgExpr]
forall a. [a] -> [a]
reverse [JStgExpr]
xs)
        -- helper to generate sp - n offset to index with
        offset :: Int -> JStgExpr
offset Int
0 = JStgExpr
fr
        offset Int
n = Op -> JStgExpr -> JStgExpr -> JStgExpr
InfixExpr Op
SubOp JStgExpr
fr  (Int -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr Int
n)
        -- helper to load stack .! i into ex, e.g., ex = stack[i]
        f :: Int -> JStgExpr -> JStgStat
f Int
i JStgExpr
ex   = JStgExpr
ex JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr -> JStgExpr
IdxExpr JStgExpr
stack (JStgExpr -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr (Int -> JStgExpr
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 JStgStat
popSkipI :: Int -> [(Ident, StackSlot)] -> G JStgStat
popSkipI Int
0 [] = JStgStat -> G JStgStat
forall a. a -> StateT GenState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JStgStat
forall a. Monoid a => a
mempty
popSkipI Int
n [] = Int -> G JStgStat
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
  a <- Int -> G JStgStat
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
  return (loadSkipI n (map fst xs) <> a)

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

-- | Blindly pop N slots
popN :: Int -> G JStgStat
popN :: Int -> G JStgStat
popN Int
n = Int -> G ()
addUnknownSlots Int
n G () -> G JStgStat -> G JStgStat
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 JStgStat
adjSpN Int
n

-- | Generate statements to update the current node with a blackhole
bhStats :: StgToJSConfig -> Bool -> JStgStat
bhStats :: StgToJSConfig -> Bool -> JStgStat
bhStats StgToJSConfig
s Bool
pushUpd = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
  [ if Bool
pushUpd then StgToJSConfig -> [JStgExpr] -> JStgStat
push' StgToJSConfig
s [JStgExpr
r1, JStgExpr
hdUpdFrame] else JStgStat
forall a. Monoid a => a
mempty
  , StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
R1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureInfo_   JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdBlackHole
  , StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
R1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField1_ JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
hdCurrentThread
  , StgReg -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr StgReg
R1 JStgExpr -> FastString -> JStgExpr
.^ FastString
closureField2_ JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
null_ -- will be filled with waiters array
  ]

-- | Wrapper around 'updateThunk'', performs the stack manipulation before
-- updating the Thunk.
updateThunk :: G JStgStat
updateThunk :: G JStgStat
updateThunk = do
  settings <- StateT GenState IO StgToJSConfig
getSettings
  -- update frame size
  let 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
  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 -> JStgStat
updateThunk' :: StgToJSConfig -> JStgStat
updateThunk' StgToJSConfig
settings =
  if StgToJSConfig -> Bool
csInlineBlackhole StgToJSConfig
settings
    then StgToJSConfig -> Bool -> JStgStat
bhStats StgToJSConfig
settings Bool
True
    else JStgExpr -> [JStgExpr] -> JStgStat
ApplStat JStgExpr
hdBh []