{-# LANGUAGE OverloadedStrings #-}
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
, 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
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
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
setStackDepth :: Int -> G ()
setStackDepth :: Int -> G ()
setStackDepth Int
d = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
s -> GenGroupState
s { ggsStackDepth = d})
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)
modifyStackDepth :: (Int -> Int) -> G ()
modifyStackDepth :: (Int -> Int) -> G ()
modifyStackDepth Int -> Int
f = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
s -> GenGroupState
s { ggsStackDepth = f (ggsStackDepth s) })
setSlots :: [StackSlot] -> G ()
setSlots :: [StackSlot] -> G ()
setSlots [StackSlot]
xs = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
g -> GenGroupState
g { ggsStack = xs})
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)
modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
modifySlots [StackSlot] -> [StackSlot]
f = (GenGroupState -> GenGroupState) -> G ()
modifyGroup (\GenGroupState
g -> GenGroupState
g { ggsStack = f (ggsStack g)})
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)
addSlots :: [StackSlot] -> G ()
addSlots :: [StackSlot] -> G ()
addSlots [StackSlot]
xs = do
s <- G [StackSlot]
getSlots
setSlots (xs ++ s)
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)
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)
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)
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
(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)
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)
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]
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
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]
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)
pushOptimized :: [(JStgExpr,Bool)]
-> 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))
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')
popSkip :: Int
-> [JStgExpr]
-> 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)
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)
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 -> 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)))
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
Int -> G ()
addUnknownSlots Int
n
[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)
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)
return (loadSkipI n (map fst xs) <> a)
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)))
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
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_
]
updateThunk :: G JStgStat
updateThunk :: G JStgStat
updateThunk = do
settings <- StateT GenState IO StgToJSConfig
getSettings
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
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 []