{-# LANGUAGE TupleSections #-}
module GHC.StgToJS.ExprCtx
( ExprCtx
, initExprCtx
, ctxAssertEvaluated
, ctxIsEvaluated
, ctxSetSrcSpan
, ctxSrcSpan
, ctxSetTop
, ctxTarget
, ctxSetTarget
, ctxEvaluatedIds
, ctxClearLneFrame
, ctxUpdateLneFrame
, ctxLneFrameVars
, ctxLneFrameSize
, ctxIsLneBinding
, ctxIsLneLiveVar
, ctxLneBindingStackSize
, ctxLneShrinkStack
)
where
import GHC.Prelude
import GHC.StgToJS.Types
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Var
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
data ExprCtx = ExprCtx
{ ExprCtx -> Id
ctxTop :: Id
, ExprCtx -> [TypedExpr]
ctxTarget :: [TypedExpr]
, ExprCtx -> UniqSet Id
ctxEvaluatedIds :: UniqSet Id
, ExprCtx -> Maybe RealSrcSpan
ctxSrcSpan :: Maybe RealSrcSpan
, ExprCtx -> UniqFM Id Int
ctxLneFrameBs :: UniqFM Id Int
, ExprCtx -> [(Id, Int)]
ctxLneFrameVars :: [(Id,Int)]
, ExprCtx -> Int
ctxLneFrameSize :: {-# UNPACK #-} !Int
}
initExprCtx :: Id -> ExprCtx
initExprCtx :: Id -> ExprCtx
initExprCtx Id
i = ExprCtx
{ ctxTop :: Id
ctxTop = Id
i
, ctxTarget :: [TypedExpr]
ctxTarget = []
, ctxEvaluatedIds :: UniqSet Id
ctxEvaluatedIds = forall a. UniqSet a
emptyUniqSet
, ctxLneFrameBs :: UniqFM Id Int
ctxLneFrameBs = forall key elt. UniqFM key elt
emptyUFM
, ctxLneFrameVars :: [(Id, Int)]
ctxLneFrameVars = []
, ctxLneFrameSize :: Int
ctxLneFrameSize = Int
0
, ctxSrcSpan :: Maybe RealSrcSpan
ctxSrcSpan = forall a. Maybe a
Nothing
}
ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget [TypedExpr]
t ExprCtx
ctx = ExprCtx
ctx { ctxTarget :: [TypedExpr]
ctxTarget = [TypedExpr]
t }
ctxSetTop :: Id -> ExprCtx -> ExprCtx
ctxSetTop :: Id -> ExprCtx -> ExprCtx
ctxSetTop Id
i ExprCtx
ctx = ExprCtx
ctx { ctxTop :: Id
ctxTop = Id
i }
ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx
ctxAssertEvaluated Id
i ExprCtx
ctx = ExprCtx
ctx { ctxEvaluatedIds :: UniqSet Id
ctxEvaluatedIds = forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet (ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx) Id
i }
ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx
ctxSetSrcSpan RealSrcSpan
span ExprCtx
ctx = ExprCtx
ctx { ctxSrcSpan :: Maybe RealSrcSpan
ctxSrcSpan = forall a. a -> Maybe a
Just RealSrcSpan
span }
ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx
ctxUpdateLneFrame :: [(Id, Int)] -> [Id] -> ExprCtx -> ExprCtx
ctxUpdateLneFrame [(Id, Int)]
new_spilled_vars [Id]
new_lne_ids ExprCtx
ctx =
let old_frame_size :: Int
old_frame_size = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
new_frame_size :: Int
new_frame_size = Int
old_frame_size forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, Int)]
new_spilled_vars
in ExprCtx
ctx
{ ctxLneFrameBs :: UniqFM Id Int
ctxLneFrameBs = forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM (ExprCtx -> UniqFM Id Int
ctxLneFrameBs ExprCtx
ctx) (forall a b. (a -> b) -> [a] -> [b]
map (,Int
new_frame_size) [Id]
new_lne_ids)
, ctxLneFrameSize :: Int
ctxLneFrameSize = Int
new_frame_size
, ctxLneFrameVars :: [(Id, Int)]
ctxLneFrameVars = ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx forall a. [a] -> [a] -> [a]
++ [(Id, Int)]
new_spilled_vars
}
ctxClearLneFrame :: ExprCtx -> ExprCtx
ctxClearLneFrame :: ExprCtx -> ExprCtx
ctxClearLneFrame ExprCtx
ctx =
ExprCtx
ctx
{ ctxLneFrameBs :: UniqFM Id Int
ctxLneFrameBs = forall key elt. UniqFM key elt
emptyUFM
, ctxLneFrameVars :: [(Id, Int)]
ctxLneFrameVars = []
, ctxLneFrameSize :: Int
ctxLneFrameSize = Int
0
}
ctxIsEvaluated :: ExprCtx -> Id -> Bool
ctxIsEvaluated :: ExprCtx -> Id -> Bool
ctxIsEvaluated ExprCtx
ctx Id
i = Id
i forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` ExprCtx -> UniqSet Id
ctxEvaluatedIds ExprCtx
ctx
ctxIsLneBinding :: ExprCtx -> Id -> Bool
ctxIsLneBinding :: ExprCtx -> Id -> Bool
ctxIsLneBinding ExprCtx
ctx Id
i = forall a. Maybe a -> Bool
isJust (ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i)
ctxIsLneLiveVar :: ExprCtx -> Id -> Bool
ctxIsLneLiveVar :: ExprCtx -> Id -> Bool
ctxIsLneLiveVar ExprCtx
ctx Id
i = Id
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx)
ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int
ctxLneBindingStackSize ExprCtx
ctx Id
i = forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ExprCtx -> UniqFM Id Int
ctxLneFrameBs ExprCtx
ctx) Id
i
ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx
ctxLneShrinkStack ExprCtx
ctx Int
n =
let l :: Int
l = ExprCtx -> Int
ctxLneFrameSize ExprCtx
ctx
in forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr
(Int
l forall a. Ord a => a -> a -> Bool
>= Int
n)
(forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"ctxLneShrinkStack: let-no-escape stack too short:"
, forall a. Outputable a => a -> SDoc
ppr Int
l
, forall doc. IsLine doc => String -> doc
text String
" < "
, forall a. Outputable a => a -> SDoc
ppr Int
n
])
(ExprCtx
ctx { ctxLneFrameVars :: [(Id, Int)]
ctxLneFrameVars = forall a. Int -> [a] -> [a]
take Int
n (ExprCtx -> [(Id, Int)]
ctxLneFrameVars ExprCtx
ctx)
, ctxLneFrameSize :: Int
ctxLneFrameSize = Int
n
}
)