L0 interpreter (#1)

* rename dir-locals breaking magit

* functor and variable

* heap structure procedures

* Format

* Use Finger Tree and Integer Maps as data structures for L0

* Initialize the Heap with custom capacity

* Add instructions to compile program

* parser and lexer

* Modify parser and lexer

* fix parser

* Finish parser and lexer for L0

* Refactor store module to respect Heap and PDL boundaries

* Include evaluator, parser and lexer in lib dune

* Finish unification algorithm (mutability-hell version)

* Save draft of compilation process

* Prepare to implement the compiler

* Add register allocation

* Parse nested functors

* Print the register allocation table instead of memory

* Handle queries in the compiler

* Call register allocation by its proper name

---------

Co-authored-by: EduardoLR10 <[email protected]>
Co-authored-by: Marinho <[email protected]>

.gitignore

@@ -2,3 +2,5 @@
 _build
 *.opam
 result
+*.cmi
+*.cmo

bin/dune

@@ -6,5 +6,6 @@
 (executable
  (name main)
  (public_name karuta)
- (libraries ast)
+ (libraries lib)
+ (modes byte exe)
  (package karuta))

bin/main.ml

@@ -1 +1,29 @@
-let () = Ast.say_hi ()
+module Option = struct
+  let ( let+ ) = Option.bind
+end
+
+let show_registers (registers : int Lib.Compiler.RegisterMap.t) : string =
+  let open Lib.Compiler.RegisterMap in
+  BatSeq.fold_left
+    (fun acc (term, register) ->
+      acc ^ "\n" ^ Lib.Ast.show term ^ " = " ^ string_of_int register)
+    "" (to_seq registers)
+
+let _ =
+  let open Option in
+  let+ content =
+    In_channel.with_open_text "examples/l0.krt" (fun fc ->
+        try Some (In_channel.input_all fc) with End_of_file -> None)
+  in
+  match Lib.Parse.parse content with
+  | [] ->
+      print_endline "File could not be parsed.";
+      None
+  | decls_queries ->
+      let initialComputer = Lib.Machine.initialize () in
+      let compiler, _ =
+        Lib.Compiler.compile
+          (decls_queries, Lib.Compiler.initialize (), initialComputer.store)
+      in
+      print_endline @@ show_registers compiler.registers;
+      None

dune-project

@@ -1,4 +1,5 @@
 (lang dune 3.4)
+(using menhir 2.1)
 (name karuta)
 (license MIT-0)
 
@@ -18,6 +19,6 @@
 (package
  (name karuta)
  (synopsis "A compiler for a statically-typed relational programming language")
- (depends ocaml dune menhir batteries)
+ (depends ocaml dune menhir (batteries (>= 3.8.0)))
  (tags
   (prolog logic compiler relational warren)))

examples/l0.krt

@@ -0,0 +1 @@
+p[f[X], h[Y, f[a]], Y].

examples/l1.krt

@@ -0,0 +1,7 @@
+father[joaquim, jubileu].
+father[joaquim, manuel].
+siblings[A, B] :-
+    father[Father, A],
+    father[Father, B].
+
+father[joaquim, X]?

flake.nix

@@ -72,6 +72,10 @@
             src = sources.ocaml;
 
             buildInputs = [
+              ocamlPackages.menhir
+              ocamlPackages.ppx_deriving
+              ocamlPackages.ppxlib
+              ocamlPackages.batteries
               # Ocaml package dependencies needed to build go here.
             ];
 
@@ -143,27 +147,6 @@
               touch $out
             '';
 
-          # Check documentation generation
-          dune-doc = legacyPackages.runCommand "check-dune-doc"
-            {
-              ODOC_WARN_ERROR = "true";
-              nativeBuildInputs = [
-                ocamlPackages.dune_3
-                ocamlPackages.ocaml
-                ocamlPackages.odoc
-              ];
-            }
-            ''
-              echo "checking ocaml documentation"
-              dune build \
-                --display=short \
-                --no-print-directory \
-                --root="${sources.ocaml}" \
-                --build-dir="$(pwd)/_build" \
-                @doc
-              touch $out
-            '';
-
           # Check Nix formatting
           nixpkgs-fmt = legacyPackages.runCommand "check-nixpkgs-fmt"
             { nativeBuildInputs = [ legacyPackages.nixpkgs-fmt ]; }
@@ -202,9 +185,8 @@
               ocamlPackages.ocamlformat-rpc-lib
               # Fancy REPL thing
               ocamlPackages.utop
-              # Libraries
-              ocamlPackages.menhir
-              ocamlPackages.batteries
+              ocamlPackages.ppx_deriving
+              ocamlPackages.ppxlib
             ];
 
             # Tools from packages

