Regs.hs

{-# LANGUAGE OverloadedStrings #-}

module GHC.StgToJS.Regs
  ( StgReg (..)
  , Special(..)
  , sp
  , stack
  , r1, r2, r3, r4
  , regsFromR1
  , regsFromR2
  , jsRegsFromR1
  , jsRegsFromR2
  , StgRet (..)
  , jsRegToInt
  , intToJSReg
  , jsReg
  , maxReg
  , minReg
  , lowRegs
  , retRegs
  , register
  , foreignRegister
  )
where

import GHC.Prelude

import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make

import GHC.StgToJS.Symbols

import GHC.Data.FastString

import Data.Array
import qualified Data.ByteString.Char8 as BSC
import Data.Char
import Data.Semigroup ((<>))

-- | General purpose "registers"
--
-- The JS backend arbitrarily supports 128 registers
data StgReg
  = R1  | R2  | R3  | R4  | R5  | R6  | R7  | R8
  | R9  | R10 | R11 | R12 | R13 | R14 | R15 | R16
  | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24
  | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32
  | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40
  | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48
  | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56
  | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64
  | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72
  | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80
  | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88
  | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96
  | R97  | R98  | R99  | R100 | R101 | R102 | R103 | R104
  | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112
  | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120
  | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128
  deriving (Eq, Ord, Show, Enum, Bounded, Ix)

-- | Stack registers
data Special
  = Stack
  | Sp
  deriving (Show, Eq)

-- | Return registers
--
-- Extra results from foreign calls can be stored here (while first result is
-- directly returned)
data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10
  deriving (Eq, Ord, Show, Enum, Bounded, Ix)

instance ToJExpr Special where
  toJExpr Stack  = hdStack
  toJExpr Sp     = hdStackPtr

instance ToJExpr StgReg where
  toJExpr r = registers ! r

instance ToJExpr StgRet where
  toJExpr r = rets ! r

---------------------------------------------------
-- helpers
---------------------------------------------------

sp :: JStgExpr
sp = toJExpr Sp

stack :: JStgExpr
stack = toJExpr Stack

r1, r2, r3, r4 :: JStgExpr
r1 = toJExpr R1
r2 = toJExpr R2
r3 = toJExpr R3
r4 = toJExpr R4


jsRegToInt :: StgReg -> Int
jsRegToInt = (+1) . fromEnum

intToJSReg :: Int -> StgReg
intToJSReg r = toEnum (r - 1)

jsReg :: Int -> JStgExpr
jsReg r = toJExpr (intToJSReg r)

maxReg :: Int
maxReg = jsRegToInt maxBound

minReg :: Int
minReg = jsRegToInt minBound

-- | List of registers, starting from R1
regsFromR1 :: [StgReg]
regsFromR1 = enumFrom R1

-- | List of registers, starting from R2
regsFromR2 :: [StgReg]
regsFromR2 = tail regsFromR1

-- | List of registers, starting from R1 as JStgExpr
jsRegsFromR1 :: [JStgExpr]
jsRegsFromR1 = fmap toJExpr regsFromR1

-- | List of registers, starting from R2 as JExpr
jsRegsFromR2 :: [JStgExpr]
jsRegsFromR2 = tail jsRegsFromR1

---------------------------------------------------
-- caches
---------------------------------------------------

lowRegs :: [Ident]
lowRegs = map reg_to_ident [R1 .. R31]
  where reg_to_ident = name . mkFastString . (unpackFS hdStr ++) . map toLower . show

retRegs :: [Ident]
retRegs = [name . mkFastStringByteString
           $ hdB <> BSC.pack (map toLower $ show n) | n <- enumFrom Ret1]

-- cache JExpr representing StgReg
registers :: Array StgReg JStgExpr
registers = listArray (minBound, maxBound) (map (global . identFS) lowRegs ++ map regN [R32 .. R128])
  where
    regN :: StgReg -> JStgExpr
    regN r = IdxExpr hdRegs (toJExpr (fromEnum r - 32))

-- cache JExpr representing StgRet
rets :: Array StgRet JStgExpr
rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1))
  where
    retN = global . mkFastString . (unpackFS hdStr ++) . map toLower . show

-- | Given a register, return the JS syntax object representing that register
register :: StgReg -> JStgExpr
register i = registers ! i

-- | Given a register, return the JS syntax object representing that register
foreignRegister :: StgRet -> JStgExpr
foreignRegister i = rets ! i