{-# LANGUAGE CPP,
             FlexibleInstances,
             OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.StgToJS.Rts.Apply
-- 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
--
-- Types and utility functions used in the JS RTS.
-----------------------------------------------------------------------------

module GHC.StgToJS.Rts.Types where

import GHC.Prelude

import GHC.JS.Make
import GHC.JS.JStg.Syntax
import GHC.JS.JStg.Monad
import GHC.StgToJS.Regs
import GHC.StgToJS.Types

--------------------------------------------------------------------------------
-- Syntactic Sugar for some Utilities we want in JS land
--------------------------------------------------------------------------------

-- | Syntactic sugar, i.e., a Haskell function which generates useful JS code.
-- Given a @JStgExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS
-- program
traceRts :: StgToJSConfig -> JStgExpr -> JStgStat
traceRts :: StgToJSConfig -> JStgExpr -> JStgStat
traceRts StgToJSConfig
s JStgExpr
ex | (StgToJSConfig -> Bool
csTraceRts StgToJSConfig
s)  = FastString -> [JStgExpr] -> JStgStat
appS FastString
"h$log" [JStgExpr
ex]
              | Bool
otherwise       = JStgStat
forall a. Monoid a => a
mempty

-- | Syntactic sugar. Given a @JStgExpr@, 'ex' which is assumed to be a predicate,
-- and a message 'm', assert that 'not ex' is True, if not throw an exception in
-- JS land with message 'm'.
assertRts :: ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
assertRts :: forall a. ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat
assertRts StgToJSConfig
s JStgExpr
ex a
m | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s = JStgExpr -> JStgStat -> JStgStat
jwhenS (UOp -> JStgExpr -> JStgExpr
UOpExpr UOp
NotOp JStgExpr
ex) (FastString -> [JStgExpr] -> JStgStat
appS FastString
"throw" [a -> JStgExpr
forall a. ToJExpr a => a -> JStgExpr
toJExpr a
m])
                 | Bool
otherwise     = JStgStat
forall a. Monoid a => a
mempty

-- | name of the closure 'c'
clName :: JStgExpr -> JStgExpr
clName :: JStgExpr -> JStgExpr
clName JStgExpr
c = JStgExpr
c JStgExpr -> FastString -> JStgExpr
.^ FastString
"n"

-- | Type name of the closure 'c'
clTypeName :: JStgExpr -> JStgExpr
clTypeName :: JStgExpr -> JStgExpr
clTypeName JStgExpr
c = FastString -> [JStgExpr] -> JStgExpr
app FastString
"h$closureTypeName" [JStgExpr
c JStgExpr -> FastString -> JStgExpr
.^ FastString
"t"]

-- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
stackFrameSize :: JStgExpr -- ^ assign frame size to this
               -> JStgExpr -- ^ stack frame header function
               -> JSM JStgStat -- ^ size of the frame, including header
stackFrameSize :: JStgExpr -> JStgExpr -> JSM JStgStat
stackFrameSize JStgExpr
tgt JStgExpr
f =
  JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat
jIf (JStgExpr
f JStgExpr -> JStgExpr -> JStgExpr
.===. FastString -> JStgExpr
var FastString
"h$ap_gen") -- h$ap_gen is special
    (JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ JStgExpr
tgt JStgExpr -> JStgExpr -> JStgStat
|= (JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1) JStgExpr -> JStgExpr -> JStgExpr
.>>. JStgExpr
8) JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
2)
    ((JStgExpr -> JSM JStgStat) -> JSM JStgStat
forall t.
(JVarMagic t, ToJExpr t) =>
(t -> JSM JStgStat) -> JSM JStgStat
jVar (\JStgExpr
tag ->
              JStgStat -> JSM JStgStat
forall a. a -> StateT JEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (JStgStat -> JSM JStgStat) -> JStgStat -> JSM JStgStat
forall a b. (a -> b) -> a -> b
$ [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat
              [JStgExpr
tag JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
f JStgExpr -> FastString -> JStgExpr
.^ FastString
"size"
              , JStgExpr -> JStgStat -> JStgStat -> JStgStat
ifS (JStgExpr
tag JStgExpr -> JStgExpr -> JStgExpr
.<. JStgExpr
0)              -- if tag is less than 0
                (JStgExpr
tgt JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr
stack JStgExpr -> JStgExpr -> JStgExpr
.! (JStgExpr
sp JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
- JStgExpr
1))   -- set target to stack pointer - 1
                (JStgExpr
tgt JStgExpr -> JStgExpr -> JStgStat
|= JStgExpr -> JStgExpr
mask8 JStgExpr
tag JStgExpr -> JStgExpr -> JStgExpr
forall a. Num a => a -> a -> a
+ JStgExpr
1)       -- else set to mask'd tag + 1
              ]
          ))

  --------------------------------------------------------------------------------
-- Register utilities
--------------------------------------------------------------------------------

-- | Perform the computation 'f', on the range of registers bounded by 'start'
-- and 'end'.
withRegs :: StgReg -> StgReg -> (StgReg -> JStgStat) -> JStgStat
withRegs :: StgReg -> StgReg -> (StgReg -> JStgStat) -> JStgStat
withRegs StgReg
start StgReg
end StgReg -> JStgStat
f = [JStgStat] -> JStgStat
forall a. Monoid a => [a] -> a
mconcat ([JStgStat] -> JStgStat) -> [JStgStat] -> JStgStat
forall a b. (a -> b) -> a -> b
$ (StgReg -> JStgStat) -> [StgReg] -> [JStgStat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StgReg -> JStgStat
f [StgReg
start..StgReg
end]