Start implementing L2

* Distinguish temporary and permanent variables in hardware
* Add allocate and deallocate operations
* Add stack manipulation to the store

lib/compiler.ml

@@ -72,15 +72,15 @@ and generate_code ((({ registers; _ } as compiler), store) : t * Cell.t Store.t)
   in
   let emit_functor_argument =
     emit_argument
-      ( (fun v -> Cell.UnifyVariable v),
-        (fun v -> Cell.UnifyValue v),
-        fun v -> Cell.UnifyVariable v )
+      ( (fun v -> Cell.UnifyVariable (Cell.X v)),
+        (fun v -> Cell.UnifyValue (Cell.X v)),
+        fun v -> Cell.UnifyVariable (Cell.X v) )
   in
   let emit_toplevel_query_argument =
     emit_argument
-      ( (fun v -> Cell.SetVariable v),
-        (fun v -> Cell.SetValue v),
-        fun v -> Cell.SetValue v )
+      ( (fun v -> Cell.SetVariable (Cell.X v)),
+        (fun v -> Cell.SetValue (Cell.X v)),
+        fun v -> Cell.SetValue (Cell.X v) )
   in
   let rec emit_query_argument
       ((({ registers; _ } as compiler), store) : t * Cell.t Store.t)
@@ -90,7 +90,7 @@ and generate_code ((({ registers; _ } as compiler), store) : t * Cell.t Store.t)
     match elem with
     | Functor { namef; elements; arity } ->
         let instruction =
-          Cell.PutStructure ((namef, arity), index_of_register)
+          Cell.PutStructure ((namef, arity), Cell.X index_of_register)
         in
         let compiler, store = add_instruction (compiler, store) instruction in
         List.fold_left emit_query_argument (compiler, store) elements
@@ -108,15 +108,19 @@ and generate_code ((({ registers; _ } as compiler), store) : t * Cell.t Store.t)
           (List.filter non_variable elements)
       in
       let index_of_register = find (Ast.Functor func) registers in
-      let instruction = Cell.PutStructure ((namef, arity), index_of_register) in
+      let instruction =
+        Cell.PutStructure ((namef, arity), Cell.X index_of_register)
+      in
       let compiler, store = add_instruction (compiler, store) instruction in
       let compiler, store =
         List.fold_left emit_toplevel_query_argument (compiler, store) elements
       in
       ({ compiler with variables = S.empty }, store)
   | Functor { namef; elements; arity } ->
       let index_register = find value registers in
-      let instruction = Cell.GetStructure ((namef, arity), index_register) in
+      let instruction =
+        Cell.GetStructure ((namef, arity), Cell.X index_register)
+      in
       let compiler, store = add_instruction (compiler, store) instruction in
       let compiler, store =
         List.fold_left emit_functor_argument (compiler, store) elements

lib/evaluator.ml

@@ -2,31 +2,31 @@ open Machine
 open Machine.Cell
 
 let put_structure (index_of_register : int) (functor_label, functor_arity)
-    ({ store; registers; h_register; _ } as computer) : Machine.t =
+    ({ store; x_registers; h_register; _ } as computer) : Machine.t =
   let structure = Machine.Cell.Structure (h_register + 1) in
   let func = Functor (functor_label, functor_arity) in
   let store =
     Store.heap_put func (h_register + 1)
     @@ Store.heap_put structure h_register store
   in
-  let registers = IM.add index_of_register structure registers in
+  let x_registers = IM.add index_of_register structure x_registers in
   let h_register = h_register + 2 in
-  { computer with store; registers; h_register }
+  { computer with store; x_registers; h_register }
 
 let set_variable (index_of_register : int)
-    ({ store; registers; h_register; _ } as computer) =
+    ({ store; x_registers; h_register; _ } as computer) =
   let reference = Reference h_register in
   let store = Store.heap_put reference h_register store in
-  let registers = IM.add index_of_register reference registers in
+  let x_registers = IM.add index_of_register reference x_registers in
   let h_register = h_register + 1 in
-  { computer with store; registers; h_register }
+  { computer with store; x_registers; h_register }
 
 let set_value (index_of_register : int)
-    ({ store; registers; h_register; _ } as computer) =
-  let value_of_register = IM.find index_of_register registers in
+    ({ store; x_registers; h_register; _ } as computer) =
+  let value_of_register = IM.find index_of_register x_registers in
   let store = Store.heap_put value_of_register h_register store in
   let h_register = h_register + 1 in
