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]] -> []         -- in the runtime this is a more efficient variant of [[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