module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF(CId,utf8CId)
import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
generateByteCode SourceGrammar
gr Int
arity [L Equation]
eqs =
let ([[Instr]]
bs,[Instr]
instrs) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [IVal]
is
((L Equation -> ([(Ident, IVal)], [Patt], Term))
-> [L Equation] -> [([(Ident, IVal)], [Patt], Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\(L Location
_ ([Patt]
ps,Term
t)) -> ([],[Patt]
ps,Term
t)) [L Equation]
eqs)
Maybe (Int, Int)
forall a. Maybe a
Nothing
[[Instr]
b]
b :: [Instr]
b = if Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| [L Equation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [L Equation]
eqs
then [Instr]
instrs
else Int -> Instr
CHECK_ARGS Int
arityInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs
in case [[Instr]]
bs of
[[Instr
FAIL]] -> []
[[Instr]]
_ -> [[Instr]] -> [[Instr]]
forall a. [a] -> [a]
reverse [[Instr]]
bs
where
is :: [IVal]
is = Int -> Int -> [IVal] -> [IVal]
push_is (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
arity []
compileEquations :: SourceGrammar -> Int -> Int -> [IVal] -> [([(Ident,IVal)],[Patt],Term)] -> Maybe (Int,CodeLabel) -> [[Instr]] -> ([[Instr]],[Instr])
compileEquations :: SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity Int
st [IVal]
_ [] Maybe (Int, Int)
fl [[Instr]]
bs = ([[Instr]]
bs,Int -> Int -> Maybe (Int, Int) -> [Instr]
mkFail Int
arity Int
st Maybe (Int, Int)
fl)
compileEquations SourceGrammar
gr Int
arity Int
st [] (([(Ident, IVal)]
vs,[],Term
t):[([(Ident, IVal)], [Patt], Term)]
_) Maybe (Int, Int)
fl [[Instr]]
bs = SourceGrammar
-> Int
-> Int
-> [(Ident, IVal)]
-> Term
-> [[Instr]]
-> ([[Instr]], [Instr])
compileBody SourceGrammar
gr Int
arity Int
st [(Ident, IVal)]
vs Term
t [[Instr]]
bs
compileEquations SourceGrammar
gr Int
arity Int
st (IVal
i:[IVal]
is) [([(Ident, IVal)], [Patt], Term)]
eqs Maybe (Int, Int)
fl [[Instr]]
bs = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
forall k a. Map k a
Map.empty
where
whilePP :: [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [] Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = case Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns of
[] -> ([[Instr]]
bs,[Instr
FAIL])
(((Term, Int), [([(Ident, IVal)], [Patt], Term)])
cn:[((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
cns) -> let ([[Instr]]
bs1,[Instr]
instrs1) = Maybe (Int, Int)
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> ([[Instr]], [Instr])
compileBranch0 Maybe (Int, Int)
fl [[Instr]]
bs ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
cn
bs2 :: [[Instr]]
bs2 = ([[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)]) -> [[Instr]])
-> [[Instr]]
-> [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
-> [[Instr]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Maybe (Int, Int)
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> [[Instr]]
forall p.
p
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> [[Instr]]
compileBranch Maybe (Int, Int)
fl) [[Instr]]
bs1 [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
cns
bs3 :: [[Instr]]
bs3 = Int -> Int -> Maybe (Int, Int) -> [Instr]
mkFail Int
arity Int
st Maybe (Int, Int)
fl [Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
: [[Instr]]
bs2
in ([[Instr]]
bs3,[Instr
PUSH_FRAME, IVal -> TailInfo -> Instr
EVAL (Int -> IVal -> IVal
shiftIVal (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) IVal
i) TailInfo
RecCall] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Instr]
instrs1)
whilePP (([(Ident, IVal)]
vs, PP QIdent
c [Patt]
ps' : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs (([([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)])
-> (Term, Int)
-> [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. [a] -> [a] -> [a]
(++) (QIdent -> Term
Q QIdent
c,[Patt] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Patt]
ps') [([(Ident, IVal)]
vs,[Patt]
ps'[Patt] -> [Patt] -> [Patt]
forall a. [a] -> [a] -> [a]
++[Patt]
ps,Term
t)] Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns)
whilePP (([(Ident, IVal)]
vs, PInt Int
n : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs (([([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)])
-> (Term, Int)
-> [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. [a] -> [a] -> [a]
(++) (Int -> Term
EInt Int
n,Int
0) [([(Ident, IVal)]
vs,[Patt]
ps,Term
t)] Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns)
whilePP (([(Ident, IVal)]
vs, PString String
s: [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs (([([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)])
-> (Term, Int)
-> [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. [a] -> [a] -> [a]
(++) (String -> Term
K String
s,Int
0) [([(Ident, IVal)]
vs,[Patt]
ps,Term
t)] Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns)
whilePP (([(Ident, IVal)]
vs, PFloat Double
d : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs (([([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)])
-> (Term, Int)
-> [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. [a] -> [a] -> [a]
(++) (Double -> Term
EFloat Double
d,Int
0) [([(Ident, IVal)]
vs,[Patt]
ps,Term
t)] Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns)
whilePP (([(Ident, IVal)]
vs, PImplArg Patt
p:[Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP (([(Ident, IVal)]
vs,Patt
pPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps,Term
t)([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
:[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns
whilePP (([(Ident, IVal)]
vs, PT Term
_ Patt
p : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP (([(Ident, IVal)]
vs,Patt
pPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps,Term
t)([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
:[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns
whilePP (([(Ident, IVal)]
vs, PAs Ident
x Patt
p : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = [([(Ident, IVal)], [Patt], Term)]
-> Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> ([[Instr]], [Instr])
whilePP (((Ident
x,IVal
i)(Ident, IVal) -> [(Ident, IVal)] -> [(Ident, IVal)]
forall a. a -> [a] -> [a]
:[(Ident, IVal)]
vs,Patt
pPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps,Term
t)([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
:[([(Ident, IVal)], [Patt], Term)]
eqs) Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns
whilePP [([(Ident, IVal)], [Patt], Term)]
eqs Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns = case Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
-> [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Term, Int) [([(Ident, IVal)], [Patt], Term)]
cns of
[] -> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV [([(Ident, IVal)], [Patt], Term)]
eqs []
(((Term, Int), [([(Ident, IVal)], [Patt], Term)])
cn:[((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
cns) -> let fl1 :: Maybe (Int, Int)
fl1 = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
st,[[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs2)
([[Instr]]
bs1,[Instr]
instrs1) = Maybe (Int, Int)
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> ([[Instr]], [Instr])
compileBranch0 Maybe (Int, Int)
fl1 [[Instr]]
bs ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
cn
bs2 :: [[Instr]]
bs2 = ([[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)]) -> [[Instr]])
-> [[Instr]]
-> [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
-> [[Instr]]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Maybe (Int, Int)
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> [[Instr]]
forall p.
p
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> [[Instr]]
compileBranch Maybe (Int, Int)
fl1) [[Instr]]
bs1 [((Term, Int), [([(Ident, IVal)], [Patt], Term)])]
cns
([[Instr]]
bs3,[Instr]
instrs3) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity Int
st (IVal
iIVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
:[IVal]
is) [([(Ident, IVal)], [Patt], Term)]
eqs Maybe (Int, Int)
fl ([Instr]
instrs3[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs2)
in ([[Instr]]
bs3,[Instr
PUSH_FRAME, IVal -> TailInfo -> Instr
EVAL (Int -> IVal -> IVal
shiftIVal (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) IVal
i) TailInfo
RecCall] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Instr]
instrs1)
whilePV :: [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV [] [([(Ident, IVal)], [Patt], Term)]
vrs = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity Int
st [IVal]
is [([(Ident, IVal)], [Patt], Term)]
vrs Maybe (Int, Int)
fl [[Instr]]
bs
whilePV (([(Ident, IVal)]
vs, PV Ident
x : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs = [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV [([(Ident, IVal)], [Patt], Term)]
eqs (((Ident
x,IVal
i)(Ident, IVal) -> [(Ident, IVal)] -> [(Ident, IVal)]
forall a. a -> [a] -> [a]
:[(Ident, IVal)]
vs,[Patt]
ps,Term
t) ([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
: [([(Ident, IVal)], [Patt], Term)]
vrs)
whilePV (([(Ident, IVal)]
vs, Patt
PW : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs = [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV [([(Ident, IVal)], [Patt], Term)]
eqs (( [(Ident, IVal)]
vs,[Patt]
ps,Term
t) ([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
: [([(Ident, IVal)], [Patt], Term)]
vrs)
whilePV (([(Ident, IVal)]
vs, PTilde Term
_ : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs = [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV [([(Ident, IVal)], [Patt], Term)]
eqs (( [(Ident, IVal)]
vs,[Patt]
ps,Term
t) ([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
: [([(Ident, IVal)], [Patt], Term)]
vrs)
whilePV (([(Ident, IVal)]
vs, PImplArg Patt
p:[Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs = [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV (([(Ident, IVal)]
vs,Patt
pPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps,Term
t)([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
:[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs
whilePV (([(Ident, IVal)]
vs, PT Term
_ Patt
p : [Patt]
ps, Term
t):[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs = [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)] -> ([[Instr]], [Instr])
whilePV (([(Ident, IVal)]
vs,Patt
pPatt -> [Patt] -> [Patt]
forall a. a -> [a] -> [a]
:[Patt]
ps,Term
t)([(Ident, IVal)], [Patt], Term)
-> [([(Ident, IVal)], [Patt], Term)]
-> [([(Ident, IVal)], [Patt], Term)]
forall a. a -> [a] -> [a]
:[([(Ident, IVal)], [Patt], Term)]
eqs) [([(Ident, IVal)], [Patt], Term)]
vrs
whilePV [([(Ident, IVal)], [Patt], Term)]
eqs [([(Ident, IVal)], [Patt], Term)]
vrs = let fl1 :: Maybe (Int, Int)
fl1 = (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
Just (Int
st,[[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs1)
([[Instr]]
bs1,[Instr]
instrs1) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity Int
st [IVal]
is [([(Ident, IVal)], [Patt], Term)]
vrs Maybe (Int, Int)
fl1 [[Instr]]
bs
([[Instr]]
bs2,[Instr]
instrs2) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity Int
st (IVal
iIVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
:[IVal]
is) [([(Ident, IVal)], [Patt], Term)]
eqs Maybe (Int, Int)
fl ([Instr]
instrs2[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs1)
in ([[Instr]]
bs2,[Instr]
instrs1)
case_instr :: Term -> Int -> Instr
case_instr Term
t =
case Term
t of
(Q (ModuleName
_,Ident
id)) -> CId -> Int -> Instr
CASE (Ident -> CId
i2i Ident
id)
(EInt Int
n) -> Literal -> Int -> Instr
CASE_LIT (Int -> Literal
LInt Int
n)
(K String
s) -> Literal -> Int -> Instr
CASE_LIT (String -> Literal
LStr String
s)
(EFloat Double
d) -> Literal -> Int -> Instr
CASE_LIT (Double -> Literal
LFlt Double
d)
saves :: Int -> [Instr]
saves Int
n = [Instr] -> [Instr]
forall a. [a] -> [a]
reverse [Int -> Instr
SAVE Int
i | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
compileBranch0 :: Maybe (Int, Int)
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> ([[Instr]], [Instr])
compileBranch0 Maybe (Int, Int)
fl [[Instr]]
bs ((Term
t,Int
n),[([(Ident, IVal)], [Patt], Term)]
eqs) =
let ([[Instr]]
bs1,[Instr]
instrs) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) (Int -> Int -> [IVal] -> [IVal]
push_is (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
n [IVal]
is) [([(Ident, IVal)], [Patt], Term)]
eqs Maybe (Int, Int)
fl [[Instr]]
bs
in ([[Instr]]
bs1, Term -> Int -> Instr
case_instr Term
t ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs1) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> [Instr]
saves Int
n [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Instr]
instrs)
compileBranch :: p
-> [[Instr]]
-> ((Term, Int), [([(Ident, IVal)], [Patt], Term)])
-> [[Instr]]
compileBranch p
l [[Instr]]
bs ((Term
t,Int
n),[([(Ident, IVal)], [Patt], Term)]
eqs) =
let ([[Instr]]
bs1,[Instr]
instrs) = SourceGrammar
-> Int
-> Int
-> [IVal]
-> [([(Ident, IVal)], [Patt], Term)]
-> Maybe (Int, Int)
-> [[Instr]]
-> ([[Instr]], [Instr])
compileEquations SourceGrammar
gr Int
arity (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) (Int -> Int -> [IVal] -> [IVal]
push_is (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
n [IVal]
is) [([(Ident, IVal)], [Patt], Term)]
eqs Maybe (Int, Int)
fl ((Term -> Int -> Instr
case_instr Term
t ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs1) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> [Instr]
saves Int
n [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Instr]
instrs) [Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
: [[Instr]]
bs)
in [[Instr]]
bs1
mkFail :: Int -> Int -> Maybe (Int, Int) -> [Instr]
mkFail Int
arity Int
st1 Maybe (Int, Int)
Nothing
| Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
st1 = [Int -> Instr
DROP (Int
st1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
arity), Instr
FAIL]
| Bool
otherwise = [Instr
FAIL]
mkFail Int
arity Int
st1 (Just (Int
st0,Int
l))
| Int
st1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
st0 = [Int -> Instr
DROP (Int
st1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
st0), Int -> Instr
JUMP Int
l]
| Bool
otherwise = [Int -> Instr
JUMP Int
l]
compileBody :: SourceGrammar
-> Int
-> Int
-> [(Ident, IVal)]
-> Term
-> [[Instr]]
-> ([[Instr]], [Instr])
compileBody SourceGrammar
gr Int
arity Int
st [(Ident, IVal)]
vs Term
e [[Instr]]
bs =
let eval :: Int -> IVal -> [IVal] -> [Instr]
eval Int
st IVal
fun [IVal]
args
| Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = let (Int
st1,[Instr]
is) = Int -> [IVal] -> (Int, [Instr])
pushArgs (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) ([IVal] -> [IVal]
forall a. [a] -> [a]
reverse [IVal]
args)
fun' :: IVal
fun' = Int -> IVal -> IVal
shiftIVal Int
st1 IVal
fun
in [Instr
PUSH_FRAME][Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[IVal -> TailInfo -> Instr
EVAL IVal
fun' TailInfo
UpdateCall]
| Bool
otherwise = let (Int
st1,IVal
fun',[Instr]
is) = Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tuckArgs Int
arity Int
st IVal
fun [IVal]
args
in [Instr]
is[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[IVal -> TailInfo -> Instr
EVAL IVal
fun' (Int -> TailInfo
TailCall (Int
st1Int -> Int -> Int
forall a. Num a => a -> a -> a
-[IVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IVal]
argsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))]
(Int
heap,[[Instr]]
bs1,[Instr]
is) = SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs Term
e Int
0 [[Instr]]
bs []
in ([[Instr]]
bs1,if Int
heap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then (Int -> Instr
ALLOC Int
heap Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is) else [Instr]
is)
compileFun :: SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (Abs BindType
_ Ident
x Term
e) Int
h0 [[Instr]]
bs [IVal]
args =
let (Int
h1,[[Instr]]
bs1,IVal
arg,[Instr]
is1) = SourceGrammar
-> Int
-> [(Ident, IVal)]
-> [Ident]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs [Ident
x] Term
e Int
h0 [[Instr]]
bs
in (Int
h1,[[Instr]]
bs1,[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++Int -> IVal -> [IVal] -> [Instr]
eval Int
st IVal
arg [IVal]
args)
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (App Term
e1 Term
e2) Int
h0 [[Instr]]
bs [IVal]
args =
let (Int
h1,[[Instr]]
bs1,IVal
arg,[Instr]
is1) = SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs Term
e2 Int
h0 [[Instr]]
bs
(Int
h2,[[Instr]]
bs2,[Instr]
is2) = SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs Term
e1 Int
h1 [[Instr]]
bs1 (IVal
argIVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
:[IVal]
args)
in (Int
h2,[[Instr]]
bs2,[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is2)
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (Q (ModuleName
m,Ident
id)) Int
h0 [[Instr]]
bs [IVal]
args =
case SourceGrammar
-> ModuleName -> Ident -> Err (Maybe Int, Maybe [Equation])
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar
-> ModuleName -> Ident -> m (Maybe Int, Maybe [Equation])
lookupAbsDef SourceGrammar
gr ModuleName
m Ident
id of
Ok (Maybe Int
_,Just [Equation]
_)
-> (Int
h0,[[Instr]]
bs,Int -> IVal -> [IVal] -> [Instr]
eval Int
st (CId -> IVal
GLOBAL (Ident -> CId
i2i Ident
id)) [IVal]
args)
Err (Maybe Int, Maybe [Equation])
_ -> let Ok Term
ty = SourceGrammar -> ModuleName -> Ident -> Err Term
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> Ident -> m Term
lookupFunType SourceGrammar
gr ModuleName
m Ident
id
(Context
ctxt,QIdent
_,[Term]
_) = Term -> (Context, QIdent, [Term])
typeForm Term
ty
c_arity :: Int
c_arity = Context -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
ctxt
n_args :: Int
n_args = [IVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IVal]
args
is1 :: [Instr]
is1 = Int -> [IVal] -> [Instr]
setArgs Int
st [IVal]
args
diff :: Int
diff = Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n_args
in if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then if Int
n_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then (Int
h0,[[Instr]]
bs,Int -> IVal -> [IVal] -> [Instr]
eval Int
st (CId -> IVal
GLOBAL (Ident -> CId
i2i Ident
id)) [])
else let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_args
in (Int
h1,[[Instr]]
bs,CId -> Instr
PUT_CONSTR (Ident -> CId
i2i Ident
id)Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++Int -> IVal -> [IVal] -> [Instr]
eval Int
st (Int -> IVal
HEAP Int
h0) [])
else let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_args
is2 :: [Instr]
is2 = [IVal -> Instr
SET (Int -> IVal
FREE_VAR Int
i) | Int
i <- [Int
0..Int
n_argsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [IVal -> Instr
SET (Int -> IVal
ARG_VAR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) | Int
i <- [Int
0..Int
diffInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
b :: [Instr]
b = Int -> Instr
CHECK_ARGS Int
diff Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
Int -> Instr
ALLOC (Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
CId -> Instr
PUT_CONSTR (Ident -> CId
i2i Ident
id) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[Instr]
is2 [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
IVal -> Int -> Instr
TUCK (Int -> IVal
ARG_VAR Int
0) Int
diff Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
IVal -> TailInfo -> Instr
EVAL (Int -> IVal
HEAP Int
h0) (Int -> TailInfo
TailCall Int
diff) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[]
in (Int
h1,[Instr]
b[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs,Int -> Instr
PUT_CLOSURE ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs)Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++Int -> IVal -> [IVal] -> [Instr]
eval Int
st (Int -> IVal
HEAP Int
h0) [])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (QC QIdent
qid) Int
h0 [[Instr]]
bs [IVal]
args =
SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (QIdent -> Term
Q QIdent
qid) Int
h0 [[Instr]]
bs [IVal]
args
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (Vr Ident
x) Int
h0 [[Instr]]
bs [IVal]
args =
(Int
h0,[[Instr]]
bs,Int -> IVal -> [IVal] -> [Instr]
eval Int
st ([(Ident, IVal)] -> Ident -> IVal
forall a p. Eq a => [(a, p)] -> a -> p
getVar [(Ident, IVal)]
vs Ident
x) [IVal]
args)
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (EInt Int
n) Int
h0 [[Instr]]
bs [IVal]
_ =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Literal -> Instr
PUT_LIT (Int -> Literal
LInt Int
n) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> IVal -> [IVal] -> [Instr]
eval Int
st (Int -> IVal
HEAP Int
h0) [])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (K String
s) Int
h0 [[Instr]]
bs [IVal]
_ =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Literal -> Instr
PUT_LIT (String -> Literal
LStr String
s) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> IVal -> [IVal] -> [Instr]
eval Int
st (Int -> IVal
HEAP Int
h0) [])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (EFloat Double
d) Int
h0 [[Instr]]
bs [IVal]
_ =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Literal -> Instr
PUT_LIT (Double -> Literal
LFlt Double
d) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> IVal -> [IVal] -> [Instr]
eval Int
st (Int -> IVal
HEAP Int
h0) [])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (Typed Term
e Term
_) Int
h0 [[Instr]]
bs [IVal]
args =
SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs Term
e Int
h0 [[Instr]]
bs [IVal]
args
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs (Let (Ident
x, (Maybe Term
_, Term
e1)) Term
e2) Int
h0 [[Instr]]
bs [IVal]
args =
let (Int
h1,[[Instr]]
bs1,IVal
arg,[Instr]
is1) = SourceGrammar
-> Int
-> [(Ident, IVal)]
-> [Ident]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs [] Term
e1 Int
h0 [[Instr]]
bs
(Int
h2,[[Instr]]
bs2,[Instr]
is2) = SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st ((Ident
x,IVal
arg)(Ident, IVal) -> [(Ident, IVal)] -> [(Ident, IVal)]
forall a. a -> [a] -> [a]
:[(Ident, IVal)]
vs) Term
e2 Int
h1 [[Instr]]
bs1 [IVal]
args
in (Int
h2,[[Instr]]
bs2,[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is2)
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs e :: Term
e@(Glue Term
e1 Term
e2) Int
h0 [[Instr]]
bs [IVal]
args =
let eval' :: Int -> IVal -> [IVal] -> [Instr]
eval' Int
st IVal
fun [IVal]
args = [Instr
PUSH_FRAME][Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[IVal -> TailInfo -> Instr
EVAL IVal
fun' TailInfo
RecCall]
where
(Int
_st1,[Instr]
is) = Int -> [IVal] -> (Int, [Instr])
pushArgs (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) ([IVal] -> [IVal]
forall a. [a] -> [a]
reverse [IVal]
args)
fun' :: IVal
fun' = Int -> IVal -> IVal
shiftIVal Int
st IVal
fun
flatten :: Term -> Int -> [[Instr]] -> (Int, [[Instr]], [Instr])
flatten (Glue Term
e1 Term
e2) Int
h0 [[Instr]]
bs =
let (Int
h1,[[Instr]]
bs1,[Instr]
is1) = Term -> Int -> [[Instr]] -> (Int, [[Instr]], [Instr])
flatten Term
e1 Int
h0 [[Instr]]
bs
(Int
h2,[[Instr]]
bs2,[Instr]
is2) = Term -> Int -> [[Instr]] -> (Int, [[Instr]], [Instr])
flatten Term
e2 Int
h1 [[Instr]]
bs1
in (Int
h2,[[Instr]]
bs2,[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is2)
flatten Term
e Int
h0 [[Instr]]
bs =
let (Int
h1,[[Instr]]
bs1,[Instr]
is1) = SourceGrammar
-> (Int -> IVal -> [IVal] -> [Instr])
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> [IVal]
-> (Int, [[Instr]], [Instr])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval' (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) [(Ident, IVal)]
vs Term
e Int
h0 [[Instr]]
bs [IVal]
args
in (Int
h1,[[Instr]]
bs1,[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr
ADD])
(Int
h1,[[Instr]]
bs1,[Instr]
is) = Term -> Int -> [[Instr]] -> (Int, [[Instr]], [Instr])
flatten Term
e Int
h0 [[Instr]]
bs
in (Int
h1,[[Instr]]
bs1,[Literal -> Instr
PUSH_ACCUM (Double -> Literal
LFlt Double
0)][Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr
POP_ACCUM][Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++Int -> IVal -> [IVal] -> [Instr]
eval (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> IVal
ARG_VAR Int
st) [])
compileFun SourceGrammar
gr Int -> IVal -> [IVal] -> [Instr]
eval Int
st [(Ident, IVal)]
vs Term
e Int
_ [[Instr]]
_ [IVal]
_ = String -> (Int, [[Instr]], [Instr])
forall a. HasCallStack => String -> a
error (Term -> String
forall a. Show a => a -> String
show Term
e)
compileArg :: SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (Q(ModuleName
m,Ident
id)) Int
h0 [[Instr]]
bs =
case SourceGrammar
-> ModuleName -> Ident -> Err (Maybe Int, Maybe [Equation])
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar
-> ModuleName -> Ident -> m (Maybe Int, Maybe [Equation])
lookupAbsDef SourceGrammar
gr ModuleName
m Ident
id of
Ok (Maybe Int
_,Just [Equation]
_) -> (Int
h0,[[Instr]]
bs,CId -> IVal
GLOBAL (Ident -> CId
i2i Ident
id),[])
Err (Maybe Int, Maybe [Equation])
_ -> let Ok Term
ty = SourceGrammar -> ModuleName -> Ident -> Err Term
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> Ident -> m Term
lookupFunType SourceGrammar
gr ModuleName
m Ident
id
(Context
ctxt,QIdent
_,[Term]
_) = Term -> (Context, QIdent, [Term])
typeForm Term
ty
c_arity :: Int
c_arity = Context -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
ctxt
in if Int
c_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then (Int
h0,[[Instr]]
bs,CId -> IVal
GLOBAL (Ident -> CId
i2i Ident
id),[])
else let is2 :: [Instr]
is2 = [IVal -> Instr
SET (Int -> IVal
ARG_VAR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) | Int
i <- [Int
0..Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
b :: [Instr]
b = Int -> Instr
CHECK_ARGS Int
c_arity Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
Int -> Instr
ALLOC (Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
CId -> Instr
PUT_CONSTR (Ident -> CId
i2i Ident
id) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[Instr]
is2 [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
IVal -> Int -> Instr
TUCK (Int -> IVal
ARG_VAR Int
0) Int
c_arity Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
IVal -> TailInfo -> Instr
EVAL (Int -> IVal
HEAP Int
h0) (Int -> TailInfo
TailCall Int
c_arity) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[]
h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[Instr]
b[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs,Int -> IVal
HEAP Int
h0,[Int -> Instr
PUT_CLOSURE ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs),Instr
SET_PAD])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (QC QIdent
qid) Int
h0 [[Instr]]
bs =
SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (QIdent -> Term
Q QIdent
qid) Int
h0 [[Instr]]
bs
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (Vr Ident
x) Int
h0 [[Instr]]
bs =
(Int
h0,[[Instr]]
bs,[(Ident, IVal)] -> Ident -> IVal
forall a p. Eq a => [(a, p)] -> a -> p
getVar [(Ident, IVal)]
vs Ident
x,[])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (EInt Int
n) Int
h0 [[Instr]]
bs =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Int -> IVal
HEAP Int
h0,[Literal -> Instr
PUT_LIT (Int -> Literal
LInt Int
n)])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (K String
s) Int
h0 [[Instr]]
bs =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Int -> IVal
HEAP Int
h0,[Literal -> Instr
PUT_LIT (String -> Literal
LStr String
s)])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (EFloat Double
d) Int
h0 [[Instr]]
bs =
let h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
in (Int
h1,[[Instr]]
bs,Int -> IVal
HEAP Int
h0,[Literal -> Instr
PUT_LIT (Double -> Literal
LFlt Double
d)])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (Typed Term
e Term
_) Int
h0 [[Instr]]
bs =
SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs Term
e Int
h0 [[Instr]]
bs
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs (ImplArg Term
e) Int
h0 [[Instr]]
bs =
SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs Term
e Int
h0 [[Instr]]
bs
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs Term
e Int
h0 [[Instr]]
bs =
let (Term
f,[Term]
es) = Term -> (Term, [Term])
appForm Term
e
isConstr :: Maybe QIdent
isConstr = case Term
f of
Q c :: QIdent
c@(ModuleName
m,Ident
id) -> case SourceGrammar
-> ModuleName -> Ident -> Err (Maybe Int, Maybe [Equation])
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar
-> ModuleName -> Ident -> m (Maybe Int, Maybe [Equation])
lookupAbsDef SourceGrammar
gr ModuleName
m Ident
id of
Ok (Maybe Int
_,Just [Equation]
_) -> Maybe QIdent
forall a. Maybe a
Nothing
Err (Maybe Int, Maybe [Equation])
_ -> QIdent -> Maybe QIdent
forall a. a -> Maybe a
Just QIdent
c
QC c :: QIdent
c@(ModuleName
m,Ident
id) -> case SourceGrammar
-> ModuleName -> Ident -> Err (Maybe Int, Maybe [Equation])
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar
-> ModuleName -> Ident -> m (Maybe Int, Maybe [Equation])
lookupAbsDef SourceGrammar
gr ModuleName
m Ident
id of
Ok (Maybe Int
_,Just [Equation]
_) -> Maybe QIdent
forall a. Maybe a
Nothing
Err (Maybe Int, Maybe [Equation])
_ -> QIdent -> Maybe QIdent
forall a. a -> Maybe a
Just QIdent
c
Term
_ -> Maybe QIdent
forall a. Maybe a
Nothing
in case Maybe QIdent
isConstr of
Just (ModuleName
m,Ident
id) ->
let Ok Term
ty = SourceGrammar -> ModuleName -> Ident -> Err Term
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> Ident -> m Term
lookupFunType SourceGrammar
gr ModuleName
m Ident
id
(Context
ctxt,QIdent
_,[Term]
_) = Term -> (Context, QIdent, [Term])
typeForm Term
ty
c_arity :: Int
c_arity = Context -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
ctxt
((Int
h1,[[Instr]]
bs1,[Instr]
is1),[IVal]
args) = ((Int, [[Instr]], [Instr])
-> Term -> ((Int, [[Instr]], [Instr]), IVal))
-> (Int, [[Instr]], [Instr])
-> [Term]
-> ((Int, [[Instr]], [Instr]), [IVal])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\(Int
h,[[Instr]]
bs,[Instr]
is) Term
e -> let (Int
h1,[[Instr]]
bs1,IVal
arg,[Instr]
is1) = SourceGrammar
-> Int
-> [(Ident, IVal)]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileArg SourceGrammar
gr Int
st [(Ident, IVal)]
vs Term
e Int
h [[Instr]]
bs
in ((Int
h1,[[Instr]]
bs1,[Instr]
is[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is1),IVal
arg))
(Int
h0,[[Instr]]
bs,[])
[Term]
es
n_args :: Int
n_args = [IVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [IVal]
args
is2 :: [Instr]
is2 = Int -> [IVal] -> [Instr]
setArgs Int
st [IVal]
args
diff :: Int
diff = Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n_args
in if Int
diff Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
then let h2 :: Int
h2 = Int
h1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_args
in (Int
h2,[[Instr]]
bs1,Int -> IVal
HEAP Int
h1,[Instr]
is1 [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ (CId -> Instr
PUT_CONSTR (Ident -> CId
i2i Ident
id) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is2))
else let h2 :: Int
h2 = Int
h1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_args
is2 :: [Instr]
is2 = [IVal -> Instr
SET (Int -> IVal
FREE_VAR Int
i) | Int
i <- [Int
0..Int
n_argsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [IVal -> Instr
SET (Int -> IVal
ARG_VAR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) | Int
i <- [Int
0..Int
diffInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
b :: [Instr]
b = Int -> Instr
CHECK_ARGS Int
diff Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
Int -> Instr
ALLOC (Int
c_arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
CId -> Instr
PUT_CONSTR (Ident -> CId
i2i Ident
id) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[Instr]
is2 [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
IVal -> Int -> Instr
TUCK (Int -> IVal
ARG_VAR Int
0) Int
diff Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
IVal -> TailInfo -> Instr
EVAL (Int -> IVal
HEAP Int
h0) (Int -> TailInfo
TailCall Int
diff) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
[]
in (Int
h2,[Instr]
b[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs1,Int -> IVal
HEAP Int
h1,[Instr]
is1 [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ (Int -> Instr
PUT_CLOSURE ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs)Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
is2))
Maybe QIdent
Nothing -> SourceGrammar
-> Int
-> [(Ident, IVal)]
-> [Ident]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs [] Term
e Int
h0 [[Instr]]
bs
compileLambda :: SourceGrammar
-> Int
-> [(Ident, IVal)]
-> [Ident]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs [Ident]
xs (Abs BindType
_ Ident
x Term
e) Int
h0 [[Instr]]
bs =
SourceGrammar
-> Int
-> [(Ident, IVal)]
-> [Ident]
-> Term
-> Int
-> [[Instr]]
-> (Int, [[Instr]], IVal, [Instr])
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
xs) Term
e Int
h0 [[Instr]]
bs
compileLambda SourceGrammar
gr Int
st [(Ident, IVal)]
vs [Ident]
xs Term
e Int
h0 [[Instr]]
bs =
let ys :: [Ident]
ys = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> Term -> [Ident]
freeVars [Ident]
xs Term
e)
arity :: Int
arity = [Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
xs
([[Instr]]
bs1,[Instr]
b) = SourceGrammar
-> Int
-> Int
-> [(Ident, IVal)]
-> Term
-> [[Instr]]
-> ([[Instr]], [Instr])
compileBody SourceGrammar
gr Int
arity
(Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
([Ident] -> [IVal] -> [(Ident, IVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ident]
xs ((Int -> IVal) -> [Int] -> [IVal]
forall a b. (a -> b) -> [a] -> [b]
map Int -> IVal
ARG_VAR [Int
0..]) [(Ident, IVal)] -> [(Ident, IVal)] -> [(Ident, IVal)]
forall a. [a] -> [a] -> [a]
++
[Ident] -> [IVal] -> [(Ident, IVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ident]
ys ((Int -> IVal) -> [Int] -> [IVal]
forall a b. (a -> b) -> [a] -> [b]
map Int -> IVal
FREE_VAR [Int
0..]))
Term
e ([Instr]
b1[Instr] -> [[Instr]] -> [[Instr]]
forall a. a -> [a] -> [a]
:[[Instr]]
bs)
b1 :: [Instr]
b1 = if Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then [Instr]
b
else Int -> Instr
CHECK_ARGS Int
arityInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
b
is :: [Instr]
is = if [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
ys
then [Instr
SET_PAD]
else (Ident -> Instr) -> [Ident] -> [Instr]
forall a b. (a -> b) -> [a] -> [b]
map (IVal -> Instr
SET (IVal -> Instr) -> (Ident -> IVal) -> Ident -> Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IVal -> IVal
shiftIVal Int
st (IVal -> IVal) -> (Ident -> IVal) -> Ident -> IVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Ident, IVal)] -> Ident -> IVal
forall a p. Eq a => [(a, p)] -> a -> p
getVar [(Ident, IVal)]
vs) [Ident]
ys
h1 :: Int
h1 = Int
h0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Instr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Instr]
is
in (Int
h1,[[Instr]]
bs1,Int -> IVal
HEAP Int
h0,Int -> Instr
PUT_CLOSURE ([[Instr]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Instr]]
bs) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is)
getVar :: [(a, p)] -> a -> p
getVar [(a, p)]
vs a
x =
case a -> [(a, p)] -> Maybe p
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x [(a, p)]
vs of
Just p
arg -> p
arg
Maybe p
Nothing -> String -> p
forall a. HasCallStack => String -> a
error String
"compileVar: unknown variable"
shiftIVal :: Int -> IVal -> IVal
shiftIVal Int
st (ARG_VAR Int
i) = Int -> IVal
ARG_VAR (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
shiftIVal Int
st IVal
arg = IVal
arg
pushArgs :: Int -> [IVal] -> (Int, [Instr])
pushArgs Int
st [] = (Int
st,[])
pushArgs Int
st (IVal
arg:[IVal]
args) = let (Int
st1,[Instr]
is) = Int -> [IVal] -> (Int, [Instr])
pushArgs (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [IVal]
args
in (Int
st1, IVal -> Instr
PUSH (Int -> IVal -> IVal
shiftIVal Int
st IVal
arg) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is)
tuckArgs :: Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tuckArgs Int
arity Int
st IVal
fun [IVal]
args = (Int
st2,Int -> IVal -> IVal
shiftIVal Int
st2 IVal
fun',[Instr]
is1[Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++[Instr]
is2)
where
(Int
st2,IVal
fun',[Instr]
is2) = Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tucks Int
st1 Int
0 IVal
fun [IVal]
tas
(Int
st1,[Instr]
is1) = Int -> [IVal] -> (Int, [Instr])
pushArgs Int
st [IVal]
pas
([IVal]
tas,[IVal]
pas) = Int -> [IVal] -> ([IVal], [IVal])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
st [IVal]
args'
args' :: [IVal]
args' = [IVal] -> [IVal]
forall a. [a] -> [a]
reverse (Int -> IVal
ARG_VAR Int
arity IVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
: [IVal]
args)
tucks :: Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tucks Int
st Int
i IVal
fun [] = (Int
st,IVal
fun,[])
tucks Int
st Int
i IVal
fun (IVal
arg:[IVal]
args)
| IVal
arg IVal -> IVal -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> IVal
ARG_VAR Int
i = Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tucks Int
st (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) IVal
fun [IVal]
args
| Bool
otherwise = case Int -> IVal -> [IVal] -> Maybe [IVal]
forall t. t -> IVal -> [IVal] -> Maybe [IVal]
save Int
st (Int -> IVal
ARG_VAR Int
i) (IVal
funIVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
:[IVal]
args) of
Just (IVal
fun:[IVal]
args) -> let (Int
st1,IVal
fun',[Instr]
is) = Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tucks (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) IVal
fun [IVal]
args
in (Int
st1, IVal
fun', IVal -> Instr
PUSH (Int -> IVal
ARG_VAR (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:
IVal -> Int -> Instr
TUCK (Int -> IVal -> IVal
shiftIVal (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) IVal
arg) (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is)
Maybe [IVal]
Nothing -> let (Int
st1,IVal
fun',[Instr]
is) = Int -> Int -> IVal -> [IVal] -> (Int, IVal, [Instr])
tucks Int
st (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) IVal
fun [IVal]
args
in (Int
st1, IVal
fun', IVal -> Int -> Instr
TUCK (Int -> IVal -> IVal
shiftIVal Int
st IVal
arg) (Int
stInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
is)
save :: t -> IVal -> [IVal] -> Maybe [IVal]
save t
st IVal
arg0 [] = Maybe [IVal]
forall a. Maybe a
Nothing
save t
st IVal
arg0 (IVal
arg:[IVal]
args)
| IVal
arg0 IVal -> IVal -> Bool
forall a. Eq a => a -> a -> Bool
== IVal
arg = [IVal] -> Maybe [IVal]
forall a. a -> Maybe a
Just (Int -> IVal
ARG_VAR Int
st1 IVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
: [IVal] -> Maybe [IVal] -> [IVal]
forall a. a -> Maybe a -> a
fromMaybe [IVal]
args (t -> IVal -> [IVal] -> Maybe [IVal]
save t
st IVal
arg0 [IVal]
args))
| Bool
otherwise = ([IVal] -> [IVal]) -> Maybe [IVal] -> Maybe [IVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IVal
arg IVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
:) (t -> IVal -> [IVal] -> Maybe [IVal]
save t
st IVal
arg0 [IVal]
args)
setArgs :: Int -> [IVal] -> [Instr]
setArgs Int
st [] = []
setArgs Int
st (IVal
arg:[IVal]
args) = IVal -> Instr
SET (Int -> IVal -> IVal
shiftIVal Int
st IVal
arg) Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Int -> [IVal] -> [Instr]
setArgs Int
st [IVal]
args
freeVars :: [Ident] -> Term -> [Ident]
freeVars [Ident]
xs (Abs BindType
_ Ident
x Term
e) = [Ident] -> Term -> [Ident]
freeVars (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
xs) Term
e
freeVars [Ident]
xs (Vr Ident
x)
| Bool -> Bool
not (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Ident
x [Ident]
xs) = [Ident
x]
freeVars [Ident]
xs Term
e = (Term -> [Ident]) -> Term -> [Ident]
forall m. Monoid m => (Term -> m) -> Term -> m
collectOp ([Ident] -> Term -> [Ident]
freeVars [Ident]
xs) Term
e
i2i :: Ident -> CId
i2i :: Ident -> CId
i2i = ByteString -> CId
utf8CId (ByteString -> CId) -> (Ident -> ByteString) -> Ident -> CId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ByteString
ident2utf8
push_is :: Int -> Int -> [IVal] -> [IVal]
push_is :: Int -> Int -> [IVal] -> [IVal]
push_is Int
i Int
0 [IVal]
is = [IVal]
is
push_is Int
i Int
n [IVal]
is = Int -> IVal
ARG_VAR Int
i IVal -> [IVal] -> [IVal]
forall a. a -> [a] -> [a]
: Int -> Int -> [IVal] -> [IVal]
push_is (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [IVal]
is