-  { computer with store; registers; h_register }
+  { computer with store; x_registers; h_register }
 
 let rec deref (a : int) store : int =
   let cell = Store.heap_get store a in
@@ -63,21 +63,21 @@ let get_structure ((functor_label, functor_arity) : string * int)
   | _ -> { computer with fail = true }
 
 let unify_variable (index_of_register : int)
-    ({ store; registers; h_register; s_register; mode; _ } as computer) :
+    ({ store; x_registers; h_register; s_register; mode; _ } as computer) :
     Machine.t =
   match mode with
   | Read ->
       let value = Store.heap_get store s_register in
-      let registers = IM.add index_of_register value registers in
+      let x_registers = IM.add index_of_register value x_registers in
       let s_register = s_register + 1 in
-      { computer with registers; s_register }
+      { computer with x_registers; s_register }
   | Write ->
       let reference = Reference s_register in
       let store = Store.heap_put reference h_register store in
-      let registers = IM.add index_of_register reference registers in
+      let x_registers = IM.add index_of_register reference x_registers in
       let h_register = h_register + 1 in
       let s_register = s_register + 1 in
-      { computer with store; registers; h_register; s_register }
+      { computer with store; x_registers; h_register; s_register }
 
 let unify (a1 : address) (a2 : address) ({ store; _ } as computer) : Machine.t =
   let newComputer =
@@ -115,7 +115,7 @@ let unify (a1 : address) (a2 : address) ({ store; _ } as computer) : Machine.t =
   aux newComputer
 
 let unify_value (index_of_register : int)
-    ({ store; registers; h_register; s_register; mode; _ } as computer) :
+    ({ store; x_registers; h_register; s_register; mode; _ } as computer) :
     Machine.t =
   match mode with
   | Read ->
@@ -124,32 +124,60 @@ let unify_value (index_of_register : int)
         s_register = s_register + 1;
       }
   | Write ->
-      let value_of_register = IM.find index_of_register registers in
+      let value_of_register = IM.find index_of_register x_registers in
       let store = Store.heap_put value_of_register h_register store in
       let h_register = h_register + 1 in
       let s_register = s_register + 1 in
       { computer with store; h_register; s_register }
 
 let put_variable (index_of_x_register : int) (index_of_a_register : int)
-    ({ store; registers; h_register; _ } as computer) : Machine.t =
+    ({ store; x_registers; h_register; _ } as computer) : Machine.t =
   let reference = Reference h_register in
   let store = Store.heap_put reference h_register store in
-  let registers =
+  let x_registers =
     IM.add index_of_x_register reference
-    @@ IM.add index_of_a_register reference registers
+    @@ IM.add index_of_a_register reference x_registers
   in
-  { computer with store; h_register = h_register + 1; registers }
+  { computer with store; h_register = h_register + 1; x_registers }
 
 let put_value (index_of_x_register : int) (index_of_a_register : int)
-    ({ registers; _ } as computer) : Machine.t =
-  let value = IM.find index_of_x_register registers in
-  let registers = IM.add index_of_a_register value registers in
-  { computer with registers }
+    ({ x_registers; _ } as computer) : Machine.t =
+  let value = IM.find index_of_x_register x_registers in
+  let x_registers = IM.add index_of_a_register value x_registers in
+  { computer with x_registers }
 
 let get_variable (index_of_x_register : int) (index_of_a_register : int)
-    ({ registers; _ } as computer) : Machine.t =
-  let value = IM.find index_of_a_register registers in
-  let registers = IM.add index_of_x_register value registers in
-  { computer with registers }
+    ({ x_registers; _ } as computer) : Machine.t =
+  let value = IM.find index_of_a_register x_registers in
+  let x_registers = IM.add index_of_x_register value x_registers in
+  { computer with x_registers }
 
 let get_value = unify
