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
showList :: [Reg] -> ShowS
$cshowList :: [Reg] -> ShowS
show :: Reg -> String
$cshow :: Reg -> String
showsPrec :: Int -> Reg -> ShowS
$cshowsPrec :: Int -> Reg -> ShowS
Show, Reg -> Reg -> Bool
(Reg -> Reg -> Bool) -> (Reg -> Reg -> Bool) -> Eq Reg
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 =
ASSIGN Reg Reg
| ASSIGNCONST Reg Const
| UPDATE Reg Reg
| MKCON Reg (Maybe Reg) Int [Reg]
| CASE Bool
Reg [(Int, [BC])] (Maybe [BC])
| PROJECT Reg Int Int
| PROJECTINTO Reg Reg Int
| CONSTCASE Reg [(Const, [BC])] (Maybe [BC])
| CALL Name
| TAILCALL Name
| FOREIGNCALL Reg FDesc FDesc [(FDesc, Reg)]
| SLIDE Int
| REBASE
| RESERVE Int
| RESERVENOALLOC Int
| ADDTOP Int
| TOPBASE Int
| BASETOP Int
| STOREOLD
| OP Reg PrimFn [Reg]
| NULL Reg
| 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
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 (n :: Name
n, SFun n' :: Name
n' args :: [Name]
args locs :: Int
locs exp :: 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 0 = []
reserve n :: Int
n = [Int -> BC
RESERVE Int
n, Int -> BC
ADDTOP Int
n]
clean :: Bool -> [BC]
clean True = [Int -> BC
TOPBASE 0, BC
REBASE]
clean False = []
bc :: Reg -> SExp -> Bool ->
[BC]
bc :: Reg -> SExp -> Bool -> [BC]
bc reg :: Reg
reg (SV (Glob n :: Name
n)) r :: Bool
r = Reg -> SExp -> Bool -> [BC]
bc Reg
reg (Bool -> Name -> [LVar] -> SExp
SApp Bool
False Name
n []) Bool
r
bc reg :: Reg
reg (SV (Loc i :: Int
i)) r :: 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
reg (SApp False f :: Name
f vs :: [LVar]
vs) r :: Bool
r =
if Int
argCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then Int -> [LVar] -> [BC]
moveReg 0 [LVar]
vs [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [BC
STOREOLD, Int -> BC
BASETOP 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 0 [LVar]
vs [BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++
[BC
STOREOLD, Int -> BC
BASETOP 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 (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs
bc reg :: Reg
reg (SApp True f :: Name
f vs :: [LVar]
vs) r :: Bool
r
= Int -> BC
RESERVENOALLOC ([LVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs) BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Int -> [LVar] -> [BC]
moveReg 0 [LVar]
vs
[BC] -> [BC] -> [BC]
forall a. [a] -> [a] -> [a]
++ [Int -> BC
SLIDE ([LVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs), Int -> BC
TOPBASE ([LVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LVar]
vs), Name -> BC
TAILCALL Name
f]
bc reg :: Reg
reg (SForeign t :: FDesc
t fname :: FDesc
fname args :: [(FDesc, LVar)]
args) r :: 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 (ty :: a
ty, Loc i :: Int
i) = (a
ty, Int -> Reg
L Int
i)
bc reg :: Reg
reg (SLet (Loc i :: Int
i) e :: SExp
e sc :: SExp
sc) r :: 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
reg (SUpdate (Loc i :: Int
i) sc :: SExp
sc) r :: 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 :: Reg
reg (SCon atloc :: Maybe LVar
atloc i :: Int
i _ vs :: [LVar]
vs) r :: 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 x :: Int
x) = Int -> Reg
L Int
x
getAllocLoc :: Maybe LVar -> Maybe Reg
getAllocLoc (Just (Loc x :: Int
x)) = Reg -> Maybe Reg
forall a. a -> Maybe a
Just (Int -> Reg
L Int
x)
getAllocLoc _ = Maybe Reg
forall a. Maybe a
Nothing
bc reg :: Reg
reg (SProj (Loc l :: Int
l) i :: Int
i) r :: 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
reg (SConst i :: Const
i) r :: 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
reg (SOp p :: PrimFn
p vs :: [LVar]
vs) r :: 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 x :: Int
x) = Int -> Reg
L Int
x
bc reg :: Reg
reg (SError str :: String
str) r :: Bool
r = [String -> BC
ERROR String
str]
bc reg :: Reg
reg SNothing r :: Bool
r = Reg -> BC
NULL Reg
reg BC -> [BC] -> [BC]
forall a. a -> [a] -> [a]
: Bool -> [BC]
clean Bool
r
bc reg :: Reg
reg (SCase up :: CaseType
up (Loc l :: Int
l) alts :: [SAlt]
alts) r :: 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
reg (SChkCase (Loc l :: Int
l) alts :: [SAlt]
alts) r :: 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
reg t :: SExp
t r :: Bool
r = String -> [BC]
forall a. HasCallStack => String -> a
error (String -> [BC]) -> String -> [BC]
forall a b. (a -> b) -> a -> b
$ "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 _ _ : xs :: [SAlt]
xs) = Bool
True
isConst (SConCase _ _ _ _ _ : xs :: [SAlt]
xs) = Bool
False
isConst (_ : xs :: [SAlt]
xs) = Bool
False
moveReg :: Int -> [LVar] -> [BC]
moveReg off :: Int
off [] = []
moveReg off :: Int
off (Loc x :: Int
x : xs :: [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
+ 1) [LVar]
xs
assign :: Reg -> Reg -> [BC]
assign r1 :: Reg
r1 r2 :: 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 safe :: Bool
safe reg :: Reg
reg l :: Reg
l xs :: [SAlt]
xs r :: 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 :: Reg
l xs :: [SAlt]
xs r :: 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 l :: Reg
l reg :: Reg
reg r :: Bool
r (SConCase lvar :: Int
lvar tag :: Int
tag _ args :: [Name]
args e :: 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 (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 l :: Reg
l reg :: Reg
reg r :: Bool
r _ = Maybe (Int, [BC])
forall a. Maybe a
Nothing
constAlt :: p -> Reg -> Bool -> SAlt -> Maybe (Const, [BC])
constAlt l :: p
l reg :: Reg
reg r :: Bool
r (SConstCase c :: Const
c e :: 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 l :: p
l reg :: Reg
reg r :: Bool
r _ = Maybe (Const, [BC])
forall a. Maybe a
Nothing
defaultAlt :: Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt reg :: Reg
reg [] r :: Bool
r = Maybe [BC]
forall a. Maybe a
Nothing
defaultAlt reg :: Reg
reg (SDefaultCase e :: SExp
e : _) r :: 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
reg (_ : xs :: [SAlt]
xs) r :: Bool
r = Reg -> [SAlt] -> Bool -> Maybe [BC]
defaultAlt Reg
reg [SAlt]
xs Bool
r