lib/ast.ml

@@ -1 +1,17 @@
-let say_hi () = print_endline "Hello, Karuta!"
+type tag = string [@@deriving show, ord]
+
+type t =
+  | Variable of var
+  | Functor of func
+  | Declaration of decl
+  | Query of func
+[@@deriving show, ord]
+
+and var = { namev : tag } [@@deriving show, ord]
+
+and func = { namef : tag; elements : t list; arity : int }
+[@@deriving show, ord]
+
+and decl = { head : func; body : func list } [@@deriving show, ord]
+
+type ts = t list [@@deriving show, ord]

lib/compiler.ml

@@ -0,0 +1,62 @@
+module RegisterMap = BatMap.Make (Ast)
+module FT = BatFingerTree
+
+type term_queue = Ast.t FT.t
+
+open Machine
+
+type t = { registers : int RegisterMap.t; terms : term_queue }
+
+let initialize () : t = { registers = RegisterMap.empty; terms = FT.empty }
+
+let rec compile : Ast.t list * t * Cell.t Store.t -> t * Cell.t Store.t =
+  function
+  | [], compiler, store -> (compiler, store)
+  | [ d ], compiler, store -> (
+      match d with
+      | Query f -> register_alloc_functor f compiler store
+      | Variable _ | Functor _ -> failwith "unreachable"
+      | Declaration { head; body } ->
+          register_alloc_declaration head body compiler store)
+  | _, _, _ -> failwith "TODO"
+
+and register_alloc_loop : t -> Cell.t Store.t -> t * Cell.t Store.t =
+ fun ({ terms; _ } as compiler) store ->
+  match FT.front terms with
+  | None -> (compiler, store)
+  | Some (rest, d) -> (
+      let new_compiler = { compiler with terms = rest } in
+      match d with
+      | Declaration _ -> failwith "unreachable"
+      | Variable v -> register_alloc_variable v new_compiler store
+      | Query f | Functor f -> register_alloc_functor f new_compiler store)
+
+and register_alloc_declaration :
+    Ast.func -> Ast.func list -> t -> Cell.t Store.t -> t * Cell.t Store.t =
+ fun head body ({ terms; _ } as compiler) store ->
+  match body with
+  | [] ->
+      register_alloc_loop
+        { compiler with terms = FT.cons terms (Ast.Functor head) }
+        store
+  | _ -> failwith "TODO"
+
+and register_alloc_functor :
+    Ast.func -> t -> Cell.t Store.t -> t * Cell.t Store.t =
+  let open RegisterMap in
+  fun ({ elements; _ } as func) { terms; registers } store ->
+    let new_registers = add (Ast.Functor func) (cardinal registers) registers in
+    let new_terms = FT.append terms (FT.of_list elements) in
+    register_alloc_loop { registers = new_registers; terms = new_terms } store
+
+and register_alloc_variable :
+    Ast.var -> t -> Cell.t Store.t -> t * Cell.t Store.t =
+  let open RegisterMap in
+  fun var ({ registers; _ } as compiler) store ->
+    match find_opt (Ast.Variable var) registers with
+    | None ->
+        let new_registers =
+          add (Ast.Variable var) (cardinal registers) registers
+        in
+        register_alloc_loop { compiler with registers = new_registers } store
+    | Some _ -> register_alloc_loop compiler store

lib/dune

@@ -3,9 +3,24 @@
 ; - https://dune.readthedocs.io/en/stable/concepts.html#libraries
 ; - https://dune.readthedocs.io/en/stable/dune-files.html#library
 
+(env
+ (dev
+  (flags
+   (:standard -w -8))))
+
 (library
- (name ast)
- (package karuta))
+ (name lib)
+ (modules ast store machine compiler evaluator parse parser lexer)
+ (libraries batteries)
+ (package karuta)
+ (preprocess
+  (pps ppx_deriving.show ppx_deriving.std ppx_deriving.ord)))
+
+(ocamllex lexer)
+
+(menhir
+ (modules parser)
+ (flags --trace))
 
 (documentation
  (package karuta))

