{-|
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reg] -> ShowS
$cshowList :: [Reg] -> ShowS
show :: Reg -> String
$cshow :: Reg -> String
showsPrec :: Int -> Reg -> ShowS
$cshowsPrec :: Int -> Reg -> ShowS
Show, Reg -> Reg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reg -> Reg -> Bool
$c/= :: Reg -> Reg -> Bool
== :: Reg -> Reg -> Bool
$c== :: 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BC] -> ShowS
$cshowList :: [BC] -> ShowS
show :: BC -> String
$cshow :: BC -> String
showsPrec :: Int -> BC -> ShowS
$cshowsPrec :: Int -> 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 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) 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 forall a. Eq a => a -> a -> Bool
== Int
0
         then Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs forall a. [a] -> [a] -> [a]
++ [BC
STOREOLD, Int -> BC
BASETOP Int
0, Name -> BC
CALL Name
f] forall a. [a] -> [a] -> [a]
++ [BC]
ret
         else Int -> BC
RESERVENOALLOC Int
argCount forall a. a -> [a] -> [a]
: Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs forall a. [a] -> [a] -> [a]
++
            [BC
STOREOLD, Int -> BC
BASETOP Int
0, Int -> BC
ADDTOP Int
argCount, Name -> BC
CALL Name
f] forall a. [a] -> [a] -> [a]
++ [BC]
ret
   where
      ret :: [BC]
ret      = Reg -> Reg -> [BC]
assign Reg
reg Reg
RVal forall a. [a] -> [a] -> [a]
++ Bool -> [BC]
clean Bool
r
      argCount :: Int
argCount = 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs) forall a. a -> [a] -> [a]
: Int -> [LVar] -> [BC]
moveReg Int
0 [LVar]
vs
      forall a. [a] -> [a] -> [a]
++ [Int -> BC
SLIDE (forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs), Int -> BC
TOPBASE (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 (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, LVar) -> (a, Reg)
farg [(FDesc, LVar)]
args) 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 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 forall a. [a] -> [a] -> [a]
++ [Reg -> Reg -> BC
ASSIGN (Int -> Reg
L Int
i) Reg
reg]
                                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 (forall a b. (a -> b) -> [a] -> [b]
map LVar -> Reg
getL [LVar]
vs) 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)) = forall a. a -> Maybe a
Just (Int -> Reg
L Int
x)
          getAllocLoc Maybe LVar
_ = 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 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 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 (forall a b. (a -> b) -> [a] -> [b]
map LVar -> Reg
getL [LVar]
vs) 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 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 = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Can't compile " forall a. [a] -> [a] -> [a]
++ 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) forall a. [a] -> [a] -> [a]
++ Int -> [LVar] -> [BC]
moveReg (Int
off forall a. Num a => a -> a -> a
+ Int
1) [LVar]
xs

assign :: Reg -> Reg -> [BC]
assign Reg
r1 Reg
r2 | Reg
r1 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 (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 (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (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)
    = forall a. a -> Maybe a
Just (Int
tag, Reg -> Int -> Int -> BC
PROJECT Reg
l Int
lvar (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args) forall a. a -> [a] -> [a]
: Reg -> SExp -> Bool -> [BC]
bc Reg
reg SExp
e Bool
r)
caseAlt Reg
l Reg
reg Bool
r SAlt
_ = 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)
    = 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
_ = forall a. Maybe a
Nothing

defaultAlt :: Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [] Bool
r = forall a. Maybe a
Nothing
defaultAlt Reg
reg (SDefaultCase SExp
e : [SAlt]
_) Bool
r = 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