{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.ExprCtx
-- 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
--
-- TODO: Write my description!
-----------------------------------------------------------------------------

module GHC.StgToJS.ExprCtx
  ( ExprCtx
  , initExprCtx
  , ctxAssertEvaluated
  , ctxIsEvaluated
  , ctxSetSrcSpan
  , ctxSrcSpan
  , ctxSetTop
  , ctxTarget
  , ctxSetTarget
  , ctxEvaluatedIds
  -- * Let-no-escape
  , 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


-- | Context into which an expression is evaluated
data ExprCtx = ExprCtx
  { ExprCtx -> Id
ctxTop        :: Id
    -- ^ Top-level binding Id

  , ExprCtx -> [TypedExpr]
ctxTarget     :: [TypedExpr]
    -- ^ Target variables for the evaluated expression

  , ExprCtx -> UniqSet Id
ctxEvaluatedIds :: UniqSet Id
    -- ^ Ids that we know to be evaluated (e.g. case binders when the expression
    -- to evaluate is in an alternative)

  , ExprCtx -> Maybe RealSrcSpan
ctxSrcSpan    :: Maybe RealSrcSpan
    -- ^ Source location

  ----------------------------
  -- Handling of let-no-escape

  , ExprCtx -> UniqFM Id Int
ctxLneFrameBs :: UniqFM Id Int
    -- ^ LNE bindings with their expected stack size.
    --
    -- The Int is the size of the stack when the LNE binding was defined.
    -- We need to shrink the stack back to this size when we enter one of the
    -- associated binder rhs: it expects its free variables at certain offsets
    -- in the stack.

  , ExprCtx -> [(Id, Int)]
ctxLneFrameVars :: [(Id,Int)]
    -- ^ Contents of current LNE frame
    --
    -- Variables and their index on the stack

  , ExprCtx -> Int
ctxLneFrameSize :: {-# UNPACK #-} !Int
    -- ^ Cache the length of `ctxLneFrameVars`

  }

-- | Initialize an expression context in the context of the given top-level
-- binding Id
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
  }

-- | Set target
ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx
ctxSetTarget [TypedExpr]
t ExprCtx
ctx = ExprCtx
ctx { ctxTarget :: [TypedExpr]
ctxTarget = [TypedExpr]
t }

-- | Set top-level binding Id
ctxSetTop :: Id -> ExprCtx -> ExprCtx
ctxSetTop :: Id -> ExprCtx -> ExprCtx
ctxSetTop Id
i ExprCtx
ctx = ExprCtx
ctx { ctxTop :: Id
ctxTop = Id
i }

-- | Add an Id to the known-evaluated set
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 }

-- | Set source location
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 }

-- | Update let-no-escape frame
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
    }

-- | Remove information about the current LNE frame
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
    }

-- | Predicate: do we know for sure that the given Id is evaluated?
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

-- | Does the given Id correspond to a LNE binding
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)

-- | Does the given Id correspond to a LNE live var on the stack
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)

-- | Return the LNE stack size associated to the given Id.
-- Return Nothing when the Id doesn't correspond to a LNE binding.
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

-- | Shrink the LNE stack to the given size
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
           }
      )