+
+let deallocate ({ e_register; store; _ } as computer) : Machine.t =
+  let p_register = Store.stack_get store (e_register + 1) in
+  let e_register = Store.stack_get store e_register in
+  let p_register, e_register =
+    match (p_register, e_register) with
+    | Cell.Address p_register, Cell.Address e_register ->
+        (p_register, e_register)
+    | _ -> failwith "unreachable"
+  in
+  { computer with p_register; e_register }
+
+let allocate (n : int)
+    ({ store; e_register; cp_register; p_register; _ } as computer) : Machine.t
+    =
+  let new_e =
+    match Store.stack_get store (e_register + 2) with
+    | Cell.Address n -> n + e_register + 3
+    | _ -> failwith "unreachable"
+  in
+  let store =
+    Store.stack_put (Cell.Address n) (new_e + 2)
+    @@ Store.stack_put (Cell.Address cp_register) (new_e + 1)
+    @@ Store.stack_put (Cell.Address e_register) new_e store
+  in
+  let e_register = new_e in
+  let p_register = p_register + 1 (* This is the instruction size *) in
+  { computer with store; p_register; e_register }

lib/machine.ml

@@ -1,16 +1,18 @@
 module Cell = struct
-  type instruction =
-    | GetStructure of ((string * int) * int)
-    | PutStructure of ((string * int) * int)
-    | PutVariable of (int * int)
-    | GetVariable of (int * int)
-    | SetVariable of int
-    | SetValue of int
-    | UnifyVariable of int
-    | GetValue of (int * int)
-    | PutValue of (int * int)
-    | UnifyValue of int
-    | Call of int
+  type register = X of int | Y of int
+
+  and instruction =
+    | GetStructure of ((string * int) * register)
+    | PutStructure of ((string * int) * register)
+    | PutVariable of (register * register)
+    | GetVariable of (register * register)
+    | SetVariable of register
+    | SetValue of register
+    | UnifyVariable of register
+    | GetValue of (register * register)
+    | PutValue of (register * register)
+    | UnifyValue of register
+    | Call of register
     | Proceed
 
   and t =
@@ -38,10 +40,13 @@ end)
 
 type t = {
   store : Cell.t Store.t;
-  registers : Cell.t IM.t;
+  x_registers : Cell.t IM.t;
+  y_registers : Cell.t IM.t;
   h_register : int;
   s_register : int;
   p_register : int;
+  cp_register : int;
+  e_register : int;
   mode : Mode.t;
   fail : bool;
 }
@@ -60,8 +65,11 @@ let show_store (store : Cell.t Store.t) (how_many : int option) : string =
 let initialize () : t =
   {
     store = Store.initialize Store.empty Store.mem_size Cell.Empty;
-    registers = IM.empty ~eq:( = );
+    x_registers = IM.empty ~eq:( = );
+    y_registers = IM.empty ~eq:( = );
     p_register = 0;
+    cp_register = 0;
+    e_register = Store.stack_start;
     h_register = Store.heap_start;
     s_register = Store.stack_start;
     mode = Mode.Read;

lib/store.ml

@@ -24,6 +24,10 @@ module type Memory = sig
   val heap_get : 'a t -> int -> 'a
   val heap_put : 'a -> int -> 'a t -> 'a t
 
+  (* Stack Operations *)
+  val stack_get : 'a t -> int -> 'a
+  val stack_put : 'a -> int -> 'a t -> 'a t
+
   (* PDL Operations *)
   val pdl_push : 'a -> 'a t -> 'a t
   val pdl_pop : 'a t -> 'a
@@ -72,16 +76,21 @@ module Make (Layout : Layout) = struct
     limited_put 0 Layout.code_size elem index mem
 
   let heap_start = Layout.code_size
+  let pdl_tracker = ref (mem_size - 1)
+  let stack_start = heap_start + Layout.heap_size
+  let trail_start = stack_start + Layout.stack_size
 
   let heap_get (mem : 'a t) (index : int) : 'a =
     limited_get heap_start Layout.heap_size mem index
 
   let heap_put (elem : 'a) (index : int) (mem : 'a t) : 'a t =
     limited_put heap_start Layout.heap_size elem index mem
 
-  let pdl_tracker = ref (mem_size - 1)
-  let stack_start = heap_start + Layout.heap_size
-  let trail_start = stack_start + Layout.stack_size
+  let stack_get (mem : 'a t) (index : int) : 'a =
+    limited_get stack_start Layout.stack_size mem index
+
+  let stack_put (elem : 'a) (index : int) (mem : 'a t) : 'a t =
+    limited_put stack_start Layout.stack_size elem index mem
 
   (* TODO: Add top of trail as an argument to be checked*)
   let pdl_push (elem : 'a) (mem : 'a t) : 'a t =