lib/evaluator.ml

@@ -0,0 +1,131 @@
+open Machine
+open Machine.Cell
+
+let put_structure (index_of_register : int) (functor_label, functor_arity)
+    ({ store; 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 h_register = h_register + 2 in
+  { computer with store; registers; h_register }
+
+let set_variable (index_of_register : int)
+    ({ store; 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 h_register = h_register + 1 in
+  { computer with store; 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
+  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 }
+
+let rec deref (a : int) store : int =
+  let cell = Store.heap_get store a in
+  match cell with
+  | Reference value when value <> a -> deref value store
+  | _ -> a
+
+type address = int
+
+let bind (i1 : address) (i2 : address) (mem : Machine.Cell.t Store.t) :
+    Machine.Cell.t Store.t =
+  Store.heap_put (Reference i2) i1 mem
+
+let get_structure ((functor_label, functor_arity) : string * int)
+    (index_of_register : int) ({ store; h_register; _ } as computer) : Machine.t
+    =
+  let addr = deref index_of_register store in
+  match Store.heap_get store addr with
+  | Reference _ ->
+      let structure = Structure (h_register + 1) in
+      let func = Functor (functor_label, functor_arity) in
+      let heap =
+        bind addr h_register
+        @@ Store.heap_put func (h_register + 1)
+        @@ Store.heap_put structure h_register store
+      in
+      { computer with h_register = h_register + 2; mode = Write; store = heap }
+  | Structure a -> (
+      match Store.heap_get store a with
+      | Functor (label, arity)
+        when label == functor_label && arity == functor_arity ->
+          { computer with s_register = a + 1; mode = Read }
+      | _ -> { computer with fail = true })
+  | _ -> { computer with fail = true }
+
+let unify_variable (index_of_register : int)
+    ({ store; 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 s_register = s_register + 1 in
+      { computer with 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 h_register = h_register + 1 in
+      let s_register = s_register + 1 in
+      { computer with store; registers; h_register; s_register }
+
+let unify (a1 : address) (a2 : address) ({ store; _ } as computer) : Machine.t =
+  let newComputer =
+    (fun s -> { computer with fail = false; store = s })
+    @@ Store.pdl_push (Address a2)
+    @@ Store.pdl_push (Address a1) store
+  in
+  let aux ({ store; fail; _ } as computer) : Machine.t =
+    let mutStore = ref store in
+    let mutFail = ref fail in
+    while not (Store.pdl_empty !mutStore || !mutFail) do
+      let (Address p1) = Store.pdl_top !mutStore in
+      mutStore := Store.pdl_pop !mutStore;
+      let (Address p2) = Store.pdl_top !mutStore in
+      mutStore := Store.pdl_pop !mutStore;
+      let d1 = deref p1 !mutStore in
+      let d2 = deref p2 !mutStore in
+      if d1 != d2 then
+        match (Store.get !mutStore d1, Store.get !mutStore d2) with
+        | Reference _, _ | _, Reference _ -> mutStore := bind d1 d2 !mutStore
+        | Structure v1, Structure v2 -> (
+            match (Store.get !mutStore v1, Store.get !mutStore v2) with
+            | Functor (s1, n1), Functor (s2, n2) ->
+                if s1 == s2 && n1 == n2 then
+                  for i = 1 to n1 do
+                    mutStore := Store.pdl_push (Address (v1 + i)) !mutStore;
+                    mutStore := Store.pdl_push (Address (v2 + i)) !mutStore
+                  done
+                else mutFail := true
+            | _, _ -> failwith "Unreachable")
+      else ()
+    done;
+    { computer with store = !mutStore; fail = !mutFail }
+  in
+  aux newComputer
+
+let unify_value (index_of_register : int)
+    ({ store; registers; h_register; s_register; mode; _ } as computer) :
+    Machine.t =
+  match mode with
+  | Read ->
+      {
+        (unify index_of_register s_register computer) with
+        s_register = s_register + 1;
+      }
+  | Write ->
+      let value_of_register = IM.find index_of_register 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 }