Why is this program leaking memory ?

28 May 2003

      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.

[kyagrd@OBIWAN 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.

[kyagrd@OBIWAN 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.

[kyagrd@OBIWAN 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