{-# 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.Unsat.Syntax
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 @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS
-- program
traceRts :: StgToJSConfig -> JExpr -> JStat
traceRts :: StgToJSConfig -> JExpr -> JStat
traceRts StgToJSConfig
s JExpr
ex | (StgToJSConfig -> Bool
csTraceRts StgToJSConfig
s)  = FastString -> [JExpr] -> JStat
appS FastString
"h$log" [JExpr
ex]
              | Bool
otherwise       = JStat
forall a. Monoid a => a
mempty

-- | Syntactic sugar. Given a @JExpr@, '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 -> JExpr -> a -> JStat
assertRts :: forall a. ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
assertRts StgToJSConfig
s JExpr
ex a
m | StgToJSConfig -> Bool
csAssertRts StgToJSConfig
s = JExpr -> JStat -> JStat
jwhenS (JUOp -> JExpr -> JExpr
UOpExpr JUOp
NotOp JExpr
ex) (FastString -> [JExpr] -> JStat
appS FastString
"throw" [a -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr a
m])
                 | Bool
otherwise     = JStat
forall a. Monoid a => a
mempty

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

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

-- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
stackFrameSize :: JExpr -- ^ assign frame size to this
               -> JExpr -- ^ stack frame header function
               -> JStat -- ^ size of the frame, including header
stackFrameSize :: JExpr -> JExpr -> JStat
stackFrameSize JExpr
tgt JExpr
f =
  JExpr -> JStat -> JStat -> JStat
ifS (JExpr
f JExpr -> JExpr -> JExpr
.===. FastString -> JExpr
var FastString
"h$ap_gen") -- h$ap_gen is special
      (JExpr
tgt JExpr -> JExpr -> JStat
|= (JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1) JExpr -> JExpr -> JExpr
.>>. JExpr
8) JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
2)
      ((JExpr -> JStat) -> JStat
forall a. ToSat a => a -> JStat
jVar (\JExpr
tag ->
               [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat
               [JExpr
tag JExpr -> JExpr -> JStat
|= JExpr
f JExpr -> FastString -> JExpr
.^ FastString
"size"
               , JExpr -> JStat -> JStat -> JStat
ifS (JExpr
tag JExpr -> JExpr -> JExpr
.<. JExpr
0)              -- if tag is less than 0
                 (JExpr
tgt JExpr -> JExpr -> JStat
|= JExpr
stack JExpr -> JExpr -> JExpr
.! (JExpr
sp JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
- JExpr
1))   -- set target to stack pointer - 1
                 (JExpr
tgt JExpr -> JExpr -> JStat
|= JExpr -> JExpr
mask8 JExpr
tag JExpr -> JExpr -> JExpr
forall a. Num a => a -> a -> a
+ JExpr
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 -> JStat) -> JStat
withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
withRegs StgReg
start StgReg
end StgReg -> JStat
f = [JStat] -> JStat
forall a. Monoid a => [a] -> a
mconcat ([JStat] -> JStat) -> [JStat] -> JStat
forall a b. (a -> b) -> a -> b
$ (StgReg -> JStat) -> [StgReg] -> [JStat]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StgReg -> JStat
f [StgReg
start..StgReg
end]