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 =
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
$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 ->
[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
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