I'm playing with the lazy abstract machine of 1997 Sestoft's paper.
I implemented this with haskell using ghc 5.04.3.
I lambda lifted the original input expression to prevent
memory leak of "Lazy Abstarc Machine", and it works fine.
I tested with the leaky program example of the Sestoft 97 paper.
[EMAIL PROTECTED] transform]$ cat test.txt
let ff = \n.let i=\x.x in ff i
in ff ff
I printed the 4 tuples (Heap, Exp, Env, Stack) each step.
It goes on and on like this.
[EMAIL PROTECTED] transform]$ ./main.exe < test.txt
let "ff"=\"n".let "i"=\"x"."x" in "ff" "i" in "ff" "ff"
let 1=\2.let 3=\4.4 in 1 3 in 1 1
let -1=\2.-1 -3 -3=\4.4 in -1 -1
let -1=\2.-1 -3 -3=\4.4 in -1 -1
let 0=\0.1 2 0=\0.0 in 0 0
([],let 0=\0.1 2 0=\0.0 in 0 0,[],[])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],0 0,[2,1],[])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],0,[2,1],[2])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],\0.1 2,[2,1],[2])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1 2,[2,2,1],[])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1,[2,2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],\0.1 2,[2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1 2,[1,2,1],[])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1,[1,2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],\0.1 2,[2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1 2,[1,2,1],[])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1,[1,2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],\0.1 2,[2,1],[1])
([(2,(\0.1 2,[2,1])),(1,(\0.0,[2,1]))],1 2,[1,2,1],[])
...
But Strangely the Haskell heap memory leaks if I omit printing
every step but only print the result.
[EMAIL PROTECTED] transform]$ ./main.exe < test.txt
let "ff"=\"n".let "i"=\"x"."x" in "ff" "i" in "ff" "ff"
let 1=\2.let 3=\4.4 in 1 3 in 1 1
let -1=\2.-1 -3 -3=\4.4 in -1 -1
let -1=\2.-1 -3 -3=\4.4 in -1 -1
let 0=\0.1 2 0=\0.0 in 0 0
c:\MyDoc\iFolder\kyagrd\LAZY\transform\main.exe: fatal error:
RTS exhausted max heap size (268435456 bytes)
I attach my source code except for the parser and lexer stuff.
I switched between two main' and main fucntion.
Why, in the Main module, "printNreduce" do not leak but
while "printeval" leaks ? Can't understand this behavior.
module Main where
import Syntax
import Parser
import Lazyeval
import MonadST
printeval q = if q'==q then print q' else printeval q'
where q' = reduce q
printNreduce q = if q'==q then print q' else (print q >> printNreduce q')
where q' = reduce q
-- print every step does not leak
main = do
s <- getContents
let e = parser s
e' <- printNpreprocess e
printNreduce ([],e',[],[])
-- print only result leak !!
main' = do
s <- getContents
let e = parser s
e' <- printNpreprocess e
printeval ([],e',[],[])
printNpreprocess e =
print e >> print e1 >> print e2 >> print e3 >> print e' >> return e'
where
((ns,[]),e1) = evalST ([1..],[]) (uniqueify e)
e2 = lambdalift negate e1
(ns3,e3) = evalST ns (normalize e2)
e' = bruijnize e3
{-
Syntax.hs
preprocessing of lazy language for evaluation
Ahn Ki-yung
-}
module Syntax where
import MonadST
import List
data Lambda id
= Var id
| App (Lambda id) (Lambda id)
| Lam id (Lambda id)
| Let [(id,Lambda id)] (Lambda id)
-- deriving (Eq, Ord)
deriving (Eq, Ord, Read)
instance Show a => Show (Lambda a) where
show (Var s) = show s
show (Lam s e) = '\\':show s ++ '.':show e
show (App e e') =
showParenExpr e ++ ' ' : showParenExpr e'
where
showParenExpr e@(Var s) = show e
showParenExpr e = '(':show e++")"
show (Let h e) = "let"
++ concat [' ':show s++'=':show e|(s,e)<-h]
++ " in " ++ show e
instance Functor Lambda where
fmap f (Var x) = Var (f x)
fmap f (App e e') = App (fmap f e) (fmap f e')
fmap f (Lam x e) = Lam (f x) (fmap f e)
fmap f (Let ds e) = Let [(f x,fmap f e)|(x,e)<-ds] (fmap f e)
transform (getId,putId,popId) = trans
where
newId x = putId x >> getId x
trans (Var x) = do { x'<-getId x; return (Var x') }
trans (App e e1) = do { e'<-trans e; e1'<-trans e1; return (App e' e1') }
trans (Lam x e) =
do { x'<-newId x; e'<-trans e; popId x; return (Lam x' e') }
trans (Let ds e) = do
let (xs,es) = unzip ds
xs'<-mapM newId xs
es'<-mapM trans es
let ds' = zip xs' es'
e'<-trans e
mapM popId xs
return (Let ds' e')
uniqueify :: (Eq a, Eq b) => Lambda a -> StateTrans ([b],[(a,b)]) (Lambda b)
uniqueify = transform (getId,putId,popId) where
getId x = do
(_,l) <- readST
let Just (_,n) = find ((x==).fst) l
return n
putId x = do
(n:ns,l) <- readST
writeST (ns,(x,n):l)
popId x = do
(ns,l) <- readST
writeST (ns,deleteBy (\p-> \q->fst p==fst q) (x,head ns) l)
normalize :: Lambda a -> StateTrans [a] (Lambda a)
normalize = normExpr where
newvar = do
(x:xs) <- readST
writeST xs
return x
normExpr (Var x) = return (Var x)
normExpr (Lam x e) = do
e' <- normExpr e
return (Lam x e')
normExpr (App e (Var x)) = do
e' <- normExpr e
return (App e' (Var x))
normExpr (App e1 e2) = do
x <- newvar
e1' <- normExpr e1
e2' <- normExpr e2
return (Let [(x,e2')] (App e1' (Var x)))
normExpr (Let ds e) = do
let (vs,es) = unzip ds
es' <- mapM normExpr es
let ds' = zip vs es'
e' <- normExpr e
return (Let ds' e')
(f,g)@@(x,y) = (f x, g y)
-- assumes uniquified normalized e
lambdalift topv e = Let ds (subsfree [] topv d' e')
where
d' = delcombs [] d
ds = [ (topv x, foldr Lam (subsfree fv topv d' e) fv) | (x,fv,e)<-d' ]
(d,fv,e') = llift e
delcombs combs d =
if combs/=combs'
then delcombs combs' [(x,fv\\combs',e) | (x,fv,e)<-d]
else d
where combs' = [x | (x,[],_)<-d]
-- assumes uniquified and no lets -- done llift
subsfree bv topv d e = subs e
where
var' = Var . topv
subs (Var x) = case find (\(y,_,_)->x==y && not (elem x bv)) d of
Just (_,fv,_) -> foldl App (var' x) (map var' fv)
_ -> Var x
subs (App e e') = App (subs e) (subs e')
subs (Lam x e) = Lam x (subs e)
-- assumes uniquified
llift (Var x) = ([], [x], Var x)
llift (App e e') = (d1++d2, union fv1 fv2, App e1 e2)
where
(d1,fv1,e1) = llift e
(d2,fv2,e2) = llift e'
llift (Lam x e) = (d, fv\\[x], Lam x e') where (d, fv, e') = llift e
llift (Let ds e) = (dd++d', fv, e')
where
(d, fv, e') = llift e
xds = map ((id,llift)@@) ds
dd = [ (x, fv\\[x], e) | (x,(d,fv,e))<-xds ]
d' = foldr (++) d [d | (_,(d,_,_))<-xds]
bruijnize e = bruijn [] e
elemIndex' x xs = (\(Just i)->i) $ elemIndex x xs
bruijn xs (Var x) = Var (elemIndex' x xs)
bruijn xs (Lam x e) = Lam 0 (bruijn (x:xs) e)
bruijn xs (App e e') = App (bruijn xs e) (bruijn xs e')
bruijn xs (Let ds e) = Let [(0,bruijn xs' e) | e<-es] (bruijn xs' e)
where
(vs,es) = unzip ds
xs' = vs ++ xs
module Lazyeval where
import Syntax
import List
data StackElem = Update Int | Point Int deriving Eq
instance Show StackElem where
show (Update i) = '#':show i
show (Point i) = show i
getHeap p = (\(Just x)->snd x) . find ((p==).fst)
setHeap t@(p,e) =
insertBy (mapF2 fst $ flip compare) t . deleteBy (mapF2 fst (==)) t
where mapF2 g f2 x y = f2 (g x) (g y)
reduce (h,App e (Var i),env,s) = (h,e,env,Point(env!!i):s)
reduce (h,Lam _ e,env,Point p:s) = (h,e,p:env,s)
reduce (h,Var i,env,s) = (h,e',env',s')
where
s' = case e' of Lam _ _ ->s; _->Update p:s
(e',env') = getHeap p h
p = env!!i
reduce (h,Lam x e,env,Update p:s) = (setHeap (p,(Lam x e,env)) h,Lam x e,env,s)
reduce (h,Let ds e,env,s) = (h',e,env',s)
where
es = snd (unzip ds)
h' = newhs ++ h
env' = newps ++ env
newhs = zip newps [(e,env')|e<-es]
newps = take n [m+n,m+n-1..]
m = if null h then 0 else (head . fst . unzip) h
n = length es
reduce q = q
fix f x = if x'==x then x else fix f x' where x' = f x
eval = fix reduce
module MonadST (readST, writeST, applyST, evalST, valueST, stateST, StateTrans) where
data StateTrans s a = ST { st :: s -> (s,a) }
instance Monad (StateTrans a) where
return x = ST (\s -> (s, x))
m >>= f = ST (\s -> let (s',x) = st m s in st (f x) s')
readST = ST (\s -> (s, s))
writeST s' = ST (\s -> (s', ()))
applyST f = ST (\s -> (f s, ()))
evalST s m = st m s
valueST s = snd . evalST s
stateST s = fst . evalST s
