{-|
Module      : IRTS.Bytecode
Description : Bytecode for a stack based VM (e.g. for generating C code with an accurate hand written GC)


License     : BSD3
Maintainer  : The Idris Community.


BASE: Current stack frame's base
TOP:  Top of stack
OLDBASE: Passed in to each function, the previous stack frame's base

L i refers to the stack item at BASE + i
T i refers to the stack item at TOP + i

RVal is a register in which computed values (essentially, what a function
returns) are stored.

-}
module IRTS.Bytecode where


import Idris.Core.TT
import IRTS.Defunctionalise
import IRTS.Simplified

import Data.Maybe

data Reg = RVal | L Int | T Int | Tmp
   deriving (Int -> Reg -> ShowS
[Reg] -> ShowS
Reg -> String
(Int -> Reg -> ShowS)
-> (Reg -> String) -> ([Reg] -> ShowS) -> Show Reg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reg -> ShowS
showsPrec :: Int -> Reg -> ShowS
$cshow :: Reg -> String
show :: Reg -> String
$cshowList :: [Reg] -> ShowS
showList :: [Reg] -> ShowS
Show, Reg -> Reg -> Bool
(Reg -> Reg -> Bool) -> (Reg -> Reg -> Bool) -> Eq Reg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Reg -> Reg -> Bool
== :: Reg -> Reg -> Bool
$c/= :: Reg -> Reg -> Bool
/= :: Reg -> Reg -> Bool
Eq)

data BC =
    -- | reg1 = reg2
    ASSIGN Reg Reg

    -- | reg = const
  | ASSIGNCONST Reg Const

    -- | reg1 = reg2 (same as assign, it seems)
  | UPDATE Reg Reg

    -- | reg = constructor, where constructor consists of a tag and
    -- values from registers, e.g. (cons tag args)
    -- the 'Maybe Reg', if set, is a register which can be overwritten
    -- (i.e. safe for mutable update), though this can be ignored
  | MKCON Reg (Maybe Reg) Int [Reg]

    -- | Matching on value of reg: usually (but not always) there are
    -- constructors, hence "Int" for patterns (that's a tag on which
    -- we should match), and the following [BC] is just a list of
    -- instructions for the corresponding case. The last argument is
    -- for default case. When it's not necessary a constructor in the
    -- reg, the Bool should be False, indicating that it's not safe to
    -- work with that as with a constructor, so a check should be
    -- added. If it's not a constructor, default case should be used.
  | CASE Bool
    Reg [(Int, [BC])] (Maybe [BC])

    -- | get a value from register, which should be a constructor, and
    -- put its arguments into the stack, starting from (base + int1)
    -- and onwards; second Int provides arity
  | PROJECT Reg Int Int

    -- | probably not used
  | PROJECTINTO Reg Reg Int -- project argument from one reg into another

    -- | same as CASE, but there's an exact value (not constructor) in reg
  | CONSTCASE Reg [(Const, [BC])] (Maybe [BC])

    -- | just call a function, passing MYOLDBASE (see below) to it
  | CALL Name

    -- | same, perhaps exists just for TCO
  | TAILCALL Name

    -- | set reg to (apply string args),
  | FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)]

    -- | move this number of elements from TOP to BASE
  | SLIDE Int

    -- | set BASE = OLDBASE
  | REBASE

    -- | reserve n more stack items (i.e. check there's space, grow if
    -- necessary)
  | RESERVE Int
  | RESERVENOALLOC Int

    -- | move the top of stack up
  | ADDTOP Int

    -- | set TOP = BASE + n
  | TOPBASE Int

    -- | set BASE = TOP + n
  | BASETOP Int

    -- | set MYOLDBASE = BASE, where MYOLDBASE is a function-local
    -- variable, set to OLDBASE by default, and passed on function
    -- call to called functions as their OLDBASE
  | STOREOLD

    -- | reg = apply primitive_function args
  | OP Reg PrimFn [Reg]

    -- | clear reg
  | NULL Reg

    -- | throw an error
  | ERROR String
  deriving Int -> BC -> ShowS
[BC] -> ShowS
BC -> String
(Int -> BC -> ShowS)
-> (BC -> String) -> ([BC] -> ShowS) -> Show BC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BC -> ShowS
showsPrec :: Int -> BC -> ShowS
$cshow :: BC -> String
show :: BC -> String
$cshowList :: [BC] -> ShowS
showList :: [BC] -> ShowS
Show

