(* `malloc' but no `free'? We need a garbage collector. We have to add tags back onto our values, so the GC can know whether the thing it sees in the `v' register (and other places) is a number of a pointer. We use `0' for numbers and `1' for functions. *) type xvar = string type xpr = Const of int | Minus of xpr * xpr | Times of xpr * xpr | Lam of xvar * xpr | Var of xvar | App of xpr * xpr | IfZero of xpr * xpr * xpr (* Same encoding as before: and cxpr = CConst of int 1 | CMinus of cxpr * cxpr 2 | CTimes of cxpr * cxpr 3 | CLam of cxpr 4 | CApp of cxpr * cxpr 5 | CIfZero of cxpr * cxpr * cxpr 6 | CVar of int 7 and kont = Done 0 | KSubArg of cxpr * xenv * kont 1 | KMultArg of cxpr * xenv * kont 2 | KSub of xval * kont 3 | KMult of xval * kont 4 | KAppArg of cxpr * xenv * kont 5 | KApp of xval * kont 6 | KIfZero of cxpr * cxpr * xenv * kont 7 *) type cenv = CEmpty | CExtend of xvar * cenv ;; (* The examples are unchanged *) let five = Const(5) let protofac = Lam("f", Lam("n", IfZero(Var("n"), Const(1), Times(Var("n"), App(App(Var("f"), Var("f")), Minus(Var("n"), Const(1))))))) let fac = App(protofac, protofac) let onetwenty = App(fac, five) ;; (* Same registers, but we need to define them earlier. *) let mReg = ref 0 and eReg = ref 0 and kReg = ref 0 and vReg = ref 0 ;; (* Same allocator, except that we tag each value as Unmoved or Moved. The collector uses this tag. *) type moved = Unmoved of int | Moved of int (* We swap memory1 and memory2 after GCing: *) let size = 250 let memory1 = ref (Array.create size (Unmoved 0)) let memory2 = ref (Array.create size (Unmoved 0)) let allocpos = ref 1 let copypos = ref 1 let malloc = function (a, d) -> let p = !allocpos in Array.set (!memory1) p (Unmoved a); Array.set (!memory1) (p+1) (Unmoved d); allocpos := (!allocpos + 2); p let read = fun p -> match (Array.get (!memory1) p) with Unmoved(v) -> v let read2 = fun p -> match (Array.get (!memory2) p) with Unmoved(v) -> v let write2 = fun (p, v) -> Array.set (!memory2) p (Unmoved v) (* The garbage collector knows the shapes of all allocated objects. So it knows the 0 and 1 tags for values, plus all the `cxpr' and `kont' tags. We start from the roots: `mReg' contains a pointer to a `cxpr', `kReg' contains a pointer to a `kont', `vReg' contains a pointer to a value, and `eReg' contains a pointer to a list of values. We implement a two-space. *) let rec gc = fun unit -> copypos := 1; vReg := (gcValue !vReg); mReg := (gcCxpr !mReg); kReg := (gcKont !kReg); eReg := (gcEnv !eReg); let m1 = !memory1 in memory1 := !memory2; memory2 := m1; allocpos := !copypos; and move = fun (p, k) -> if (p == 0) then 0 else match ((Array.get !memory1 p), (Array.get !memory1 (p+1))) with ((Moved n), _) -> n | ((Unmoved n), Unmoved(m)) -> let np = !copypos in Array.set (!memory2) np (Unmoved n); Array.set (!memory2) (np+1) (Unmoved m); Array.set (!memory1) p (Moved np); copypos := (!copypos + 2); k(np); np and moveCons = fun (p, k) -> write2(p, move(read2(p), k)); () and moveGen = fun (p, f) -> write2(p, f(read2(p))); () and gcValue = fun p -> move(p, fun np -> match (read2 np) with 0 -> () | 1 -> moveCons(np+1, fun vp -> moveGen(vp, gcCxpr); moveGen(vp+1, gcEnv))); and gcCxpr = fun p -> move(p, fun np -> match (read2 np) with 1|7 -> () | 2|3|5 -> moveCons(np+1, fun pp -> moveGen(pp, gcCxpr); moveGen(pp+1, gcCxpr)) | 6 -> moveCons(np+1, fun pp -> moveGen(pp, gcCxpr); moveCons(pp+1, fun pp -> moveGen(pp, gcCxpr); moveGen(pp+1, gcCxpr))) | 4 -> moveGen(np+1, gcCxpr)) and gcKont = fun p -> move(p, fun np -> match (read2 np) with 0 -> () | 1|2|5 -> moveCons(np+1, fun pp -> moveGen(pp, gcCxpr); moveCons(pp+1, fun pp -> moveGen(pp, gcEnv); moveGen(pp+1, gcKont))) | 3|4|6 -> moveCons(np+1, fun pp -> moveGen(pp, gcValue); moveGen(pp+1, gcKont)) | 7 -> moveCons(np+1, fun pp -> moveGen(pp, gcCxpr); moveCons(pp+1, fun pp -> moveGen(pp, gcCxpr); moveCons(pp+1, fun pp -> moveGen(pp, gcEnv); moveGen(pp+1, gcKont))))) and gcEnv = fun p -> move(p, fun np -> moveGen(np, gcValue); moveGen(np+1, gcEnv)) ;; (* The compiler is unchanged *) let rec comp = function (Const(v), e) -> malloc(1, v) | (Minus(m1, m2), e) -> malloc(2, malloc(comp(m1, e), comp(m2, e))) | (Times(m1, m2), e) -> malloc(3, malloc(comp(m1, e), comp(m2, e))) | (Lam(var, m), e) -> malloc(4, comp(m, CExtend(var, e))) | (App(m1, m2), e) -> malloc(5, malloc(comp(m1, e), comp(m2, e))) | (IfZero(m1, m2, m3), e) -> malloc(6, malloc(comp(m1, e), malloc(comp(m2, e), comp(m3, e)))) | (Var(var), e) -> malloc(7, offset(var, e)) and offset = fun (var, CExtend(var2, e)) -> if (var = var2) then 0 else (1 + offset(var, e)) ;; (* A couple of `eval' rules have to include tags: the const rule and the closure rule. the other rules are unchanged. *) let rec eval = function unit -> let e = !eReg and k = !kReg and p = !mReg in match (read p) with 1 -> vReg := malloc(0, read(p+1)); (*** Add 0 tag ***) kontinue() | 2 -> mReg := read(read(p+1)); kReg := malloc(1, malloc(read(read(p+1)+1), malloc(e, k))); eval() | 3 -> mReg := read(read(p+1)); kReg := malloc(2, malloc(read(read(p+1)+1), malloc(e, k))); eval() | 4 -> vReg := malloc(1, malloc(read(p+1), e)); (*** Add 1 tag ***) kontinue() | 5 -> mReg := read(read(p+1)); kReg := malloc(5, malloc(read(read(p+1)+1), malloc(e, k))); eval() | 6 -> mReg := read(read(p+1)); kReg := malloc(7, malloc(read(read(read(p+1)+1)), malloc(read(read(read(p+1)+1)+1), malloc(e, k)))); eval() | 7 -> vReg := lookup(read(p+1), e); kontinue() (* Rules 3, 4, 7, and 0 have to strip off the 0 tag for numbers. Rule 6 has to strip off the 1 tag for functions. Note that we aren't checking the tags. A safe implementation of our language would need to do that, so it could signal a run-time error. *) and kontinue = function unit -> gc(); let p = !kReg and v = !vReg in match (read p) with 1 -> mReg := read(read(p+1)); eReg := read(read(read(p+1)+1)); kReg := malloc(3, malloc(v, read(read(read(p+1)+1)+1))); eval() | 2 -> mReg := read(read(p+1)); eReg := read(read(read(p+1)+1)); kReg := malloc(4, malloc(v, read(read(read(p+1)+1)+1))); eval() | 3 -> vReg := malloc(0, (read(read(read(p+1))+1) - (read(v+1)))); kReg := read(read(p+1)+1); kontinue() | 4 -> vReg := malloc(0, (read(read(read(p+1))+1) * (read(v+1)))); kReg := read(read(p+1)+1); kontinue() | 5 -> mReg := read(read(p+1)); eReg := read(read(read(p+1)+1)); kReg := malloc(6, malloc(v, read(read(read(p+1)+1)+1))); eval() | 6 -> mReg := read(read(read(read(p+1))+1)); eReg := malloc(v, read(read(read(read(p+1))+1)+1)); kReg := read(read(p+1)+1); eval() | 7 -> mReg := (if (read(v+1)=0) then read(read(p+1)) else read(read(read(p+1)+1))); eReg := read(read(read(read(p+1)+1)+1)); kReg := read(read(read(read(p+1)+1)+1)+1); eval() | 0 -> read(v+1) and lookup = function (0, p) -> read(p) | (n, p) -> lookup(n-1, read(p+1)) ;; mReg := comp(onetwenty,CEmpty); kReg := malloc(0, 0); eval() ;;