toBC :: (Name, SDecl) -> (Name, [BC])
toBC :: (Name, SDecl) -> (Name, [BC])
toBC (Name
n, SFun Name
n' [Name]
args Int
locs SExp
exp)
   = (Name
n, Int -> [BC]
reserve Int
locs [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Reg -> SExp -> Bool -> [BC]
bc Reg
RVal SExp
exp Bool
True)
  where reserve :: Int -> [BC]
reserve Int
0 = []
        reserve Int
n = [Int -> BC
RESERVE Int
n, Int -> BC
ADDTOP Int
n]

clean :: Bool -> [BC]
clean Bool
True  = [Int -> BC
TOPBASE Int
0, BC
REBASE]
clean Bool
False = []

bc :: Reg -> SExp -> Bool -> -- returning
      [BC]
bc :: Reg -> SExp -> Bool -> [BC]
bc Reg
reg (SV (Glob Name
n)) Bool
r = Reg -> SExp -> Bool -> [BC]
bc Reg
reg (Bool -> Name -> [LVar] -> SExp
SApp Bool
False Name
n []) Bool
r
bc Reg
reg (SV (Loc Int
i))  Bool
r = Reg -> Reg -> [BC]
assign Reg
reg (Int -> Reg
L Int
i) [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Bool -> [BC]
clean Bool
r
bc Reg
reg (SApp Bool
False Name
f [LVar]
vs) Bool
r =
      if Int
argCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
         then Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [BC
STOREOLD, Int -> BC
BASETOP Int
0, Name -> BC
CALL Name
f] [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [BC]
ret
         else Int -> BC
RESERVENOALLOC Int
argCount BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++
            [BC
STOREOLD, Int -> BC
BASETOP Int
0, Int -> BC
ADDTOP Int
argCount, Name -> BC
CALL Name
f] [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [BC]
ret
   where
      ret :: [BC]
ret      = Reg -> Reg -> [BC]
assign Reg
reg Reg
RVal [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Bool -> [BC]
clean Bool
r
      argCount :: Int
argCount = [LVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs
bc Reg
reg (SApp Bool
True Name
f [LVar]
vs) Bool
r
    = Int -> BC
RESERVENOALLOC ([LVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs
      [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [Int -> BC
SLIDE ([LVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs), Int -> BC
TOPBASE ([LVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs), Name -> BC
TAILCALL Name
f]
bc Reg
reg (SForeign FDesc
t FDesc
fname [(FDesc, LVar)]
args) Bool
r
    = Reg -> FDesc -> FDesc -> [(FDesc, Reg)] -> BC
FOREIGNCALL Reg
reg FDesc
t FDesc
fname (((FDesc, LVar) -> (FDesc, Reg))
-> [(FDesc, LVar)] -> [(FDesc, Reg)]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, LVar) -> (FDesc, Reg)
forall {a}. (a, LVar) -> (a, Reg)
farg [(FDesc, LVar)]
args) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
  where farg :: (a, LVar) -> (a, Reg)
farg (a
ty, Loc Int
i) = (a
ty, Int -> Reg
L Int
i)
bc Reg
reg (SLet (Loc Int
i) SExp
e SExp
sc) Bool
r = Reg -> SExp -> Bool -> [BC]
bc (Int -> Reg
L Int
i) SExp
e Bool
False [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
sc Bool
r
bc Reg
reg (SUpdate (Loc Int
i) SExp
sc) Bool
r = Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
sc Bool
False [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [Reg -> Reg -> BC
ASSIGN (Int -> Reg
L Int
i) Reg
reg]
                                [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Bool -> [BC]
clean Bool
r
-- bc reg (SUpdate x sc) r = bc reg sc r -- can't update, just do it
bc Reg
reg (SCon Maybe LVar
atloc Int
i Name
_ [LVar]
vs) Bool
r
  = Reg -> Maybe Reg -> Int -> [Reg] -> BC
MKCON Reg
reg (Maybe LVar -> Maybe Reg
getAllocLoc Maybe LVar
atloc) Int
i ((LVar -> Reg) -> [LVar] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map LVar -> Reg
getL [LVar]
vs) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
    where getL :: LVar -> Reg
getL (Loc Int
x) = Int -> Reg
L Int
x
          getAllocLoc :: Maybe LVar -> Maybe Reg
getAllocLoc (Just (Loc Int
x)) = Reg -> Maybe Reg
forall a. a -> Maybe a
Just (Int -> Reg
L Int
x)
          getAllocLoc Maybe LVar
_ = Maybe Reg
forall a. Maybe a
Nothing
bc Reg
reg (SProj (Loc Int
l) Int
i) Bool
r = Reg -> Reg -> Int -> BC
PROJECTINTO Reg
reg (Int -> Reg
L Int
l) Int
i BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
bc Reg
reg (SConst Const
i) Bool
r = Reg -> Const -> BC
ASSIGNCONST Reg
reg Const
i BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
bc Reg
reg (SOp PrimFn
p [LVar]
vs) Bool
r = Reg -> PrimFn -> [Reg] -> BC
OP Reg
reg PrimFn
p ((LVar -> Reg) -> [LVar] -> [Reg]
forall a b. (a -> b) -> [a] -> [b]
map LVar -> Reg
getL [LVar]
vs) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
    where getL :: LVar -> Reg
getL (Loc Int
x) = Int -> Reg
L Int
x
bc Reg
reg (SError String
str) Bool
r = [String -> BC
ERROR String
str]
bc Reg
reg SExp
SNothing Bool
r = Reg -> BC
NULL Reg
reg BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
bc Reg
reg (SCase CaseType
up (Loc Int
l) [SAlt]
alts) Bool
r
   | [SAlt] -> Bool
isConst [SAlt]
alts = Reg -> Reg -> [SAlt] -> Bool -> [BC]
constCase Reg
reg (Int -> Reg
L Int
l) [SAlt]
alts Bool
r
   | Bool
otherwise = Bool -> Reg -> Reg -> [SAlt] -> Bool -> [BC]
conCase Bool
True Reg
reg (Int -> Reg
L Int
l) [SAlt]
alts Bool
r
bc Reg
reg (SChkCase (Loc Int
l) [SAlt]
alts) Bool
r
   = Bool -> Reg -> Reg -> [SAlt] -> Bool -> [BC]
conCase Bool
False Reg
reg (Int -> Reg
L Int
l) [SAlt]
alts Bool
r
bc Reg
reg SExp
t Bool
r = String -> [BC]
forall a. HasCallStack => String -> a
error (String -> [BC]) -> String -> [BC]
forall a b. (a -> b) -> a -> b
$ String
"Can't compile " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExp -> String
forall a. Show a => a -> String
show SExp
t

isConst :: [SAlt] -> Bool
isConst [] = Bool
False
isConst (SConstCase Const
_ SExp
_ : [SAlt]
xs) = Bool
True
isConst (SConCase Int
_ Int
_ Name
_ [Name]
_ SExp
_ : [SAlt]
xs) = Bool
False
isConst (SAlt
_ : [SAlt]
xs) = Bool
False

moveReg :: Int -> [LVar] -> [BC]
moveReg Int
off [] = []
moveReg Int
off (Loc Int
x : [LVar]
xs) = Reg -> Reg -> [BC]
assign (Int -> Reg
T Int
off) (Int -> Reg
L Int
x) [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ Int -> [LVar] -> [BC]
moveReg (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [LVar]
xs

assign :: Reg -> Reg -> [BC]
assign Reg
r1 Reg
r2 | Reg
r1 Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r2 = []
             | Bool
otherwise = [Reg -> Reg -> BC
ASSIGN Reg
r1 Reg
r2]

conCase :: Bool -> Reg -> Reg -> [SAlt] -> Bool -> [BC]
conCase Bool
safe Reg
reg Reg
l [SAlt]
xs Bool
r = [Bool -> Reg -> [(Int, [BC])] -> Maybe [BC] -> BC
CASE Bool
safe Reg
l ((SAlt -> Maybe (Int, [BC])) -> [SAlt] -> [(Int, [BC])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Reg -> Reg -> Bool -> SAlt -> Maybe (Int, [BC])
caseAlt Reg
l Reg
reg Bool
r) [SAlt]
xs)
                                (Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [SAlt]
xs Bool
r)]

constCase :: Reg -> Reg -> [SAlt] -> Bool -> [BC]
constCase Reg
reg Reg
l [SAlt]
xs Bool
r = [Reg -> [(Const, [BC])] -> Maybe [BC] -> BC
CONSTCASE Reg
l ((SAlt -> Maybe (Const, [BC])) -> [SAlt] -> [(Const, [BC])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Reg -> Reg -> Bool -> SAlt -> Maybe (Const, [BC])
forall {p}. p -> Reg -> Bool -> SAlt -> Maybe (Const, [BC])
constAlt Reg
l Reg
reg Bool
r) [SAlt]
xs)
                               (Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [SAlt]
xs Bool
r)]

caseAlt :: Reg -> Reg -> Bool -> SAlt -> Maybe (Int, [BC])
caseAlt Reg
l Reg
reg Bool
r (SConCase Int
lvar Int
tag Name
_ [Name]
args SExp
e)
    = (Int, [BC]) -> Maybe (Int, [BC])
forall a. a -> Maybe a
Just (Int
tag, Reg -> Int -> Int -> BC
PROJECT Reg
l Int
lvar ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
e Bool
r)
caseAlt Reg
l Reg
reg Bool
r SAlt
_ = Maybe (Int, [BC])
forall a. Maybe a
Nothing

constAlt :: p -> Reg -> Bool -> SAlt -> Maybe (Const, [BC])
constAlt p
l Reg
reg Bool
r (SConstCase Const
c SExp
e)
    = (Const, [BC]) -> Maybe (Const, [BC])
forall a. a -> Maybe a
Just (Const
c, Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
e Bool
r)
constAlt p
l Reg
reg Bool
r SAlt
_ = Maybe (Const, [BC])
forall a. Maybe a
Nothing

defaultAlt :: Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [] Bool
r = Maybe [BC]
forall a. Maybe a
Nothing
defaultAlt Reg
reg (SDefaultCase SExp
e : [SAlt]
_) Bool
r = [BC] -> Maybe [BC]
forall a. a -> Maybe a
Just (Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
e Bool
r)
defaultAlt Reg
reg (SAlt
_ : [SAlt]
xs) Bool
r = Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [SAlt]
xs Bool
r