diff --git a/DOOML/.gitignore b/DOOML/.gitignore new file mode 100644 index 00000000..0e5f1e4b --- /dev/null +++ b/DOOML/.gitignore @@ -0,0 +1,3 @@ +/_build +/_coverage + diff --git a/DOOML/.ocamlformat b/DOOML/.ocamlformat new file mode 100644 index 00000000..25919d0e --- /dev/null +++ b/DOOML/.ocamlformat @@ -0,0 +1,3 @@ +version=0.27.0 +profile=janestreet + diff --git a/DOOML/DOOML.opam b/DOOML/DOOML.opam new file mode 100644 index 00000000..ce90481c --- /dev/null +++ b/DOOML/DOOML.opam @@ -0,0 +1,41 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "A short LLVM demo" +maintainer: ["Georgiy Belyanin" "Ignatiy Sergeev"] +authors: ["Georgiy Belyanin" "Ignatiy Sergeev"] +license: "LGPL-3.0-or-later WITH OCaml-LGPL-linking-exception" +homepage: "https://github.com/Kakadu/comp24" +bug-reports: "https://github.com/Kakadu/comp24/issues" +depends: [ + "ocaml" + "dune" {>= "3.8" & = "3.19.1"} + "angstrom" {= "0.16.0"} + "qcheck" + "bisect_ppx" + "llvm" {= "18-shared"} + "qcheck" {with-tests} + "ppx_deriving_qcheck" {= "0.6"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/Kakadu/comp24.git" +depexts: [ + [ "llvm-18-dev" "clang-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"} +] +pin-depends: [ + ["ppx_deriving_qcheck.0.6" "git+https://github.com/c-cube/qcheck.git#42429bf06ba12373cad02b1404f50d0ad6238af5"] +] +# Don't edit '*.opam' file manually. Use 'dune b @install' diff --git a/DOOML/DOOML.opam.template b/DOOML/DOOML.opam.template new file mode 100644 index 00000000..f4e537bf --- /dev/null +++ b/DOOML/DOOML.opam.template @@ -0,0 +1,7 @@ +depexts: [ + [ "llvm-18-dev" "clang-18" "gcc-riscv64-linux-gnu" "g++-riscv64-linux-gnu" "qemu-user"] {os-distribution = "ubuntu"} +] +pin-depends: [ + ["ppx_deriving_qcheck.0.6" "git+https://github.com/c-cube/qcheck.git#42429bf06ba12373cad02b1404f50d0ad6238af5"] +] +# Don't edit '*.opam' file manually. Use 'dune b @install' diff --git a/DOOML/Makefile b/DOOML/Makefile new file mode 100644 index 00000000..c0615678 --- /dev/null +++ b/DOOML/Makefile @@ -0,0 +1,20 @@ +.PHONY: all test +all: + dune build + +test: + dune test + +TEST_COV_D = /tmp/cov +COVERAGE_OPTS = --coverage-path $(TEST_COV_D) --expect bin/ + +.PHONY: test_coverage coverage +test_coverage: coverage +coverage: + $(RM) -r $(TEST_COV_D) + mkdir -p $(TEST_COV_D) + BISECT_FILE=$(TEST_COV_D)/language dune runtest --no-print-directory \ + --instrument-with bisect_ppx --force + bisect-ppx-report html $(COVERAGE_OPTS) + bisect-ppx-report summary $(COVERAGE_OPTS) + @echo "Use 'xdg-open _coverage/index.html' to see coverage report" diff --git a/DOOML/bin/dune b/DOOML/bin/dune new file mode 100644 index 00000000..5388d800 --- /dev/null +++ b/DOOML/bin/dune @@ -0,0 +1,10 @@ +(executable + (public_name DOOML) + (name main) + (modules main) + (libraries DOOML) + (instrumentation + (backend bisect_ppx))) + +(cram + (deps ./main.exe runtime.c)) diff --git a/DOOML/bin/main.ml b/DOOML/bin/main.ml new file mode 100644 index 00000000..5fce87af --- /dev/null +++ b/DOOML/bin/main.ml @@ -0,0 +1,34 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2023-2025, Kakadu and contributors *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +open DOOML +module Map = Base.Map.Poly + +let failf fmt = Format.kasprintf failwith fmt + +let parse input = + let code = In_channel.with_open_text input In_channel.input_all in + match Fe.parse code with + | Error msg -> Error msg + | Ok ast_list -> Ok (ast_list |> Cc.cc |> Ll.ll |> Anf.anf) +;; + +let () = + match Array.to_list Sys.argv with + | [ _exe; input; output ] -> + let riscv_triple = "riscv64-unknown-linux-gnu" in + let riscv_features = "+d" in + let module_ = + match parse input with + | Error msg -> failf "%s" msg + | Ok anf_list -> Codegen.emit_ir ~triple:riscv_triple anf_list + in + Codegen.optimize_ir ~triple:riscv_triple module_; + Codegen.emit_binary ~triple:riscv_triple ~features:riscv_features module_ output + | _ -> exit 1 +;; diff --git a/DOOML/bin/run.t b/DOOML/bin/run.t new file mode 100644 index 00000000..c5569b68 --- /dev/null +++ b/DOOML/bin/run.t @@ -0,0 +1,20 @@ + $ clang-18 -c runtime.c -o runtime.o + $ ./main.exe + $ ls + main.exe + out.ll + runtime.c + runtime.o + $ cat out.ll | grep -E 'source_filename|target datalayout|ModuleID' --invert-match + target triple = "x86_64-pc-linux-gnu" + + declare void @print_int(i64) + + define i64 @main() { + entry: + call void @print_int(i64 70) + ret i64 0 + } + $ clang-18 out.ll runtime.o -o demo1.exe + $ echo "Press $(./demo1.exe) to pay respect" + Press F to pay respect diff --git a/DOOML/bin/runtime.c b/DOOML/bin/runtime.c new file mode 100644 index 00000000..9c00aa03 --- /dev/null +++ b/DOOML/bin/runtime.c @@ -0,0 +1,10 @@ +/* Copyright 2023-2024, Kakadu and contributors */ +/* SPDX-License-Identifier: LGPL-3.0-or-later */ + +#include +#include + +void print_int(int64_t n) { + putchar(n); + fflush(stdout); +} \ No newline at end of file diff --git a/DOOML/dune-project b/DOOML/dune-project new file mode 100644 index 00000000..3901660e --- /dev/null +++ b/DOOML/dune-project @@ -0,0 +1,33 @@ +(lang dune 3.8) + +(name DOOML) + +(generate_opam_files true) + +(source + (github Kakadu/comp24)) + +(authors "Georgiy Belyanin" "Ignatiy Sergeev") + +(maintainers "Georgiy Belyanin" "Ignatiy Sergeev") + +(license "LGPL-3.0-or-later WITH OCaml-LGPL-linking-exception") + +(package + (name DOOML) + (synopsis "A short LLVM demo") + (depends + ocaml + (dune + (= "3.19.1")) + (angstrom + (= "0.16.0")) + qcheck + bisect_ppx + (llvm + (= "18-shared")) + (qcheck :with-tests) + (ppx_deriving_qcheck + (= "0.6")))) + +; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project diff --git a/DOOML/lib/anf.ml b/DOOML/lib/anf.ml new file mode 100644 index 00000000..34c0d8cc --- /dev/null +++ b/DOOML/lib/anf.ml @@ -0,0 +1,427 @@ +type immexpr = + | ImmNum of int + | ImmUnit + | ImmId of string + | ImmTuple of immexpr list +[@@deriving variants] + +let rec pp_immexpr ppf = function + | ImmNum d -> Format.fprintf ppf "%d" d + | ImmUnit -> Format.fprintf ppf "()" + | ImmId s -> Format.fprintf ppf "%s" s + | ImmTuple s -> + Format.fprintf + ppf + "(%a)" + (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") pp_immexpr) + s +;; + +type cexpr = + | CImm of immexpr + | CIte of immexpr * aexpr * aexpr + | CApp of string * immexpr list + +and aexpr = + | ALet of string * cexpr * aexpr + | AExpr of cexpr + +let cimm imm = CImm imm +let cite cond_ then_ else_ = CIte (cond_, then_, else_) +let capp f args = CApp (f, args) +let alet bind v body = ALet (bind, v, body) +let aexpr cexpr = AExpr cexpr + +let rec pp_cexpr ppf = function + | CImm imm -> Format.fprintf ppf "%a" pp_immexpr imm + | CIte (cond_, then_, else_) -> + Format.fprintf + ppf + "if %a then@;<1 2>@[%a@]@;<1 0>else@;<1 2>@[%a@]" + pp_immexpr + cond_ + pp_aexpr + then_ + pp_aexpr + else_ + | CApp (s, immexprs) -> + Format.fprintf + ppf + "(%s) %a" + s + (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf " ") pp_immexpr) + immexprs + +and pp_aexpr ppf = function + | ALet (name, cexpr, aexpr) -> + Format.fprintf + ppf + "let %s =@;<1 2>@[%a@]@;<1 0>in@;<1 0>%a" + name + pp_cexpr + cexpr + pp_aexpr + aexpr + | AExpr cexpr -> Format.fprintf ppf "%a" pp_cexpr cexpr +;; + +type decl = Decl of Ast.rec_flag * string * string list * aexpr [@@deriving variants] + +let pp_decl ppf = function + | Decl (rec_flag, name, args, body) -> + let rec_flag = + match rec_flag with + | Rec -> "rec " + | NonRec -> "" + in + Format.fprintf + ppf + "@[let %s%s %a =@;<1 2>@[%a@]@;<0 0>;;@]@." + rec_flag + name + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf " ") + Format.pp_print_string) + args + pp_aexpr + body +;; + +module Ctx = struct + type t = { syms : string list } + + let addsym v (ctx : t) = { syms = v :: ctx.syms } + + let gensym ?prefix () (ctx : t) = + let prefix = Option.value prefix ~default:"sup" in + let rec aux i = + let v = String.cat prefix (Int.to_string i) in + if List.mem v ctx.syms then aux (i + 1) else v + in + let v = aux (List.length ctx.syms) in + v, addsym v ctx + ;; +end + +module State = struct + include State.M (Ctx) + + let addsym sym ctx = put (Ctx.addsym sym ctx) () + let gensym = Ctx.gensym +end + +open State + +let rec arg = function + | Ast.PUnit -> return ("()", []) + | Ast.Plug -> return ("_", []) + | Ast.Ident name -> return (name, []) + | Ast.PTuple els -> + let* els = + List.fold_right + (fun a acc -> + let* acc = acc in + let* a = arg a in + return (a :: acc)) + els + (return []) + in + let* sym = gensym () in + let lets = + List.mapi (fun i (name, _) -> name, capp "tuple_nth" [ immid sym; immnum i ]) els + in + let lets = lets @ List.concat_map snd els in + return (sym, lets) +;; + +let rec anf (k : immexpr -> Ctx.t -> aexpr * Ctx.t) = function + | Ast.Const d -> + let imm = + match d with + | Ast.CInt d -> immnum d + | Ast.CUnit -> ImmUnit + in + let* ret = k imm in + return ret + | Var s -> + let* () = addsym s in + let* ret = k (immid s) in + return ret + | Tuple exprs -> + let rec anf_list immexprs = function + | [] -> + let* tsym = gensym () in + let* expr = k (immid tsym) in + return (alet tsym (cimm (immtuple (List.rev immexprs))) expr) + | hd :: tl -> anf (fun immhd -> anf_list (immhd :: immexprs) tl) hd + in + anf_list [] exprs + | App _ as app -> + let rec aux immexprs = function + | Ast.Var s -> + let* sym = gensym () in + let* expr = k (immid sym) in + let ret = alet sym (capp s immexprs) expr in + return ret + | App (f', expr') -> + anf + (fun immexpr -> + let* f' = aux (immexpr :: immexprs) f' in + return f') + expr' + | f -> + anf + (fun immf -> + let* sym = gensym () in + let* sym' = gensym () in + let* expr = k (immid sym') in + return (alet sym (cimm immf) (alet sym' (capp sym immexprs) expr))) + f + in + aux [] app + | Let (_rec, name, bind, expr) -> + let* name, lets = arg name in + let* () = addsym name in + let* ret = + anf + (fun immbind -> + let* expr = anf k expr in + let expr = + List.fold_right (fun (name, bind) acc -> alet name bind acc) lets expr + in + let ret = alet name (cimm immbind) expr in + return ret) + bind + in + return ret + | Ite (cond_, then_, else_) -> + let* ret = + anf + (fun immcond -> + let* then_ = anf (fun imm -> return (aexpr (cimm imm))) then_ in + let* else_ = anf (fun imm -> return (aexpr (cimm imm))) else_ in + let* sym = gensym ~prefix:"ite" () in + let* expr = k (immid sym) in + let ret = alet sym (cite immcond then_ else_) expr in + return ret) + cond_ + in + return ret + | Fun _ -> failwith "should be CC/LL first" +;; + +let anf program = + List.fold_right + (fun a acc -> + let* acc = acc in + match a with + | Ast.LetDecl (rec_flag, name, Fun (args, body)) -> + let* args = + List.fold_right + (fun a acc -> + let* acc = acc in + let* a = arg a in + return (a :: acc)) + args + (return []) + in + let args, lets = List.split args in + let lets = List.concat lets in + let* body = anf (fun imm -> return (aexpr (cimm imm))) body in + let* name, lets' = arg name in + let body = + List.fold_right (fun (name, bind) acc -> alet name bind acc) lets body + in + let ret = decl rec_flag name args body in + let lets' = + List.map (fun (name, bind) -> decl Ast.nonrec_ name [] (aexpr bind)) lets' + in + return ((ret :: lets') @ acc) + | Ast.LetDecl (rec_flag, name, v) -> + let* v = anf (fun imm -> return (aexpr (cimm imm))) v in + let* name, lets = arg name in + let v = List.fold_right (fun (name, bind) acc -> alet name bind acc) lets v in + let ret = decl rec_flag name [] v in + return (ret :: acc)) + program + (return []) + { syms = [] } + |> fst +;; + +let%expect_test "basic" = + let ast = + Fe.parse + {| + let f = + let q = f ((g + sup0) * (2 * i)) in + q ;; + |} + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_decl) + (anf ast); + [%expect + {| + let f = + let sup2 = + (*) 2 i + in + let sup5 = + (+) g sup0 + in + let sup6 = + (*) sup5 sup2 + in + let sup7 = + (f) sup6 + in + let q = + sup7 + in + q + ;; + |}] +;; + +let%expect_test "ite" = + let ast = + Fe.parse + {| + let rec fac = + if (k = 1) then (1) else (fac (k - 1) * k) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_decl) + (anf ast); + [%expect + {| + let rec fac = + let sup1 = + (=) k 1 + in + let ite7 = + if sup1 then + 1 + else + let sup4 = + (-) k 1 + in + let sup5 = + (fac) sup4 + in + let sup6 = + (*) sup5 k + in + sup6 + in + ite7 + ;; + |}] +;; + +let%expect_test "task 2" = + let asts = + Fe.parse + {| + let main = + let x = if (if 0 then 1 else 2) + then 0 else 1 in + large x + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + |> Cc.cc + |> Ll.ll + |> anf + in + Format.printf "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_decl) asts; + [%expect + {| + let main = + let ite1 = + if 0 then 1 else 2 + in + let ite2 = + if ite1 then 0 else 1 + in + let x = + ite2 + in + let sup4 = + (large) x + in + sup4 + ;; + |}] +;; + +let%expect_test "task 3" = + let asts = + Fe.parse + {| + let (f, g) = fun a (b, c) -> + let (b1, b2) = b in + let (c1, c2) = c in + b1 + b2 + c1 + c2 + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + |> Cc.cc + |> Ll.ll + |> anf + in + Format.printf "%a" (Format.pp_print_list ~pp_sep:Format.pp_print_newline pp_decl) asts; + [%expect + {| + let sup14 a sup0 = + let b = + (tuple_nth) sup0 0 + in + let c = + (tuple_nth) sup0 1 + in + let sup1 = + b + in + let b1 = + (tuple_nth) sup1 0 + in + let b2 = + (tuple_nth) sup1 1 + in + let sup4 = + c + in + let c1 = + (tuple_nth) sup4 0 + in + let c2 = + (tuple_nth) sup4 1 + in + let sup11 = + (+) b1 b2 + in + let sup12 = + (+) sup11 c1 + in + let sup13 = + (+) sup12 c2 + in + sup13 + ;; + + let f = (tuple_nth) sup14 0;; + + let g = (tuple_nth) sup14 1;; + |}] +;; diff --git a/DOOML/lib/ast.ml b/DOOML/lib/ast.ml new file mode 100644 index 00000000..0c4870d4 --- /dev/null +++ b/DOOML/lib/ast.ml @@ -0,0 +1,127 @@ +type ident = string + +let pp_ident ppf ident = + match String.get ident 0 with + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> Format.fprintf ppf "%s" ident + | _ -> Format.fprintf ppf "(%s)" ident +;; + +let pp_sep_space ppf () = Format.fprintf ppf " " +let pp_sep_quote ppf () = Format.fprintf ppf ", " + +type ty = + | Int + | Bool + | List of ty + | Unit +[@@deriving show, variants] + +type pattern = + | PUnit (** () *) + | Plug (** _ *) + | Ident of ident + | PTuple of pattern list +[@@deriving variants] + +let rec pp_pattern ppf = function + | PUnit -> Format.fprintf ppf "()" + | Plug -> Format.fprintf ppf "_" + | Ident s -> Format.fprintf ppf "%s" s + | PTuple ss -> + Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep:pp_sep_quote pp_pattern) ss +;; + +type decl_body = pattern [@@deriving show] + +type rec_flag = + | Rec + | NonRec +[@@deriving variants] + +type const = + | CInt of int + | CUnit +[@@deriving variants] + +type expr = + | Const of const + | Var of ident + | Tuple of expr list + | App of expr * expr + | Let of rec_flag * pattern * expr * expr + | Ite of expr * expr * expr + | Fun of pattern list * expr +[@@deriving variants] + +let fun_ args = function + | Fun (args', body') -> fun_ (args @ args') body' + | body -> fun_ args body +;; + +let pp_const ppf = function + | CInt c -> Format.fprintf ppf "%d" c + | CUnit -> Format.fprintf ppf "()" + +let rec pp_expr ppf = function + | Const c -> Format.fprintf ppf "%a" pp_const c + | Var ident -> Format.fprintf ppf "%a" pp_ident ident + | Tuple exprs -> + Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep:pp_sep_quote pp_expr) exprs + | App ((Fun _ as f), arg) -> Format.fprintf ppf "(%a) %a" pp_expr f pp_expr arg + | App (f, (Const _ as arg)) | App (f, (Var _ as arg)) -> + Format.fprintf ppf "%a %a" pp_expr f pp_expr arg + | App (f, arg) -> Format.fprintf ppf "%a (%a)" pp_expr f pp_expr arg + | Let (rec_flag, pattern, bind, body) -> + let rec_flag = + match rec_flag with + | Rec -> "rec " + | NonRec -> "" + in + Format.fprintf + ppf + "let %s%a =@;<1 2>@[%a@]@;<1 0>in@;<1 0>%a" + rec_flag + pp_pattern + pattern + pp_expr + bind + pp_expr + body + | Fun (patterns, body) -> + Format.fprintf + ppf + "fun %a ->@;<1 2>@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_space pp_pattern) + patterns + pp_expr + body + | Ite (cond, then_, else_) -> + Format.fprintf + ppf + "if %a then@;<1 2>@[%a@]@;<1 0>else@;<1 2>@[%a@]" + pp_expr + cond + pp_expr + then_ + pp_expr + else_ +;; + +type top_level = LetDecl of rec_flag * pattern * expr [@@deriving variants] + +let pp_top_level ppf = function + | LetDecl (rec_flag, pattern, body) -> + let rec_flag = + match rec_flag with + | Rec -> "rec " + | NonRec -> "" + in + Format.fprintf + ppf + "@[let %s%a =@;<1 2>@[%a@]@;<0 0>;;@]@." + rec_flag + pp_pattern + pattern + pp_expr + body +;; diff --git a/DOOML/lib/builtin.ml b/DOOML/lib/builtin.ml new file mode 100644 index 00000000..7d2137a0 --- /dev/null +++ b/DOOML/lib/builtin.ml @@ -0,0 +1,27 @@ +type t = + { name : string + ; arity : int + } + +let all = + [ { name = "*"; arity = 2 } + ; { name = "/"; arity = 2 } + ; { name = "+"; arity = 2 } + ; { name = "-"; arity = 2 } + ; { name = "<"; arity = 2 } + ; { name = "<="; arity = 2 } + ; { name = "=="; arity = 2 } + ; { name = "="; arity = 2 } + ; { name = "<>"; arity = 2 } + ; { name = ">"; arity = 2 } + ; { name = ">="; arity = 2 } + ; { name = "&&"; arity = 2 } + ; { name = "||"; arity = 2 } + ; { name = "print_int"; arity = 1 } + ; { name = "tuple_nth"; arity = 2 } + ; { name = "collect"; arity = 1 } + ; { name = "get_heap_start"; arity = 1 } + ; { name = "get_heap_fin"; arity = 1 } + ; { name = "print_gc_status"; arity = 1 } + ] +;; diff --git a/DOOML/lib/cc.ml b/DOOML/lib/cc.ml new file mode 100644 index 00000000..8850ab12 --- /dev/null +++ b/DOOML/lib/cc.ml @@ -0,0 +1,372 @@ +module Scope = Set.Make (String) + +module Ctx = struct + type t = + { captured : string list + ; locals : Scope.t + ; globals : Scope.t + ; recs : Scope.t + } + + let rec of_pattern = function + | Ast.PUnit | Plug -> Scope.empty + | Ident s -> Scope.singleton s + | PTuple patterns -> + List.map of_pattern patterns |> List.fold_left Scope.union Scope.empty + ;; + + let mem s (ctx : t) = + Scope.mem s ctx.locals || Scope.mem s ctx.recs || Scope.mem s ctx.globals + ;; + + let capture name (ctx : t) = + if mem name ctx + then ctx + else { ctx with locals = Scope.add name ctx.locals; captured = name :: ctx.captured } + ;; + + let extend pattern (ctx : t) = + let names = of_pattern pattern in + { ctx with locals = Scope.union ctx.locals names } + ;; + + let global pattern (ctx : t) = + let names = of_pattern pattern in + { ctx with globals = Scope.union ctx.globals names } + ;; + + let rec_ pattern (ctx : t) = + let names = of_pattern pattern in + { ctx with locals = Scope.union ctx.locals names; recs = names } + ;; + + let nonrec_ pattern (ctx : t) = + let names = of_pattern pattern in + { ctx with locals = Scope.union ctx.locals names; recs = Scope.empty } + ;; + + let up (ctx' : t) (ctx : t) = + let captured = + ctx.captured + |> List.filter (fun local -> + (not (Scope.mem local ctx'.locals)) && not (List.mem local ctx'.captured)) + in + let captured = captured @ ctx'.captured in + { ctx' with captured } + ;; + + let empty = + let scope = + Scope.of_list (Builtin.all |> List.map (fun (builtin : Builtin.t) -> builtin.name)) + in + let locals = scope in + let captured = [] in + { locals; captured; globals = Scope.empty; recs = Scope.empty } + ;; + + let of_args args (ctx : t) = + let scope = + Scope.of_list (Builtin.all |> List.map (fun (builtin : Builtin.t) -> builtin.name)) + in + let locals = + List.map of_pattern args |> List.fold_left Scope.union scope |> Scope.union ctx.recs + in + let captured = [] in + { locals; captured; globals = ctx.globals; recs = Scope.empty } + ;; +end + +module State = struct + include State.M (Ctx) + + let empty = Ctx.empty + let of_args v ctx = get (Ctx.of_args v ctx) + let extend v ctx = put (Ctx.extend v ctx) () + let global v ctx = put (Ctx.global v ctx) () + let rec_ v ctx = put (Ctx.rec_ v ctx) () + let nonrec_ v ctx = put (Ctx.nonrec_ v ctx) () + let capture v ctx = put (Ctx.capture v ctx) () + let up v ctx = put (Ctx.up v ctx) () +end + +open State + +let rec cc = function + | Ast.Const _ as c -> return c + | Var name as v -> + let* () = capture name in + return v + | Tuple exprs -> + let rec cc_list = function + | [] -> return [] + | hd :: tl -> + let* hd = cc hd in + let* tl = cc_list tl in + return (hd :: tl) + in + let* exprs = cc_list exprs in + return (Ast.tuple exprs) + | Fun (args', body') -> + (* fix rec here *) + let* ctx' = of_args args' in + let body'', ctx'' = cc body' ctx' in + let f = Ast.fun_ args' body'' in + let captured = ctx''.captured in + (match captured with + | [] -> return f + | captured -> + let args = List.map Ast.ident captured in + let f = Ast.fun_ args f in + List.fold_left + (fun f v -> + let* f = f in + let* v = cc (Ast.var v) in + Ast.app f v |> return) + (return f) + captured) + | App (f, g) -> + let* f = cc f in + let* g = cc g in + let a = Ast.app f g in + return a + | Let (rec_flag, pattern, bind, body) -> + let* bind = + let* ctx = get in + let* () = + match rec_flag with + | Ast.Rec -> rec_ pattern + | Ast.NonRec -> nonrec_ pattern + in + let* bind = cc bind in + let* () = up ctx in + return bind + in + let* () = extend pattern in + let* body = cc body in + let l = Ast.let_ rec_flag pattern bind body in + return l + | Ite (cond_, then_, else_) -> + let* cond_ = cc cond_ in + let* then_ = cc then_ in + let* else_ = cc else_ in + let ite = Ast.ite cond_ then_ else_ in + return ite +;; + +let cc asts = + List.fold_left + (fun acc (Ast.LetDecl (rec_flag, pattern, body)) -> + let* acc = acc in + let* body = + let* ctx = get in + let* () = + match rec_flag with + | Ast.Rec -> rec_ pattern + | Ast.NonRec -> nonrec_ pattern + in + let* bind = cc body in + let* () = up ctx in + return bind + in + let* () = global pattern in + let ret = Ast.letdecl rec_flag pattern body in + return (ret :: acc)) + (return []) + asts + empty + |> fst + |> List.rev +;; + +let%expect_test "basic" = + let ast = + Fe.parse + {| + let f = fun a b c -> + let g = fun d -> d + a in + let h = fun e -> e + b in + (g c) + (h c) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (cc ast); + [%expect + {| + let f = + fun a b c -> + let g = + (fun a d -> (+) d a) a + in + let h = + (fun b e -> (+) e b) b + in + (+) (g c) (h c) + ;; + |}] +;; + +let%expect_test "basic 2" = + let ast = + Fe.parse + {| + let f = fun a b c -> + let g = fun d -> a + d in + let h = fun e -> b + g e in + let i = fun f -> c + h f + g f + p in + i (a + b + c + q) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (cc ast); + [%expect + {| + let f = + (fun q p a b c -> + let g = + (fun a d -> (+) a d) a + in + let h = + (fun g b e -> (+) b (g e)) g b + in + let i = + (fun p g h c f -> (+) ((+) ((+) c (h f)) (g f)) p) p g h c + in + i ((+) ((+) ((+) a b) c) q)) q p + ;; + |}] +;; + +let%expect_test "recursion" = + let ast = + Fe.parse + {| + let rec f = fun a b -> + let p = f a in + let rec g = fun n -> if (n = 1) then f (p n) n else g (f a b) in + g (a + b) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (cc ast); + [%expect + {| + let rec f = + fun a b -> + let p = + f a + in + let rec g = + (fun b a p f n -> if (=) n 1 then f (p n) n else g (f a b)) b a p f + in + g ((+) a b) + ;; + |}] +;; + +let%expect_test "multiple" = + let ast = + Fe.parse + {| + let rec f = fun n -> + if n = 1 then 1 + else (f (n - 1)) * n + ;; + + let main = fun () -> + let _ = print_int (f 1) in + let _ = print_int (f 2) in + let _ = print_int (f 5) in + print_int (f 8) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (cc ast); + [%expect + {| + let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + let main = + fun () -> + let _ = + print_int (f 1) + in + let _ = + print_int (f 2) + in + let _ = + print_int (f 5) + in + print_int (f 8) + ;; + |}] +;; + +let%expect_test "multiple 2" = + let ast = + Fe.parse + {| + let rec f = fun n -> + if n = 1 then 1 + else (f (n - 1)) * n + ;; + + let b = 1;; + let main = fun () -> + let c = 3 in + let f = fun () -> print_int (f a) in + let f = fun () -> print_int (f (a + b)) in + let f = fun () -> print_int (f (a + c)) in + print_int (f 8) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (cc ast); + [%expect + {| + let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + let b = 1;; + + let main = + (fun a () -> + let c = + 3 + in + let f = + (fun a () -> print_int (f a)) a + in + let f = + (fun a () -> print_int (f ((+) a b))) a + in + let f = + (fun c a () -> print_int (f ((+) a c))) c a + in + print_int (f 8)) a + ;; + |}] +;; diff --git a/DOOML/lib/cc.mli b/DOOML/lib/cc.mli new file mode 100644 index 00000000..c34a1792 --- /dev/null +++ b/DOOML/lib/cc.mli @@ -0,0 +1 @@ +val cc : Ast.top_level list -> Ast.top_level list diff --git a/DOOML/lib/codegen.ml b/DOOML/lib/codegen.ml new file mode 100644 index 00000000..e394ddc9 --- /dev/null +++ b/DOOML/lib/codegen.ml @@ -0,0 +1,427 @@ +module Map = Base.Map.Poly + +let context = Llvm.global_context () +let builder = Llvm.builder context +let the_module = Llvm.create_module context "main" +open (val Llvm_wrapper.make context builder the_module) + +let failf fmt = Format.kasprintf failwith fmt + +type visibility = + | Internal + | External + +let unbox funcs v = + let (f, typ, _) = Map.find_exn funcs "unbox" in + build_call typ f [ v ] + +let box_imm funcs imm = + let (f, typ, _) = Map.find_exn funcs "box_imm" in + build_call typ f [ imm ] + +let define_ibinop ?(box_ret = false) funcs name ret build_f = + let typ = function_type ret [| i64_type; i64_type |] in + let func = define_func name (Llvm.return_type typ) (Llvm.param_types typ) in + let entry = entry_block func in + position_at_end entry; + (match params func with + | [| lhs; rhs |] -> + let (lhs, rhs) = (unbox funcs lhs, unbox funcs rhs) in + let binop = build_f lhs rhs in + let binop = if box_ret then box_imm funcs binop else binop in + build_ret binop |> ignore; + | _ -> assert false); + Llvm_analysis.assert_valid_function func; + ( name, (func, typ, External) ) + +let declare_internal name ret params = + let f = declare_func name ret params in + let t = function_type ret params in + ( name, (f, t, Internal ) ) + +let declare_external name ret params = + let f = declare_func name ret params in + let t = function_type ret params in + ( name, (f, t, External ) ) + +let emit_builtins () = + let rt = [ declare_external "print_int" i64_type [| i64_type |]; + declare_internal "create_closure" i64_type [| i64_type; i64_type; i64_type; i64_type |]; + declare_internal "closure_apply" i64_type [| i64_type; i64_type; i64_type |]; + declare_internal "create_tuple" i64_type [| i64_type; i64_type |]; + declare_external "tuple_nth" i64_type [| i64_type; i64_type |]; + declare_internal "unbox" i64_type [| i64_type |]; + declare_internal "box_imm" i64_type [| i64_type |]; + declare_internal "gc_init" void_type [| |]; + declare_internal "sp_init" void_type [| |]; + declare_external "collect" void_type [| i64_type |]; + declare_external "get_heap_start" i64_type [| i64_type |]; + declare_external "get_heap_fin" i64_type [| i64_type |]; + declare_external "print_gc_status" void_type [| i64_type |]; + ] |> Map.of_alist_exn in + let binops =[ define_ibinop ~box_ret:true rt "+" i64_type build_add; + define_ibinop ~box_ret:true rt "-" i64_type build_sub; + define_ibinop ~box_ret:true rt "*" i64_type build_mul; + define_ibinop ~box_ret:true rt "/" i64_type build_sdiv; + define_ibinop rt "<" i1_type (build_icmp Llvm.Icmp.Slt); + define_ibinop rt ">" i1_type (build_icmp Llvm.Icmp.Sgt); + define_ibinop rt "<=" i1_type (build_icmp Llvm.Icmp.Sle); + define_ibinop rt ">=" i1_type (build_icmp Llvm.Icmp.Sge); + define_ibinop rt "=" i1_type (build_icmp Llvm.Icmp.Eq) ] |> Map.of_alist_exn in + Map.merge_disjoint_exn rt binops + +let emit_create_closure funcs func args = + let arity = params func |> Array.length in + let argc = List.length args in + let (create_closure, typ, _) = Map.find_exn funcs "create_closure" in + let func = build_pointercast func i64_type ~name:"func_toi64_cast" in + let argc_lv = const_int i64_type argc in + let argv_lv = build_array_alloca ~name:"create_closure_argv" i64_type argc_lv in + args |> List.iteri + (fun i a -> + let el_ptr = build_gep argv_lv [| (const_int i64_type i) |] in + build_store a el_ptr |> ignore); + let argv_lv = build_pointercast argv_lv i64_type ~name:"args_arr_toi64_cast" in + let arity_lv = const_int i64_type arity in + build_call typ create_closure [ func; arity_lv; argc_lv; argv_lv ] + +let emit_create_tuple funcs init = + let size = List.length init in + let size_lv = const_int i64_type size in + let init_lv = build_array_alloca ~name:"create_tuple_init" i64_type size_lv in + init |> List.iteri + (fun i a -> + let el_ptr = build_gep init_lv [| (const_int i64_type i) |] in + build_store a el_ptr |> ignore); + let init_lv = build_pointercast init_lv i64_type ~name:"init_arr_toi64_cast" in + let (create_tuple, typ, _) = Map.find_exn funcs "create_tuple" in + build_call typ create_tuple [ size_lv; init_lv ] + +let rec emit_immexpr binds funcs = + function + | Anf.ImmNum n -> const_int i64_type n |> box_imm funcs + | Anf.ImmUnit -> const_int i64_type 0 |> box_imm funcs + | Anf.ImmId s -> + (match Map.find binds s with + | Some lv -> lv + | None -> (match Map.find funcs s with + | Some (f, _, External) -> emit_create_closure funcs f [] + | Some _ + | None -> failf "Unbound variable %s" s)) + | Anf.ImmTuple immexprs -> + let init = List.map (fun immexpr -> emit_immexpr binds funcs immexpr) immexprs in + emit_create_tuple funcs init + +let emit_capp binds funcs name args = + let app_type = match Map.find funcs name with + (** binops are defined inside llvm ir and processed as regular functions + they will be inlined **) + | Some (func, typ, External) -> `Fun (func, typ, params func |> Array.length) + | Some _ + | None -> (match Map.find binds name with + | Some closure -> `Closure closure + | None -> failf "Unbound application %s" name) + in + let argc = List.length args + in + match app_type with + | `Fun (func, typ, arity) when argc == arity -> + let args_lv = args |> List.map + (fun a -> + emit_immexpr binds funcs a) + in + build_call typ func args_lv + | `Fun (func, _, arity) when argc < arity -> + let args = args |> List.map + (fun a -> emit_immexpr binds funcs a) in + emit_create_closure funcs func args + | `Fun (_, _, arity) -> + failf + "Too many arguments (%d) are passed for the function %s, expected %d" + argc + name + arity + | `Closure closure -> + let args_lv = args |> List.map + (fun a -> + emit_immexpr binds funcs a) + in + let (closure_apply, typ, _) = Map.find_exn funcs "closure_apply" in + let argc_lv = const_int i64_type argc in + let argv_lv = build_array_alloca ~name:"closure_apply_argv" i64_type argc_lv in + args_lv |> List.iteri + (fun i a -> + let el_ptr = build_gep argv_lv [| (const_int i64_type i) |] in + build_store a el_ptr |> ignore); + let argv_lv = build_pointercast argv_lv i64_type ~name:"args_arr_toi64_cast" in + let apply_args = [ closure; argc_lv; argv_lv ] in + build_call typ closure_apply apply_args + +let rec emit_cexpr binds funcs = + function + | Anf.CImm imm -> emit_immexpr binds funcs imm + | Anf.CIte (cond_, then_, else_) -> + let cond_lv = emit_immexpr binds funcs cond_ in + let zero = const_int i1_type 0 in + build_icmp Llvm.Icmp.Ne cond_lv zero |> ignore; + + let start_bb = insertion_block () in + let the_function = block_parent start_bb in + + let then_bb = append_block ~name:"then" the_function in + position_at_end then_bb; + let then_lv = emit_aexpr binds funcs then_ in + let new_then_bb = insertion_block () in + + let else_bb = append_block ~name:"else" the_function in + position_at_end else_bb; + let else_lv = emit_aexpr binds funcs else_ in + let new_else_bb = insertion_block () in + + let merge_bb = append_block ~name:"merge" the_function in + position_at_end merge_bb; + + let phi_setup = [(then_lv, new_then_bb); (else_lv, new_else_bb)] in + let phi = build_phi ~name:"ifphi" phi_setup in + + position_at_end start_bb; + build_cond_br cond_lv then_bb else_bb |> ignore; + position_at_end new_then_bb; + build_br merge_bb |> ignore; + position_at_end new_else_bb; + build_br merge_bb |> ignore; + position_at_end merge_bb; + + phi + | Anf.CApp (name, args) -> + emit_capp binds funcs name args + +and emit_aexpr binds funcs = function + | Anf.AExpr expr -> emit_cexpr binds funcs expr + | Anf.ALet (pattern, bind, body) -> + let bind_lv = emit_cexpr binds funcs bind in + let binds = Map.update binds pattern ~f:(fun _ -> bind_lv) in + emit_aexpr binds funcs body + +let emit_decl funcs (decl: Anf.decl) = + match decl with + | Anf.Decl (rec_flag, name, par, body) -> + (if Map.find funcs name != None then failf "Function redefinition %s" name); + let (_, funcs_entry) = List.map (fun _ -> i64_type) par |> Array.of_list |> declare_external name i64_type in + let (f, _, _) = funcs_entry in + let funcs = (match rec_flag with + | Ast.Rec -> funcs |> Map.add_exn ~key:name ~data:funcs_entry + | Ast.NonRec -> funcs) in + let par_binds = par |> + List.mapi (fun i a -> (i, a)) |> + List.fold_left (fun acc (i, a) -> + (a, (params f).(i)) :: acc) [ ] |> Map.of_alist in + let par_binds = match par_binds with + | `Duplicate_key k -> failf "Multiple parameters %s in fun %s" k name + | `Ok m -> m in + let entry_bb = append_block ~name:"entry" f in + position_at_end entry_bb; + (if name = "main" then + let (gc_init, gc_init_t, _) = Map.find_exn funcs "gc_init" in + build_call gc_init_t gc_init [ ] |> ignore; + let (sp_init, sp_init_t, _) = Map.find_exn funcs "sp_init" in + build_call sp_init_t sp_init [ ] |> ignore); + let body = emit_aexpr par_binds funcs body in + let body = if name = "main" then unbox funcs body else body in + build_ret body |> ignore; + let funcs = (match rec_flag with + | Ast.Rec -> funcs + | Ast.NonRec -> funcs |> Map.add_exn ~key:name ~data:funcs_entry) in + Llvm_analysis.assert_valid_function f; + funcs +;; + +let emit_ir ?(triple = "x86_64-pc-linux-gnu") program = + assert (Llvm_executionengine.initialize ()); + Llvm.set_target_triple triple the_module; + let funcs = emit_builtins () in + List.fold_left (fun funcs d -> emit_decl funcs d) funcs program |> ignore; + Llvm_all_backends.initialize (); + the_module + +let optimize_ir ?(triple = "x86_64-pc-linux-gnu") module_ = + let target = Llvm_target.Target.by_triple triple in + let machine = + Llvm_target.TargetMachine.create + ~triple:triple target in + let options = Llvm_passbuilder.create_passbuilder_options () in + Llvm_passbuilder.passbuilder_options_set_verify_each options true; + Llvm_passbuilder.passbuilder_options_set_slp_vectorization options true; + Llvm_passbuilder.passbuilder_options_set_merge_functions options true; + Llvm_passbuilder.passbuilder_options_set_inliner_threshold options 2; + (match Llvm_passbuilder.run_passes module_ "default" machine options with + | Error e -> failf "Optimization error %s" e + | Ok () -> ()); + Llvm_passbuilder.dispose_passbuilder_options options + +let emit_binary ?(triple = "x86_64-pc-linux-gnu") ?(features = "") module_ file = + let target = Llvm_target.Target.by_triple triple in + let machine = + Llvm_target.TargetMachine.create + ~triple:triple ~features:features target in + Llvm_target.TargetMachine.emit_to_file module_ Llvm_target.CodeGenFileType.ObjectFile file machine + +let pp_module ppf module_= + Format.fprintf ppf "%s" (Llvm.string_of_llmodule module_) + +let%expect_test "basic" = + let ast = + Fe.parse + {| + let rec f = fun n -> + if n = 1 then 1 + else (f (n - 1)) * n + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + pp_module + (Cc.cc ast + |> fun asts -> + Format.printf + "CC: %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + asts; + asts + |> Ll.ll + |> fun asts -> + Format.printf + "LL: %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + asts; + asts + |> Anf.anf + |> fun asts -> + Format.printf + "ANF %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Anf.pp_decl) + asts; + asts |> emit_ir); + [%expect + {| + CC: let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + + LL: let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + + ANF let rec f n = + let sup1 = + (=) n 1 + in + let ite7 = + if sup1 then + 1 + else + let sup4 = + (-) n 1 + in + let sup5 = + (f) sup4 + in + let sup6 = + (*) sup5 n + in + sup6 + in + ite7 + ;; + + + ; ModuleID = 'main' + source_filename = "main" + target triple = "x86_64-pc-linux-gnu" + + define i1 @"="(i64 %0, i64 %1) { + entry: + %2 = icmp eq i64 %0, %1 + ret i1 %2 + } + + define i1 @">="(i64 %0, i64 %1) { + entry: + %2 = icmp sge i64 %0, %1 + ret i1 %2 + } + + define i1 @"<="(i64 %0, i64 %1) { + entry: + %2 = icmp sle i64 %0, %1 + ret i1 %2 + } + + define i1 @">"(i64 %0, i64 %1) { + entry: + %2 = icmp sgt i64 %0, %1 + ret i1 %2 + } + + define i1 @"<"(i64 %0, i64 %1) { + entry: + %2 = icmp slt i64 %0, %1 + ret i1 %2 + } + + define i64 @"/"(i64 %0, i64 %1) { + entry: + %2 = sdiv i64 %0, %1 + ret i64 %2 + } + + define i64 @"*"(i64 %0, i64 %1) { + entry: + %2 = mul i64 %0, %1 + ret i64 %2 + } + + define i64 @-(i64 %0, i64 %1) { + entry: + %2 = sub i64 %0, %1 + ret i64 %2 + } + + define i64 @"+"(i64 %0, i64 %1) { + entry: + %2 = add i64 %0, %1 + ret i64 %2 + } + + declare i64 @tuple_nth(i64, i64) + + declare i64 @create_tuple(i64, i64) + + declare i64 @closure_apply(i64, i64, i64) + + declare i64 @create_closure(i64, i64, i64, i64) + + declare void @print_int(i64) + + define i64 @f(i64 %0) { + entry: + %1 = call i1 @"="(i64 %0, i64 1) + %2 = icmp ne i1 %1, false + br i1 %1, label %then, label %else + + then: ; preds = %entry + br label %merge + + else: ; preds = %entry + %3 = call i64 @-(i64 %0, i64 1) + %4 = call i64 @f(i64 %3) + %5 = call i64 @"*"(i64 %4, i64 %0) + br label %merge + + merge: ; preds = %else, %then + %ifphi = phi i64 [ 1, %then ], [ %5, %else ] + ret i64 %ifphi + } + |}] +;; diff --git a/DOOML/lib/codegen.mli b/DOOML/lib/codegen.mli new file mode 100644 index 00000000..029535e5 --- /dev/null +++ b/DOOML/lib/codegen.mli @@ -0,0 +1,3 @@ +val emit_ir : ?triple:string -> Anf.decl list -> Llvm.llmodule +val optimize_ir : ?triple:string -> Llvm.llmodule -> unit +val emit_binary : ?triple:string -> ?features:string -> Llvm.llmodule -> string -> unit diff --git a/DOOML/lib/dune b/DOOML/lib/dune new file mode 100644 index 00000000..1b071717 --- /dev/null +++ b/DOOML/lib/dune @@ -0,0 +1,48 @@ +(library + (name DOOML) + (public_name DOOML.Lib) + (modules Anf Ast Builtin Cc Fe Ll Riscv State Codegen Llvm_wrapper) + (libraries + base + stdlib + angstrom + llvm + llvm.analysis + llvm.executionengine + llvm.passbuilder + llvm.all_backends) + (inline_tests) + (preprocess + (pps ppx_expect ppx_deriving.show ppx_variants_conv ppx_inline_test)) + (instrumentation + (backend bisect_ppx))) + +(rule + (targets runtime.so) + (deps runtime/runtime.c runtime/call-runtime.h runtime/any-call-runtime.c) + (action + (run gcc -fPIC -shared %{deps} -o %{targets} -lffi))) + +(rule + (targets debug-runtime.so) + (deps runtime/runtime.c runtime/call-runtime.h runtime/any-call-runtime.c) + (action + (run gcc -fPIC -DDEBUG -shared %{deps} -o %{targets} -lffi))) + +(rule + (targets riscv-call-runtime.o) + (deps runtime/riscv-call-runtime.c runtime/call-runtime.h) + (action + (run riscv64-linux-gnu-gcc -c %{deps}))) + +(rule + (targets runtime.o) + (deps runtime/runtime.c runtime/call-runtime.h) + (action + (run riscv64-linux-gnu-gcc -c %{deps}))) + +(rule + (targets riscv64-runtime.a) + (deps runtime.o riscv-call-runtime.o) + (action + (run riscv64-linux-gnu-ar rcs %{targets} %{deps}))) diff --git a/DOOML/lib/fe.ml b/DOOML/lib/fe.ml new file mode 100644 index 00000000..71f87ddb --- /dev/null +++ b/DOOML/lib/fe.ml @@ -0,0 +1,425 @@ +open Angstrom +module Map = Base.Map.Poly + +let is_whitespace = function + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false +;; + +let whitespace = take_while is_whitespace +let whitespace1 = take_while1 is_whitespace +let token f = whitespace *> f <* whitespace + +let is_digit = function + | '0' .. '9' -> true + | _ -> false +;; + +let is_idschar = function + | 'a' .. 'z' | 'A' .. 'Z' | '_' -> true + | _ -> false +;; + +let is_idchar = function + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> true + | _ -> false +;; + +let is_fbinopchar = function + | '$' | '&' | '*' | '+' | '-' | '/' | '=' | '>' | '@' | '^' | '|' | '%' | '<' | '#' -> + true + | _ -> false +;; + +let is_sbinopchar = function + | '$' + | '&' + | '*' + | '+' + | '-' + | '/' + | '=' + | '>' + | '@' + | '^' + | '|' + | '%' + | '<' + | '!' + | '.' + | ':' + | '?' + | '~' -> true + | _ -> false +;; + +let is_funopchar = function + | '?' | '~' | '!' -> true + | _ -> false +;; + +let is_sunopchar = is_sbinopchar + +let kws = + Map.of_alist_exn + [ "rec", () + ; "let", () + ; "in", () + ; "type", () + ; "fun", () + ; "if", () + ; "then", () + ; "else", () + ] +;; + +let spf = Format.asprintf +let pp_sep_space ppf () = Format.fprintf ppf " " +let pp_sep_newline ppf () = Format.fprintf ppf "\n" +let failf fmt = Format.kasprintf fail fmt +let parens f = token (char '(') *> f <* token (char ')') + +let chainl1 e op = + let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in + e >>= go +;; + +let kw = + let* kw = take_while1 is_idchar |> token in + if Map.mem kws kw then return kw else fail (spf "expected keyword, but found %s" kw) +;; + +let ident = + let un_ident = + let* hd = satisfy is_funopchar in + let* tl = take_while is_sunopchar in + String.cat (String.make 1 hd) tl |> return + in + let binop_ident = + let* hd = satisfy is_fbinopchar in + let* tl = take_while is_sbinopchar in + String.cat (String.make 1 hd) tl |> return + in + let* ident = + take_while1 is_idchar |> token <|> parens un_ident <|> parens binop_ident + in + if Map.find kws ident |> Option.is_none + then ident |> return + else failf "expected ident, but found keyword %s" ident +;; + +let punit = (string "()" |> token) *> return Ast.punit +let plug = (string "_" |> token) *> return Ast.plug + +let ptuple pattern = + let tuple = + let* fpattern = pattern in + let* patterns = many (token (char ',') *> pattern) in + return (Ast.ptuple (fpattern :: patterns)) + in + parens tuple +;; + +let pattern = + fix (fun pattern -> + punit <|> plug <|> ptuple pattern <|> (ident >>= fun ident -> return (Ast.ident ident))) +;; + +let const = + (string "()" |> token) *> return (Ast.cunit |> Ast.const) <|> + (let* v = take_while1 is_digit |> token in + v |> int_of_string |> Ast.cint |> Ast.const |> return) +;; + +let var = + let* ident = ident in + Ast.var ident |> return +;; + +let rec_flag = + let rec_ = token (string "rec") *> return Ast.rec_ in + rec_ <|> return Ast.nonrec_ +;; + +let let_ expr = + let* rec_flag = rec_flag in + let* pattern = pattern "expected pattern after 'let'" in + let* _ = token (char '=') in + let* body = + expr spf "expected expression after 'let %a ='" Ast.pp_pattern pattern + in + let* _ = token (string "in") "expected \'in\' after introducing new let binding" in + let* expr = expr "expected expression after 'let ... = ... in'" in + Ast.let_ rec_flag pattern body expr |> return +;; + +let fun_ expr = + let* patterns = many1 pattern "expected one or more function argument names" in + let* _ = token (string "->") in + let* expr = + expr + spf + "expected expression after 'fun %a ' " + (Format.pp_print_list ~pp_sep:pp_sep_space Ast.pp_pattern) + patterns + in + Ast.fun_ patterns expr |> return +;; + +let app expr = + let* f = expr in + let* args = many1 expr in + match args with + | hd :: tl -> List.fold_left Ast.app (Ast.app f hd) tl |> return + | _ -> assert false +;; + +let binops expr = + let binop op expr = + let op = token op in + chainl1 expr op + in + let combine op = + string op *> return (fun lhs rhs -> Ast.app (Ast.app (Ast.var op) lhs) rhs) + in + (* Stolen from https://ocaml.org/manual/5.1/api/Ocaml_operators.html. *) + expr + |> binop (combine "*" <|> combine "/") + |> binop (combine "+" <|> combine "-") + |> binop (combine "<" <|> combine "<=" <|> combine "==" <|> combine "=" <|> combine "<>") + |> binop (combine ">" <|> combine ">=") + |> binop (combine "&&") + |> binop (combine "||") +;; + +let ite expr = + let* cond = expr spf "expected expression inside 'if' condition" in + let* _ = token (string "then") spf "expected 'then'" in + let* then_ = expr spf "expected expression inside 'then' clause" in + let* _ = token (string "else") spf "expected 'else'" in + let* else_ = expr spf "expected expression inside 'else' clause" in + Ast.ite cond then_ else_ |> return +;; + +let tuple expr = + let tuple = + let* fexpr = expr in + let* exprs = many (token (char ',') *> expr) in + return (Ast.tuple (fexpr :: exprs)) + in + parens tuple +;; + +let expr = + fix (fun expr -> + let expr' = + let* c = whitespace *> peek_char in + match c with + | Some '0' .. '9' -> const + | Some '(' -> + let* r = const <|> parens expr <|> tuple expr <|> var in + r |> return + | _ -> var + in + let expr' = app expr' <|> expr' in + let expr' = binops expr' in + let expr' = + (let* kw = kw in + match kw with + | "let" -> let_ expr + | "fun" -> fun_ expr + | "if" -> ite expr + | _ -> fail "") + <|> expr' + in + expr') +;; + +let ty = fail "types and ADTs are not implemented yet" + +let let_decl = + let* rec_flag = rec_flag in + let* pattern = pattern "expected pattern after 'let'" in + let* _ = token (char '=') in + let* body = + expr spf "expected expression after 'let %a ='" Ast.pp_pattern pattern + in + let* _ = token (string ";;") in + Ast.letdecl rec_flag pattern body |> return +;; + +let top_level = + let* kw = kw in + match kw with + | "let" -> + let* () = commit in + let_decl + | "type" -> + let* () = commit in + ty + | _ -> fail "expected top level declaration" +;; + +let parse = parse_string ~consume:Consume.All (many1 top_level) + +let parse_and_print code = + match parse_string ~consume:Consume.All (many1 top_level) code with + | Ok res -> + Format.printf "%a" (Format.pp_print_list ~pp_sep:pp_sep_newline Ast.pp_top_level) res + | Error res -> + Format.printf + "%s" + (res + |> String.split_on_char '>' + |> List.rev + |> List.map String.trim + |> String.concat "\n") +;; + +let%expect_test "const definition to 15" = + parse_and_print "let const_15 = fun () -> 15;;"; + [%expect {| let const_15 = fun () -> 15;; |}] +;; + +let%expect_test "simple algebraic expression" = + parse_and_print "let sub = fun a b c -> a + b + c;;"; + [%expect {| let sub = fun a b c -> (+) ((+) a b) c;; |}] +;; + +let%expect_test "find stddev" = + parse_and_print "let stddev = fun a b c -> a * a + ((b * b) + (c * c));;"; + [%expect {| let stddev = fun a b c -> (+) ((*) a a) ((+) ((*) b b) ((*) c c));; |}] +;; + +let%expect_test "use let ins for test" = + parse_and_print + {| + let some_test = fun a b c -> + let a_plus_b = a + b in + let b_plus_c = b + c in + let c_plus_a = c + a in + 5 + ;; + |}; + [%expect + {| + let some_test = + fun a b c -> + let a_plus_b = + (+) a b + in + let b_plus_c = + (+) b c + in + let c_plus_a = + (+) c a + in + 5 + ;; + |}] +;; + +let%expect_test "wrong let ins" = + parse_and_print + {| + let some_test = fun () -> + let % = 5 in 10 + ;; + |}; + [%expect + {| expected expression after 'let some_test =': expected ident, but found keyword fun |}] +;; + +let%expect_test "simple call" = + parse_and_print "let swap = fun a b k -> k b a;;"; + [%expect {| let swap = fun a b k -> k b a;; |}] +;; + +let%expect_test "simple call with parens" = + parse_and_print "let wrong_swap = fun a b k -> k (b a);;"; + [%expect {| let wrong_swap = fun a b k -> k (b a);; |}] +;; + +let%expect_test "factorial" = + parse_and_print + {| + let rec fac = fun n -> + if n = 0 then + 1 + else + n * (fac (n - 1)) + ;; + |}; + [%expect {| let rec fac = fun n -> if (=) n 0 then 1 else (*) n (fac ((-) n 1));; |}] +;; + +let%expect_test "factorial" = + parse_and_print + {| + let f = 15;; + let g = f + 3;; + let h = g * 15;; + |}; + [%expect + {| + let f = 15;; + + let g = (+) f 3;; + + let h = (*) g 15;; + |}] +;; + +let%expect_test "ite in ite" = + parse_and_print + {| + let f = if (if 1 then 0 else 0) then 1 else 0;; + |}; + [%expect + {| let f = if if 1 then 0 else 0 then 1 else 0;; |}] +;; + +let%expect_test "tuples and plugs" = + parse_and_print + {| + let () = _;; + let _ = _;; + let (a, b) = _;; + |}; + [%expect + {| + let () = _;; + + let _ = _;; + + let (a, b) = _;; + |}] +;; + +let%expect_test "quick check" = + let top_levels = + parse + {| + let rec fac = fun n -> + if n = 0 then + 1 + else + n * (fac (n - 1)) + ;; + |} + |> Result.get_ok + in + let top_levels' = + Format.asprintf + "%a" + (Format.pp_print_list ~pp_sep:pp_sep_newline Ast.pp_top_level) + top_levels + |> parse + |> Result.map_error (fun err -> + Format.printf "%s" err; + err) + |> Result.get_ok + in + Format.printf "%b" (top_levels = top_levels'); + [%expect {| true |}] +;; diff --git a/DOOML/lib/ll.ml b/DOOML/lib/ll.ml new file mode 100644 index 00000000..45fa0315 --- /dev/null +++ b/DOOML/lib/ll.ml @@ -0,0 +1,169 @@ +module Scope = struct + include Set.Make (String) +end + +module Ctx = struct + type t = + { lifts : (Ast.pattern * Ast.pattern list * Ast.expr) list + ; symbols : Scope.t + } + + let gen ?prefix (ctx : t) = + let prefix = Option.value ~default:"_" prefix in + let v = Scope.cardinal ctx.symbols in + let rec aux off = + let name = String.concat "_" [ prefix; Int.to_string (v + off) ] in + if not (Scope.mem name ctx.symbols) then name else aux (off + 1) + in + aux 0 + ;; + + let rec of_pattern = function + | Ast.PUnit | Plug -> Scope.empty + | Ident s -> Scope.singleton s + | PTuple patterns -> + List.map of_pattern patterns |> List.fold_left Scope.union Scope.empty + ;; + + let extend pattern (ctx : t) = + let names = of_pattern pattern in + { ctx with symbols = Scope.union ctx.symbols names } + ;; + + let lift args body (ctx : t) = + let name = gen ctx in + let v = Ast.var name in + let name = Ast.ident name in + let ctx = extend name ctx in + v, { ctx with lifts = (name, args, body) :: ctx.lifts } + ;; + + let empty = { lifts = []; symbols = Scope.empty } +end + +module State = struct + include State.M (Ctx) + + let empty = Ctx.empty + let lift = Ctx.lift + let extend v ctx = put (Ctx.extend v ctx) () +end + +open State + +let rec ll = function + | Ast.Const _ as c -> return c + | Var _ as v -> return v + | Tuple exprs -> + let rec ll_list = function + | [] -> return [] + | hd :: tl -> + let* hd = ll hd in + let* tl = ll_list tl in + return (hd :: tl) + in + let* exprs = ll_list exprs in + return (Ast.tuple exprs) + | Fun (args', body') -> + let* body' = ll body' in + let* f = lift args' body' in + return f + | App (f, g) -> + let* f = ll f in + let* g = ll g in + let a = Ast.app f g in + return a + | Let (rec_flag, pattern, bind, body) -> + let* () = + match rec_flag with + | Ast.Rec -> extend pattern + | Ast.NonRec -> return () + in + let* bind = ll bind in + let* () = extend pattern in + let* body = ll body in + let l = Ast.let_ rec_flag pattern bind body in + return l + | Ite (cond_, then_, else_) -> + let* cond_ = ll cond_ in + let* then_ = ll then_ in + let* else_ = ll else_ in + let ite = Ast.ite cond_ then_ else_ in + return ite +;; + +let ll = + let ctx = ref empty in + List.concat_map (function Ast.LetDecl (rec_flag, pattern, body) -> + (ctx + := match rec_flag with + | Ast.Rec -> extend pattern !ctx |> snd + | Ast.NonRec -> !ctx); + let lifts, body = + match body with + | Fun (args, body) -> + let body, ctx = ll body !ctx in + ctx.lifts, Ast.fun_ args body + | ast -> + let ast, ctx = ll ast !ctx in + ctx.lifts, ast + in + ctx := extend pattern !ctx |> snd; + Ast.letdecl rec_flag pattern body + :: List.map + (fun (name, args, body) -> Ast.letdecl Ast.nonrec_ name (Ast.fun_ args body)) + lifts + |> List.rev) +;; + +let%expect_test "basic" = + let asts = + Fe.parse + {| + let f = + (fun q p -> + (fun q p a b c -> + let g = + (fun a -> fun d -> (+) a d) a + in + let h = + (fun g b -> fun e -> (+) b (g e)) g b + in + let i = + (fun p g h c -> fun f -> (+) ((+) ((+) c (h f)) (g f)) p) p g h c + in + i ((+) ((+) ((+) a b) c) q)) q p) + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + (ll asts); + [%expect + {| + let __0 = fun a d -> (+) a d;; + + let __2 = fun g b e -> (+) b (g e);; + + let __4 = fun p g h c f -> (+) ((+) ((+) c (h f)) (g f)) p;; + + let __6 = + fun q p a b c -> + let g = + __0 a + in + let h = + __2 g b + in + let i = + __4 p g h c + in + i ((+) ((+) ((+) a b) c) q) + ;; + + let f = fun q p -> __6 q p;; + |}] +;; diff --git a/DOOML/lib/ll.mli b/DOOML/lib/ll.mli new file mode 100644 index 00000000..1533096f --- /dev/null +++ b/DOOML/lib/ll.mli @@ -0,0 +1 @@ +val ll : Ast.top_level list -> Ast.top_level list diff --git a/DOOML/lib/llvm_wrapper.ml b/DOOML/lib/llvm_wrapper.ml new file mode 100644 index 00000000..35976b8c --- /dev/null +++ b/DOOML/lib/llvm_wrapper.ml @@ -0,0 +1,120 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2023-2024, Kakadu and contributors *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +open Llvm + +module type S = sig + val context : Llvm.llcontext + val module_ : Llvm.llmodule + val builder : Llvm.llbuilder + val build_store : Llvm.llvalue -> Llvm.llvalue -> Llvm.llvalue + val build_call : ?name:string -> lltype -> llvalue -> llvalue list -> llvalue + val define_func : string -> Llvm.lltype -> Llvm.lltype array -> Llvm.llvalue + val declare_func : string -> Llvm.lltype -> Llvm.lltype array -> Llvm.llvalue + val build_add : ?name:string -> llvalue -> llvalue -> llvalue + val build_sub : ?name:string -> llvalue -> llvalue -> llvalue + val build_mul : ?name:string -> llvalue -> llvalue -> llvalue + val build_sdiv : ?name:string -> llvalue -> llvalue -> llvalue + val build_icmp : ?name:string -> Icmp.t -> llvalue -> llvalue -> llvalue + val build_ret : llvalue -> llvalue + val build_br : llbasicblock -> llvalue + val build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llvalue + val build_phi : ?name:string -> (llvalue * llbasicblock) list -> llvalue + val build_array_alloca : ?name:string -> lltype -> llvalue -> llvalue + val build_gep : ?name:string -> llvalue -> llvalue array -> llvalue + + (** [set_metadata v kind fmt] sets metadata to value [v] of kind [k]. + Returns this value [v]. Useful for attaching debugging *) + val set_metadata + : llvalue + -> string + -> ('a, Format.formatter, unit, llvalue) format4 + -> 'a + + (* ?? *) + + val build_pointercast : ?name:string -> llvalue -> lltype -> llvalue + val position_at_end : llbasicblock -> unit + val append_block : ?name:string -> llvalue -> llbasicblock + val insertion_block : unit -> llbasicblock + + (** Just aliases *) + + val void_type : Llvm.lltype + val block_parent : Llvm.llbasicblock -> Llvm.llvalue + val entry_block : Llvm.llvalue -> Llvm.llbasicblock + val i64_type : Llvm.lltype + val i1_type : Llvm.lltype + val ptr_type : Llvm.lltype + val function_type : lltype -> lltype array -> lltype + val const_int : Llvm.lltype -> int -> Llvm.llvalue + val params : Llvm.llvalue -> Llvm.llvalue array + val pp_value : Format.formatter -> llvalue -> unit +end + +let make context builder module_ = + let module L : S = struct + let context = context + let builder = builder + let module_ = module_ + let build_store a b = Llvm.build_store a b builder + + let build_call ?(name = "") typ f args = + build_call typ f (Array.of_list args) name builder + ;; + + let declare_func name ret params = + let typ = Llvm.function_type ret params in + Llvm.declare_function name typ module_ + ;; + + let define_func name ret params = + let typ = Llvm.function_type ret params in + Llvm.define_function name typ module_ + ;; + + let build_add ?(name = "") l r = build_add l r name builder + let build_sub ?(name = "") l r = build_sub l r name builder + let build_mul ?(name = "") l r = build_mul l r name builder + let build_sdiv ?(name = "") l r = build_sdiv l r name builder + let build_icmp ?(name = "") op l r = build_icmp op l r name builder + let build_pointercast ?(name = "") f typ = Llvm.build_pointercast f typ name builder + let build_ret v = build_ret v builder + let build_br bb = build_br bb builder + let build_cond_br c tb fb = build_cond_br c tb fb builder + let build_phi ?(name = "") rules = build_phi rules name builder + let build_array_alloca ?(name = "") typ n = Llvm.build_array_alloca typ n name builder + let build_gep ?(name = "") v ind = Llvm.build_gep (type_of v) v ind name builder + + let set_metadata v kind fmt = + Format.kasprintf + (fun s -> + Llvm.set_metadata v (Llvm.mdkind_id context kind) (Llvm.mdstring context s); + v) + fmt + ;; + + let position_at_end bb = Llvm.position_at_end bb builder + let insertion_block () = Llvm.insertion_block builder + let append_block ?(name = "") f = Llvm.append_block context name f + + (* Aliases *) + let block_parent = Llvm.block_parent + let entry_block = Llvm.entry_block + let void_type = Llvm.void_type context + let i64_type = Llvm.i64_type context + let i1_type = Llvm.i1_type context + let ptr_type = Llvm.pointer_type context + let function_type = Llvm.function_type + let const_int = Llvm.const_int + let params = Llvm.params + let pp_value ppf x = Format.fprintf ppf "%s" (Llvm.string_of_llvalue x) + end + in + (module L : S) +;; diff --git a/DOOML/lib/riscv.ml b/DOOML/lib/riscv.ml new file mode 100644 index 00000000..b9f87703 --- /dev/null +++ b/DOOML/lib/riscv.ml @@ -0,0 +1,734 @@ +module Map = Map.Make (String) +module Set = Set.Make (String) + +type reg = + | Zero + | Ra + | Sp + | Gp + | Arg of int + | Saved of int + | Temp of int +[@@deriving variants] + +let rv = arg 0 +let bp = saved 0 + +let pp_reg ppf = + Format.( + function + | Zero -> fprintf ppf "zero" + | Ra -> fprintf ppf "ra" + | Sp -> fprintf ppf "sp" + | Gp -> fprintf ppf "gp" + | Arg c -> fprintf ppf "a%d" c + | Saved c -> fprintf ppf "s%d" c + | Temp c -> fprintf ppf "t%d" c) +;; + +type instr = + (* Arithmetic instructions *) + | Addi of reg * reg * int + | Add of reg * reg * reg + | Sh1add of reg * reg * reg + | Sh2add of reg * reg * reg + | Sh3add of reg * reg * reg + | Add_wu of reg * reg * reg + | Sh1add_wu of reg * reg * reg + | Sh2add_wu of reg * reg * reg + | Sh3add_wu of reg * reg * reg + | Addiw of reg * reg * int + | Addw of reg * reg * reg + | Sub of reg * reg * reg + | Subw of reg * reg * reg + | Neg of reg * reg + | Negw of reg * reg + | Mul of reg * reg * reg + | Mulw of reg * reg * reg + | Mulh of reg * reg * reg + | Mulhu of reg * reg * reg + | Mulhsu of reg * reg * reg + | Div of reg * reg * reg + | Divu of reg * reg * reg + | Rem of reg * reg * reg + | Remu of reg * reg * reg + | Min of reg * reg * reg + | Max of reg * reg * reg + | Minu of reg * reg * reg + | Maxu of reg * reg * reg + (* Comparison instructions *) + | Seqz of reg * reg + | Snez of reg * reg + | Slti of reg * reg * int + | Slt of reg * reg * reg + | Sltiu of reg * reg * int + | Sltu of reg * reg * reg + (* Bit manipulation instructions *) + | Bexti of reg * reg * int + | Bext of reg * reg * reg + | Andi of reg * reg * int + | And of reg * reg * reg + | Andn of reg * reg * reg + | Bclri of reg * reg * int + | Bclr of reg * reg * reg + | Ori of reg * reg * int + | Or of reg * reg * reg + | Orn of reg * reg * reg + | Bseti of reg * reg * int + | Bset of reg * reg * reg + | Xori of reg * reg * int + | Xor of reg * reg * reg + | Xnor of reg * reg * reg + | Binvi of reg * reg * int + | Binv of reg * reg * reg + | Not of reg * reg + | Orc_b of reg * reg + (* Shift instructions *) + | Slli of reg * reg * int + | Sll of reg * reg * reg + | Slliw of reg * reg * int + | Sllw of reg * reg * reg + | Slli_wu of reg * reg * int + | Srli of reg * reg * int + | Srl of reg * reg * reg + | Srliw of reg * reg * int + | Srlw of reg * reg * reg + | Srai of reg * reg * int + | Sra of reg * reg * reg + | Sraiw of reg * reg * int + | Sraw of reg * reg * reg + | Rori of reg * reg * int + | Ror of reg * reg * reg + | Rol of reg * reg * reg + | Roriw of reg * reg * int + | Rorw of reg * reg * reg + | Rolw of reg * reg * reg + (* Count instructions *) + | Clz of reg * reg + | Clzw of reg * reg + | Ctz of reg * reg + | Ctzw of reg * reg + | Cpop of reg * reg + | Cpopw of reg * reg + (* Jump and branch instructions *) + | J of string (* label *) + | Jal of reg * string + | Jr of reg * int option + | Jalr of reg * reg * int option + | Call of string (* symbol *) + | Tail of string (* symbol *) + | Ret + | Beq of reg * reg * string (* label *) + | Bne of reg * reg * string (* label *) + | Blt of reg * reg * string (* label *) + | Bgt of reg * reg * string (* label *) + | Bge of reg * reg * string (* label *) + | Ble of reg * reg * string (* label *) + | Bltu of reg * reg * string (* label *) + | Bgtu of reg * reg * string (* label *) + | Bgeu of reg * reg * string (* label *) + | Bleu of reg * reg * string (* label *) + (* Load & store *) + | La of reg * string + | Ld of reg * int * reg + | Sd of reg * int * reg +[@@deriving variants] + +let mv rd rs = addi rd rs 0 +let li rd v = addi rd zero v + +let _pp_instr fmt = + Format.( + function + (* Arithmetic instructions *) + | Addi (rd, rs, imm) -> fprintf fmt "addi %a, %a, %d" pp_reg rd pp_reg rs imm + | Add (rd, rs1, rs2) -> fprintf fmt "add %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh1add (rd, rs1, rs2) -> + fprintf fmt "sh1add %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh2add (rd, rs1, rs2) -> + fprintf fmt "sh2add %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh3add (rd, rs1, rs2) -> + fprintf fmt "sh3add %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Add_wu (rd, rs1, rs2) -> + fprintf fmt "add.wu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh1add_wu (rd, rs1, rs2) -> + fprintf fmt "sh1add.wu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh2add_wu (rd, rs1, rs2) -> + fprintf fmt "sh2add.wu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sh3add_wu (rd, rs1, rs2) -> + fprintf fmt "sh3add.wu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Addiw (rd, rs, imm) -> fprintf fmt "addiw %a, %a, %d" pp_reg rd pp_reg rs imm + | Addw (rd, rs1, rs2) -> fprintf fmt "addw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sub (rd, rs1, rs2) -> fprintf fmt "sub %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Subw (rd, rs1, rs2) -> fprintf fmt "subw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Neg (rd, rs) -> fprintf fmt "neg %a, %a" pp_reg rd pp_reg rs + | Negw (rd, rs) -> fprintf fmt "negw %a, %a" pp_reg rd pp_reg rs + | Mul (rd, rs1, rs2) -> fprintf fmt "mul %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Mulw (rd, rs1, rs2) -> fprintf fmt "mulw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Mulh (rd, rs1, rs2) -> fprintf fmt "mulh %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Mulhu (rd, rs1, rs2) -> + fprintf fmt "mulhu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Mulhsu (rd, rs1, rs2) -> + fprintf fmt "mulhsu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Div (rd, rs1, rs2) -> fprintf fmt "div %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Divu (rd, rs1, rs2) -> fprintf fmt "divu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Rem (rd, rs1, rs2) -> fprintf fmt "rem %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Remu (rd, rs1, rs2) -> fprintf fmt "remu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Min (rd, rs1, rs2) -> fprintf fmt "min %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Max (rd, rs1, rs2) -> fprintf fmt "max %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Minu (rd, rs1, rs2) -> fprintf fmt "minu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Maxu (rd, rs1, rs2) -> fprintf fmt "maxu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + (* Comparison instructions *) + | Seqz (rd, rs) -> fprintf fmt "seqz %a, %a" pp_reg rd pp_reg rs + | Snez (rd, rs) -> fprintf fmt "snez %a, %a" pp_reg rd pp_reg rs + | Slti (rd, rs, imm) -> fprintf fmt "slti %a, %a, %d" pp_reg rd pp_reg rs imm + | Slt (rd, rs1, rs2) -> fprintf fmt "slt %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sltiu (rd, rs, imm) -> fprintf fmt "sltiu %a, %a, %d" pp_reg rd pp_reg rs imm + | Sltu (rd, rs1, rs2) -> fprintf fmt "sltu %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + (* Bit manipulation instructions *) + | Bexti (rd, rs, imm) -> fprintf fmt "bexti %a, %a, %d" pp_reg rd pp_reg rs imm + | Bext (rd, rs1, rs2) -> fprintf fmt "bext %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Andi (rd, rs, imm) -> fprintf fmt "andi %a, %a, %d" pp_reg rd pp_reg rs imm + | And (rd, rs1, rs2) -> fprintf fmt "and %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Andn (rd, rs1, rs2) -> fprintf fmt "andn %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Bclri (rd, rs, imm) -> fprintf fmt "bclri %a, %a, %d" pp_reg rd pp_reg rs imm + | Bclr (rd, rs1, rs2) -> fprintf fmt "bclr %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Ori (rd, rs, imm) -> fprintf fmt "ori %a, %a, %d" pp_reg rd pp_reg rs imm + | Or (rd, rs1, rs2) -> fprintf fmt "or %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Orn (rd, rs1, rs2) -> fprintf fmt "orn %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Bseti (rd, rs, imm) -> fprintf fmt "bseti %a, %a, %d" pp_reg rd pp_reg rs imm + | Bset (rd, rs1, rs2) -> fprintf fmt "bset %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Xori (rd, rs, imm) -> fprintf fmt "xori %a, %a, %d" pp_reg rd pp_reg rs imm + | Xor (rd, rs1, rs2) -> fprintf fmt "xor %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Xnor (rd, rs1, rs2) -> fprintf fmt "xnor %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Binvi (rd, rs, imm) -> fprintf fmt "binvi %a, %a, %d" pp_reg rd pp_reg rs imm + | Binv (rd, rs1, rs2) -> fprintf fmt "binv %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Not (rd, rs) -> fprintf fmt "not %a, %a" pp_reg rd pp_reg rs + | Orc_b (rd, rs) -> fprintf fmt "orc.b %a, %a" pp_reg rd pp_reg rs + (* Shift instructions *) + | Slli (rd, rs, imm) -> fprintf fmt "slli %a, %a, %d" pp_reg rd pp_reg rs imm + | Sll (rd, rs1, rs2) -> fprintf fmt "sll %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Slliw (rd, rs, imm) -> fprintf fmt "slliw %a, %a, %d" pp_reg rd pp_reg rs imm + | Sllw (rd, rs1, rs2) -> fprintf fmt "sllw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Slli_wu (rd, rs, imm) -> fprintf fmt "slli.wu %a, %a, %d" pp_reg rd pp_reg rs imm + | Srli (rd, rs, imm) -> fprintf fmt "srli %a, %a, %d" pp_reg rd pp_reg rs imm + | Srl (rd, rs1, rs2) -> fprintf fmt "srl %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Srliw (rd, rs, imm) -> fprintf fmt "srliw %a, %a, %d" pp_reg rd pp_reg rs imm + | Srlw (rd, rs1, rs2) -> fprintf fmt "srlw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Srai (rd, rs, imm) -> fprintf fmt "srai %a, %a, %d" pp_reg rd pp_reg rs imm + | Sra (rd, rs1, rs2) -> fprintf fmt "sra %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Sraiw (rd, rs, imm) -> fprintf fmt "sraiw %a, %a, %d" pp_reg rd pp_reg rs imm + | Sraw (rd, rs1, rs2) -> fprintf fmt "sraw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Rori (rd, rs, imm) -> fprintf fmt "rori %a, %a, %d" pp_reg rd pp_reg rs imm + | Ror (rd, rs1, rs2) -> fprintf fmt "ror %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Rol (rd, rs1, rs2) -> fprintf fmt "rol %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Roriw (rd, rs, imm) -> fprintf fmt "roriw %a, %a, %d" pp_reg rd pp_reg rs imm + | Rorw (rd, rs1, rs2) -> fprintf fmt "rorw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + | Rolw (rd, rs1, rs2) -> fprintf fmt "rolw %a, %a, %a" pp_reg rd pp_reg rs1 pp_reg rs2 + (* Count instructions *) + | Clz (rd, rs) -> fprintf fmt "clz %a, %a" pp_reg rd pp_reg rs + | Clzw (rd, rs) -> fprintf fmt "clzw %a, %a" pp_reg rd pp_reg rs + | Ctz (rd, rs) -> fprintf fmt "ctz %a, %a" pp_reg rd pp_reg rs + | Ctzw (rd, rs) -> fprintf fmt "ctzw %a, %a" pp_reg rd pp_reg rs + | Cpop (rd, rs) -> fprintf fmt "cpop %a, %a" pp_reg rd pp_reg rs + | Cpopw (rd, rs) -> fprintf fmt "cpopw %a, %a" pp_reg rd pp_reg rs + (* Jump and branch instructions *) + | J label -> fprintf fmt "j %s" label + | Jal (rd, imm) -> fprintf fmt "jal %a, %s" pp_reg rd imm + | Jr (rs, None) -> fprintf fmt "jr %a" pp_reg rs + | Jr (rs, Some imm) -> fprintf fmt "jr %a, %d" pp_reg rs imm + | Jalr (rd, rs, None) -> fprintf fmt "jalr %a, %a" pp_reg rd pp_reg rs + | Jalr (rd, rs, Some imm) -> fprintf fmt "jalr %a, %a, %d" pp_reg rd pp_reg rs imm + | Call symbol -> fprintf fmt "call %s" symbol + | Tail symbol -> fprintf fmt "tail %s" symbol + | Ret -> fprintf fmt "ret" + | Beq (rs1, rs2, label) -> fprintf fmt "beq %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bne (rs1, rs2, label) -> fprintf fmt "bne %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Blt (rs1, rs2, label) -> fprintf fmt "blt %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bgt (rs1, rs2, label) -> fprintf fmt "bgt %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bge (rs1, rs2, label) -> fprintf fmt "bge %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Ble (rs1, rs2, label) -> fprintf fmt "ble %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bltu (rs1, rs2, label) -> fprintf fmt "bltu %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bgtu (rs1, rs2, label) -> fprintf fmt "bgtu %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bgeu (rs1, rs2, label) -> fprintf fmt "bgeu %a, %a, %s" pp_reg rs1 pp_reg rs2 label + | Bleu (rs1, rs2, label) -> fprintf fmt "bleu %a, %a, %s" pp_reg rs1 pp_reg rs2 label + (* Load & Store *) + | La (rd, label) -> fprintf fmt "la %a, %s" pp_reg rd label + | Ld (rd, offset, rs) -> fprintf fmt "ld %a, %d(%a)" pp_reg rd offset pp_reg rs + | Sd (rs, offset, rd) -> fprintf fmt "sd %a, %d(%a)" pp_reg rs offset pp_reg rd) +;; + +type loc = + | Mem of int + | Reg of reg +[@@deriving variants] + +type line = + | Instr of instr + | Comment of string + | Label of string + | Etc of string +[@@deriving variants] + +let todo () = failwith "todo" + +module Ctx = struct + type t = + { code : line list + ; temp_regs : bool Map.t + ; fail : string option + ; arities : int Map.t + ; offset : int + ; offsets : int Map.t + ; lbls : Set.t + } + + let arities = + Builtin.all + |> List.map (fun (builtin : Builtin.t) -> builtin.name, builtin.arity) + |> Map.of_list + ;; + + let empty = + { code = [] + ; temp_regs = Map.empty + ; fail = None + ; arities + ; offset = -16 + ; offsets = Map.empty + ; lbls = Set.empty + } + ;; + + let arity name (ctx : t) = Map.find_opt name ctx.arities + let comment (c : string) (ctx : t) = { ctx with code = comment c :: ctx.code } + let etc (c : string) (ctx : t) = { ctx with code = etc c :: ctx.code } + + let lbl ?prefix (ctx : t) = + let rec aux cnt = + let prefix = Option.value ~default:"lbl" prefix in + let name = String.concat "" [ prefix; Int.to_string cnt ] in + if Set.mem name ctx.lbls + then aux (cnt + 1) + else name, { ctx with lbls = Set.add name ctx.lbls } + in + aux 0 + ;; + + let label (l : string) (ctx : t) = { ctx with code = label l :: ctx.code } + let emit (i : instr) (ctx : t) = { ctx with code = instr i :: ctx.code } + + (*let as_reg (loc : loc) (ctx : t) = match loc with + | Reg reg -> reg + (*| Mem ->*) + ;;*) + + let as_arg (n : int) (loc : loc) (ctx : t) = + match loc with + | Reg (Arg n' as r) when n' = n -> r, ctx + | Reg rs -> + let rd = arg n in + let ctx = emit (mv rd rs) ctx in + rd, ctx + | Mem offset -> + let rd = arg n in + let ctx = emit (ld rd offset bp) ctx in + rd, ctx + ;; + + (*| Mem ->*) + + let fail (msg : string) (ctx : t) = { ctx with fail = Option.some msg } + let total () (ctx : t) = ctx.offset, { ctx with offset = -16 } + let offset (var : string) (ctx : t) = Map.find_opt var ctx.offsets + + let push r (ctx : t) = + let new_offset = ctx.offset - 8 in + let ctx = emit (addi sp sp ~-8) ctx in + let ctx = emit (sd r 0 sp) ctx in + new_offset, { ctx with offset = new_offset } + ;; + + let var (name : string) (ctx : t) = + let offset, ctx = push zero ctx in + let offsets = Map.add name offset ctx.offsets in + offset, { ctx with offsets } + ;; + + (*addi sp, sp, -8 + sd t0, 0(sp)*) + + let args args' ctx = + List.fold_right + (fun (i, a) acc -> + let offset, ctx = var a acc in + let ctx = if i < 8 then emit (sd (arg i) offset bp) ctx else todo () in + ctx) + (args' |> List.mapi (fun i a -> i, a)) + ctx + ;; + + let define name argc ctx = { ctx with arities = Map.add name argc arities } +end + +module State = struct + include State.M (Ctx) + + let arity name = get >>= fun ctx -> return (Ctx.arity name ctx) + let total = Ctx.total + let offset var = get >>= fun ctx -> return (Ctx.offset var ctx) + let emit instr ctx = put (Ctx.emit instr ctx) () + let label lbl ctx = put (Ctx.label lbl ctx) () + let comment c ctx = put (Ctx.comment c ctx) () + let etc c ctx = put (Ctx.etc c ctx) () + let as_arg = Ctx.as_arg + let var = Ctx.var + let push = Ctx.push + let define name argc ctx = put (Ctx.define name argc ctx) () + let args args' ctx = put (Ctx.args args' ctx) () + let empty = Ctx.empty + let lbl = Ctx.lbl + (*let as_reg = Ctx.as_reg*) +end + +open State + +let spf = Format.asprintf +let failf fmt = Format.kasprintf failwith fmt + +let immexpr reg = function + | Anf.ImmNum c -> + let* () = emit (li reg c) in + return reg + | Anf.ImmUnit -> failf "todo" + | ImmId var -> + let* offset = offset var in + (match offset with + | Some offset -> + let* () = emit (ld reg offset bp) in + return reg + | None -> failf "Unknown variable %s" var) + | Anf.ImmTuple _ -> failf "todo" +;; + +let rec cexpr = + let capp name args = + let binop op lhs rhs = + let op = + fun rd rs1 rs2 -> + let return v = [ v rd rs1 rs2 ] in + match op with + | "+" -> return add + | "-" -> return sub + | "*" -> return mul + | "/" -> return div + | "<" -> return slt + | "<=" -> [ slt rd rs2 rs1; xori rd rd 1 ] + | ">" -> [ slt rd rs2 rs1 ] + | ">=" -> [ slt rd rs1 rs2; xori rd rd 1 ] + | "=" -> [ sub (temp 0) rs1 rs2; seqz rd (temp 0) ] + | "<>" -> [ sub (temp 0) rs1 rs2; snez rd (temp 0) ] + | _ -> assert false + in + let* lhs = immexpr (arg 0) lhs in + let* rhs = immexpr (arg 1) rhs in + let* () = + List.fold_left + (fun acc instr -> + let* _ = acc in + emit instr) + (return ()) + (op rv lhs rhs) + in + return rv + in + match name, args with + | (("+" | "-" | "*" | "/" | "<" | ">" | "<=" | ">=" | "=") as op), [ lhs; rhs ] -> + binop op lhs rhs + | name, args -> + let* arity = arity name in + let* arity = + match arity with + | Some arity -> return (`Fun arity) + | None -> + let* offset = offset name in + let* arity = + match offset with + | Some offset -> + let* () = comment "here should be a partial call" in + return (`Closure offset) + | None -> todo () + in + return arity + in + let argc = List.length args in + (match arity with + | `Fun arity when arity == argc -> + let* _ = + List.fold_left + (fun acc (i, a) -> + let* acc = acc in + let* a = immexpr (arg i) a in + return (a :: acc)) + (return []) + (args |> List.mapi (fun i arg -> i, arg)) + in + let* () = emit (jal ra name) in + return rv + | `Fun arity when argc < arity -> + let* _offset = + List.fold_right + (fun a acc -> + let* _ = acc in + let* a = immexpr (temp 0) a in + let* offset = push a in + return offset) + args + (return 0) + in + let* () = emit (la (arg 0) name) in + let* () = emit (li (arg 1) arity) in + let* () = emit (li (arg 2) argc) in + let* () = emit (mv (arg 3) sp) in + let* () = emit (jal ra "create_closure") in + return rv + | `Closure offset -> + let* _offset = + List.fold_right + (fun a acc -> + let* _ = acc in + let* a = immexpr (temp 0) a in + let* offset = push a in + return offset) + args + (return 0) + in + let* () = emit (ld (arg 0) offset bp) in + let* () = emit (li (arg 1) argc) in + let* () = emit (mv (arg 2) sp) in + let* () = emit (jal ra "closure_apply") in + return rv + | `Fun arity -> + failf + "Too many arguments (%d) are passed for the function %s, expected %d" + argc + name + arity) + in + let cite cond_ then_ else_ = + let* cond_ = immexpr (temp 0) cond_ in + let* then_lbl = lbl ~prefix:"then" in + let* end_lbl = lbl ~prefix:"end" in + let* () = emit (bne cond_ zero then_lbl) in + let* _else_ = aexpr else_ in + let* () = emit (j end_lbl) in + let* () = label then_lbl in + let* _then_ = aexpr then_ in + let* () = label end_lbl in + return rv + in + function + | Anf.CImm imm -> immexpr rv imm + | CIte (cond_, then_, else_) -> cite cond_ then_ else_ + | CApp (name, args) -> capp name args + +and aexpr = function + | Anf.AExpr expr -> cexpr expr + | ALet (bind, v, body) -> + let* bind = var bind in + let* v = cexpr v in + let* () = emit (sd v bind bp) in + aexpr body +;; + +let decl rec_flag name args' body = + let* () = + comment + (spf + "%s(%a)" + name + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") + Format.pp_print_string) + args') + in + let* () = label name in + let* () = emit (mv (temp 0) sp) in + let* () = emit (addi sp sp ~-8) in + let* () = emit (sd ra 0 sp) in + let* () = emit (addi sp sp ~-8) in + let* () = emit (sd bp 0 sp) in + let* () = emit (mv bp (temp 0)) in + let* () = + match rec_flag with + | Ast.Rec -> define name (List.length args') + | Ast.NonRec -> return () + in + let* () = args args' in + let* () = comment (spf "Prelude of %s ended here" name) in + let* _ = aexpr body in + let* () = comment (spf "Body of %s ended here" name) in + let* total = total () in + let* () = emit (addi sp sp ~-total) in + let* () = emit (ld ra ~-8 bp) in + let* () = emit (ld bp ~-16 bp) in + let* () = + match rec_flag with + | Ast.Rec -> return () + | Ast.NonRec -> define name (List.length args') + in + let* () = if name <> "main" then emit ret else emit (jal ra "exit2") in + return () +;; + +let riscv decls = + let ctx = empty in + let init = + let* () = etc ".global main" in + return () + in + let ctx = init ctx |> snd in + let ctx = + List.fold_left + (fun acc (Anf.Decl (rec_flag, name, args, body)) -> + let* _acc = acc in + let* _d = decl rec_flag name args body in + return ()) + (return ()) + decls + ctx + |> snd + in + ctx.code |> List.rev +;; + +let pp_code = + Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun ppf -> function + | Etc l -> Format.fprintf ppf "%s" l + | Label l -> Format.fprintf ppf "%s:" l + | Comment c -> Format.fprintf ppf "# %s:" c + | Instr instr -> Format.fprintf ppf " %a" _pp_instr instr) +;; + +let%expect_test "basic" = + let ast = + Fe.parse + {| + let rec f = fun n -> + if n = 1 then 1 + else (f (n - 1)) * n + ;; + |} + |> Result.map_error (fun err -> Format.printf "Error %s" err) + |> Result.get_ok + in + Format.printf + "%a" + pp_code + (Cc.cc ast + |> fun asts -> + Format.printf + "CC: %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + asts; + asts + |> Ll.ll + |> fun asts -> + Format.printf + "LL: %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level) + asts; + asts + |> Anf.anf + |> fun asts -> + Format.printf + "ANF %a\n\n" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline Anf.pp_decl) + asts; + asts |> riscv); + [%expect + {| + CC: let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + + LL: let rec f = fun n -> if (=) n 1 then 1 else (*) (f ((-) n 1)) n;; + + + ANF let rec f n = + let sup1 = + (=) n 1 + in + let ite7 = + if sup1 then + 1 + else + let sup4 = + (-) n 1 + in + let sup5 = + (f) sup4 + in + let sup6 = + (*) sup5 n + in + sup6 + in + ite7 + ;; + + + .global main + # f(n): + f: + addi t0, sp, 0 + addi sp, sp, -8 + sd ra, 0(sp) + addi sp, sp, -8 + sd s0, 0(sp) + addi s0, t0, 0 + addi sp, sp, -8 + sd zero, 0(sp) + sd a0, -24(s0) + # Prelude of f ended here: + addi sp, sp, -8 + sd zero, 0(sp) + ld a0, -24(s0) + addi a1, zero, 1 + sub t0, a0, a1 + seqz a0, t0 + sd a0, -32(s0) + addi sp, sp, -8 + sd zero, 0(sp) + ld t0, -32(s0) + bne t0, zero, then0 + addi sp, sp, -8 + sd zero, 0(sp) + ld a0, -24(s0) + addi a1, zero, 1 + sub a0, a0, a1 + sd a0, -48(s0) + addi sp, sp, -8 + sd zero, 0(sp) + ld a0, -48(s0) + jal ra, f + sd a0, -56(s0) + addi sp, sp, -8 + sd zero, 0(sp) + ld a0, -56(s0) + ld a1, -24(s0) + mul a0, a0, a1 + sd a0, -64(s0) + ld a0, -64(s0) + j end0 + then0: + addi a0, zero, 1 + end0: + sd a0, -40(s0) + ld a0, -40(s0) + # Body of f ended here: + addi sp, sp, 64 + ld ra, -8(s0) + ld s0, -16(s0) + ret + |}] +;; diff --git a/DOOML/lib/runtime/any-call-runtime.c b/DOOML/lib/runtime/any-call-runtime.c new file mode 100644 index 00000000..8c089c06 --- /dev/null +++ b/DOOML/lib/runtime/any-call-runtime.c @@ -0,0 +1,26 @@ +#include "call-runtime.h" +#include +#include +#include + +int64_t call_function(void *func, int64_t arity, int64_t *args) { + ffi_cif cif; + + ffi_type *args_t[arity]; + void *args_v[arity]; + for (int64_t i = 0; i < arity; i++) { + args_t[i] = &ffi_type_sint64; + args_v[i] = &args[i]; + } + + if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, arity, &ffi_type_sint64, args_t) != FFI_OK) { + fprintf(stderr, "closure call failed"); + exit(1); + } + + ffi_sarg ret; + ffi_call(&cif, FFI_FN(func), &ret, args_v); + + return ret; +} + diff --git a/DOOML/lib/runtime/call-runtime.h b/DOOML/lib/runtime/call-runtime.h new file mode 100644 index 00000000..6a2b9353 --- /dev/null +++ b/DOOML/lib/runtime/call-runtime.h @@ -0,0 +1,3 @@ +typedef long int64_t; + +int64_t call_function(void *func, int64_t nargs, int64_t *args); diff --git a/DOOML/lib/runtime/riscv-call-runtime.c b/DOOML/lib/runtime/riscv-call-runtime.c new file mode 100644 index 00000000..bcb8eb88 --- /dev/null +++ b/DOOML/lib/runtime/riscv-call-runtime.c @@ -0,0 +1,110 @@ +#include "call-runtime.h" + +int64_t call_function(void *func, int64_t nargs, int64_t *args) { + int64_t result; + + if (nargs <= 8) { + asm volatile ( + "li t0, 0\n" + "beq %[nargs], t0, 1f\n" + "ld a0, 0(%[args])\n" + + "li t0, 1\n" + "beq %[nargs], t0, 1f\n" + "ld a1, 8(%[args])\n" + + "li t0, 2\n" + "beq %[nargs], t0, 1f\n" + "ld a2, 16(%[args])\n" + + "li t0, 3\n" + "beq %[nargs], t0, 1f\n" + "ld a3, 24(%[args])\n" + + "li t0, 4\n" + "beq %[nargs], t0, 1f\n" + "ld a4, 32(%[args])\n" + + "li t0, 5\n" + "beq %[nargs], t0, 1f\n" + "ld a5, 40(%[args])\n" + + "li t0, 6\n" + "beq %[nargs], t0, 1f\n" + "ld a6, 48(%[args])\n" + + "li t0, 7\n" + "beq %[nargs], t0, 1f\n" + "ld a7, 56(%[args])\n" + + "1:\n" + "jalr %[func]\n" + + "mv %[result], a0\n" + + : [result] "=r" (result) + : [func] "r" (func), [nargs] "r" (nargs), [args] "r" (args) + : "ra", "t0", "a0", "a1", "a2", "a3", "a4", "a5", "a6", "a7", + "memory" + ); + } else { + int64_t stack_size = (nargs - 8) * 8; + + asm volatile ( + "addi sp, sp, -32\n" + "sd ra, 24(sp)\n" + "sd s1, 8(sp)\n" + + "mv s1, %[nargs]\n" + "mv s2, %[args]\n" + + "sub sp, sp, %[stack_size]\n" + + "ld a0, 0(s2)\n" + "ld a1, 8(s2)\n" + "ld a2, 16(s2)\n" + "ld a3, 24(s2)\n" + "ld a4, 32(s2)\n" + "ld a5, 40(s2)\n" + "ld a6, 48(s2)\n" + "ld a7, 56(s2)\n" + + "li t0, 64\n" + "add t1, s2, t0\n" + "mv t2, sp\n" + + "li t3, 8\n" + "sub t4, s1, t3\n" + + "copy_loop:\n" + "beqz t4, copy_done\n" + "ld t5, 0(t1)\n" + "sd t5, 0(t2)\n" + "addi t1, t1, 8\n" + "addi t2, t2, 8\n" + "addi t4, t4, -1\n" + "j copy_loop\n" + + "copy_done:\n" + "jalr %[func]\n" + + "mv %[result], a0\n" + + "add sp, sp, %[stack_size]\n" + + "ld s1, 8(sp)\n" + "ld ra, 24(sp)\n" + "addi sp, sp, 32\n" + : [result] "=r" (result) + : [func] "r" (func), [nargs] "r" (nargs), [args] "r" (args), + [stack_size] "r" (stack_size) + : "ra", "t0", "t1", "t2", "t3", "t4", "t5", + "s1", "s2", + "a0", "a1", "a2", "a3", "a4", "a5", "a6", "a7", + "memory" + ); + } + + return result; +} + diff --git a/DOOML/lib/runtime/runtime.c b/DOOML/lib/runtime/runtime.c new file mode 100644 index 00000000..05655fa7 --- /dev/null +++ b/DOOML/lib/runtime/runtime.c @@ -0,0 +1,385 @@ +#include "call-runtime.h" + +#include +#include +#include +#include +#include + +#define MEM 65536 + +typedef long int64_t; + +typedef struct { + uint32_t size; + uint32_t allocated_size; + uint8_t bank_idx; + uint64_t runs; +} GCStats; + +typedef struct { + GCStats stats; + + int64_t *from_bank_start; + uint32_t from_bank_size; + int64_t *to_bank_start; + uint32_t to_bank_size; + + int64_t *free_space_start; +} GC; + +typedef enum { + Tuple, + Closure, + Forward, + ENUM_SIZE_FORCE_32BIT = UINT8_MAX +} GCObjTag; + +__attribute__((aligned(8))) +typedef struct { + uint32_t size; + GCObjTag tag; +} GCObjHeader; + +typedef struct { + GCObjHeader header; + int64_t callee; + int64_t arity; + int64_t argc; + int64_t args[]; +} GCClosure; + +typedef struct { + GCObjHeader header; + int64_t size; + int64_t fields[]; +} GCTuple; + +typedef struct { + GCObjHeader header; + int64_t ptr; +} GCForward; + +static const uint64_t GC_BANK_SIZE = MEM; +static GC gc; +static int64_t *initial_sp; + +#ifdef DEBUG +#define debugf printf +#define debug_call(...) __VA_ARGS__ +#else +#define debugf(...) +#define debug_call(...) +#endif + +int64_t box_imm(int64_t n) { + return (n << 1) + 1; +} + +bool is_imm(int64_t n) { + return n & 1; +} + +int64_t unbox(int64_t n) { + if (!is_imm(n)) { + return n; + } + return n >> 1; +} + +void gc_init() { + GCStats init_stats = { + .runs = 0, + .bank_idx = 0, + .size = 0, + .allocated_size = 0, + }; + GC init_gc = { + .stats = init_stats, + .from_bank_size = GC_BANK_SIZE, + .from_bank_start = malloc(GC_BANK_SIZE), + .to_bank_size = GC_BANK_SIZE, + .to_bank_start = malloc(GC_BANK_SIZE), + }; + init_gc.free_space_start = init_gc.from_bank_start; + debugf("> bank 0 ranges: %ld : %ld\n", (int64_t)init_gc.from_bank_start, (int64_t)(init_gc.from_bank_start + init_gc.from_bank_size)); + debugf("> bank 1 ranges: %ld : %ld\n", (int64_t)init_gc.to_bank_start, (int64_t)(init_gc.to_bank_start + init_gc.to_bank_size)); + gc = init_gc; +} + +static inline int64_t *get_sp() { + return (int64_t *)__builtin_frame_address(0); +} + +void sp_init() { + initial_sp = get_sp(); +} + +void print_obj_helper(int64_t ptr) { + if (is_imm(ptr)) { + printf("int %ld", unbox(ptr)); + return; + } + GCObjTag tag = ((GCObjHeader *)ptr)->tag; + if (tag == Forward) { + printf("Forward -> %ld: ", ((GCForward *)ptr)->ptr); + print_obj_helper(((GCForward *)ptr)->ptr); + } + if (tag == Closure) { + GCClosure *closure = (GCClosure *)ptr; + printf("Closure %ld(", closure->callee); + for (int i = 0; i < closure->arity; i++) { + if (i < closure->argc) { + print_obj_helper(closure->args[i]); + } else { + printf("..."); + } + if (i != closure->arity - 1) { + printf(", "); + } + } + printf(")"); + } + if (tag == Tuple) { + GCTuple *tuple = (GCTuple *)ptr; + printf("Tuple ("); + for (int i = 0; i < tuple->size; i++) { + print_obj_helper(tuple->fields[i]); + if (i != tuple->size - 1) { + printf(", "); + } + } + printf(")"); + } +} + +void debug_print_value(int64_t ptr) { + debug_call(printf("%ld: ", ptr)); + debug_call(print_obj_helper(ptr)); + debug_call(printf("\n")); +} + +void gc_collect(); + +int64_t *gc_alloc(uint32_t size, GCObjTag tag) { + int64_t *ptr = gc.free_space_start; + uint32_t taken_bytes = ((uint32_t) (ptr - gc.from_bank_start)) / 8; + uint32_t free_space = gc.from_bank_size - taken_bytes; + + if (free_space < size) { + gc_collect(); + ptr = gc.free_space_start; + taken_bytes = ((uint32_t) (ptr - gc.from_bank_start)) / 8; + free_space = gc.from_bank_size - taken_bytes; + if (free_space < size) { + fprintf(stderr, "GC OOM\n"); + exit(1); + } + } + + gc.free_space_start += size * 8; + gc.stats.allocated_size += size; + gc.stats.size += size; + ((GCObjHeader *)ptr)->size = size; + ((GCObjHeader *)ptr)->tag = tag; + + return ptr; +} + +GCClosure *gc_alloc_closure_base(int64_t callee, int64_t arity, int64_t argc) { + int64_t size = sizeof(GCClosure) + arity * 8; + GCClosure *closure = (GCClosure *)gc_alloc(size, Closure); + closure->callee = callee; + closure->arity = arity; + closure->argc = argc; + debugf("< alloc(%ld): closure %ld with %ld(%ld out of %ld)\n", size, (int64_t)closure, callee, argc, arity); + return closure; +} + +GCTuple *gc_alloc_tuple_base(int64_t size) { + int64_t obj_size = sizeof(GCClosure) + size * 8; + GCTuple *tuple = (GCTuple *)gc_alloc(obj_size, Tuple); + tuple->size = size; + debugf("< alloc(%ld): tuple %ld with size %ld\n", obj_size, (int64_t)tuple, size); + return tuple; +} + +void gc_make_fwd(int64_t ptr, int64_t new_ptr) { + ((GCObjHeader *)ptr)->tag = Forward; + ((GCForward *)ptr)->ptr = new_ptr; +} + +int64_t gc_mark_and_copy(int64_t ptr) { + GCObjTag tag = ((GCObjHeader *)ptr)->tag; + if (tag == Forward) { + return ((GCForward *)ptr)->ptr; + } + + GCObjTag size = ((GCObjHeader *)ptr)->tag; + + if (tag == Closure) { + GCClosure *closure = (GCClosure *)ptr; + GCClosure *closure2 = gc_alloc_closure_base(closure->callee, closure->arity, closure->argc); + + // rewrites header and callee + gc_make_fwd(ptr, (int64_t)closure2); + + for (int64_t i = 0; i < closure2->argc; i++) { + int64_t arg = closure->args[i]; + if (is_imm(arg)) { + closure2->args[i] = arg; + } else { + closure2->args[i] = gc_mark_and_copy(arg); + } + } + + return (int64_t)closure2; + } + + if (tag == Tuple) { + GCTuple *tuple = (GCTuple *)ptr; + GCTuple *tuple2 = gc_alloc_tuple_base(tuple->size); + + // rewrites header and size + gc_make_fwd(ptr, (int64_t)tuple2); + + for (int64_t i = 0; i < tuple2->size; i++) { + int64_t field = tuple->fields[i]; + if (is_imm(field)) { + tuple2->fields[i] = field; + } else { + tuple2->fields[i] = gc_mark_and_copy(field); + } + } + + return (int64_t)tuple2; + } + + fprintf(stderr, "unknown gc tag %u\n", tag); + exit(1); +} + +void gc_collect() { + int64_t *sp = get_sp(); + int64_t gc_bank_range_start = (int64_t)gc.from_bank_start; + int64_t gc_bank_range_end = (int64_t)gc.free_space_start; + + int64_t *to_bank_start = gc.to_bank_start; + int64_t to_bank_size = gc.to_bank_size; + gc.to_bank_start = gc.from_bank_start; + gc.from_bank_start = to_bank_start; + gc.to_bank_size = gc.from_bank_size; + gc.from_bank_size = to_bank_size; + gc.free_space_start = gc.from_bank_start; + gc.stats.bank_idx = 1 - gc.stats.bank_idx; + gc.stats.size = 0; + + debugf("> gc_collect\n"); + for (int64_t stack_cell = (int64_t)initial_sp; stack_cell >= (int64_t)sp; stack_cell--) { + int64_t obj_ptr = *(int64_t*)stack_cell; + if (!is_imm(obj_ptr) && obj_ptr >= gc_bank_range_start && obj_ptr < gc_bank_range_end) { + debugf(" gc_root: %ld\n", obj_ptr); + debug_print_value(obj_ptr); + *(int64_t*)stack_cell = gc_mark_and_copy(obj_ptr); + debugf(" new pointer on stack: %ld\n", *(int64_t*)stack_cell); + } + } + + gc.stats.runs += 1; + debugf("< gc_collect\n"); +} + +void collect(int64_t unit) { + gc_collect(); +} + +int64_t get_heap_start(int64_t unit) { + return box_imm((int64_t)gc.from_bank_start); +} + +int64_t get_heap_fin(int64_t unit) { + return box_imm((int64_t)(gc.from_bank_start + gc.from_bank_size)); +} + +void print_gc_status(int64_t unit) { + printf("GC status\n"); + printf("Bank index: %u\n", gc.stats.bank_idx); + printf("Bank capacity: %u\n", gc.from_bank_size); + printf("Allocated: %u\n", gc.stats.size); + printf("Total allocated: %u\n", gc.stats.allocated_size); + printf("GC runs: %ld\n", gc.stats.runs); +} + +int64_t create_tuple(int64_t size, int64_t init) { + GCTuple *tuple = gc_alloc_tuple_base(size); + for (int64_t i = 0; i < size; i++) { + tuple->fields[i] = ((int64_t*) init)[i]; + } + + return (int64_t) tuple; +} + +int64_t tuple_nth(int64_t tuple, int64_t i) { + int64_t unboxed_i = unbox(i); + GCTuple *tuple_ptr = (GCTuple*) tuple; + if (unboxed_i >= tuple_ptr->size) { + fprintf(stderr, "tuple_nth: index is out of bounds\n"); + exit(1); + } + return tuple_ptr->fields[unboxed_i]; +} + +int64_t create_closure(int64_t callee, int64_t arity, int64_t argc, int64_t argv_) { + assert(argc < arity); + + GCClosure *closure = gc_alloc_closure_base(callee, arity, argc); + + int64_t *argv = (int64_t*) argv_; + for (int64_t i = 0; i < argc; i++) { + closure->args[i] = argv[i]; + } + + return (int64_t) closure; +} + +GCClosure *copy_closure(GCClosure *closure) { + GCClosure *closure2 = gc_alloc_closure_base(closure->callee, closure->arity, closure->argc); + for (int64_t i = 0; i < closure->argc; i++) { + closure2->args[i] = closure->args[i]; + } + + return closure2; +} + +int64_t closure_apply(int64_t closure_, int64_t argc, int64_t argv_) { + debugf("> closure_apply\n"); + debugf(" orig: "); + debug_print_value(closure_); + + int64_t *argv = (int64_t*) argv_; + GCClosure *closure = copy_closure((GCClosure *)closure_); + int64_t current_argc = closure->argc; + for (int64_t i = 0; i < argc; i++) { + closure->args[i + current_argc] = argv[i]; + closure->argc++; + } + + debugf(" applied: "); + debug_print_value((int64_t)closure); + + if (closure->argc >= closure->arity) { + debugf(" closure_apply: calling\n"); + return call_function((void*) closure->callee, closure->arity, closure->args); + } else { + debugf(" closure_apply: returning a new closure"); + return (int64_t) closure; + } +} + +int64_t print_int(int64_t n) { + return box_imm(printf("%ld\n", unbox(n))); +} + +void exit2(void) { + exit(0); +} diff --git a/DOOML/lib/state.ml b/DOOML/lib/state.ml new file mode 100644 index 00000000..f090df92 --- /dev/null +++ b/DOOML/lib/state.ml @@ -0,0 +1,19 @@ +module M (S : sig + type t + end) = +struct + type state = S.t + type 'a t = state -> 'a * state + + let return v st = v, st + + let ( >>= ) m f st = + let v, st' = m st in + f v st' + ;; + + let ( let* ) = ( >>= ) + let get st = st, st + let put st v = v, st + let run m = m +end diff --git a/DOOML/many_tests/.ocamlformat b/DOOML/many_tests/.ocamlformat new file mode 100644 index 00000000..e3346c16 --- /dev/null +++ b/DOOML/many_tests/.ocamlformat @@ -0,0 +1 @@ +disable=true diff --git a/DOOML/many_tests/typed/001fac.ml b/DOOML/many_tests/typed/001fac.ml new file mode 120000 index 00000000..219cccf7 --- /dev/null +++ b/DOOML/many_tests/typed/001fac.ml @@ -0,0 +1 @@ +../../../manytests/typed/001fac.ml \ No newline at end of file diff --git a/DOOML/many_tests/typed/dune b/DOOML/many_tests/typed/dune new file mode 100644 index 00000000..f66331bb --- /dev/null +++ b/DOOML/many_tests/typed/dune @@ -0,0 +1,2 @@ +(cram + (deps ./001fac.ml)) diff --git a/DOOML/many_tests/typed/typed.t b/DOOML/many_tests/typed/typed.t new file mode 100644 index 00000000..ab349b10 --- /dev/null +++ b/DOOML/many_tests/typed/typed.t @@ -0,0 +1,2 @@ + $ wc 001fac.ml + 6 30 105 001fac.ml diff --git a/DOOML/out.ll b/DOOML/out.ll new file mode 100644 index 00000000..9f73f8af --- /dev/null +++ b/DOOML/out.ll @@ -0,0 +1,12 @@ +; ModuleID = 'main' +source_filename = "main" +target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128" +target triple = "x86_64-pc-linux-gnu" + +declare void @print_int(i64) + +define i64 @main() { +entry: + call void @print_int(i64 70) + ret i64 0 +} diff --git a/DOOML/shell.nix b/DOOML/shell.nix new file mode 100644 index 00000000..10cf0b93 --- /dev/null +++ b/DOOML/shell.nix @@ -0,0 +1,12 @@ +{ pkgs ? import {} }: +pkgs.mkShell { + name = "Chrobelias"; + packages = with pkgs; [ + gmp + opam + + llvm_18 + zlib + libtinfo + ]; +} diff --git a/DOOML/test_qc/dune b/DOOML/test_qc/dune new file mode 100644 index 00000000..9ca61266 --- /dev/null +++ b/DOOML/test_qc/dune @@ -0,0 +1,13 @@ +(executable + (name test_qc) + (modules test_qc) + (libraries qcheck angstrom) + (preprocess + (pps ppx_deriving_qcheck ppx_deriving.show))) + +(rule + (alias runtest) + (deps + (:< test_qc.exe)) + (action + (run %{<}))) diff --git a/DOOML/test_qc/test_qc.ml b/DOOML/test_qc/test_qc.ml new file mode 100644 index 00000000..fa125b7f --- /dev/null +++ b/DOOML/test_qc/test_qc.ml @@ -0,0 +1,98 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2023-2024, Kakadu and contributors *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"] + +(* run this test via `dune test --force` *) + +module AST = struct + type t = + | Const of (int[@gen QCheck.Gen.return 1]) + | Add of t * t + [@@deriving qcheck, show { with_path = false }] +end + +module PP = struct + let rec pp ppf = function + | AST.Const n -> Format.fprintf ppf "%d" n + (* | Add (l, r) -> Format.fprintf ppf "%a+%a" pp l pp r *) + | Add (l, r) -> Format.fprintf ppf "(%a+%a)" pp l pp r + ;; +end + +module Parser = struct + open Angstrom + + let prio expr table = + let len = Array.length table in + let rec helper level = + if level >= len + then expr + else ( + let xs = table.(level) in + return (List.fold_left (fun acc (op, r) -> op acc r)) + <*> helper (level + 1) + <*> many + (choice + (List.map + (fun (op, f) -> op *> helper (level + 1) >>= fun r -> return (f, r)) + xs))) + in + helper 0 + ;; + + let expr_small = + let code0 = Char.code '0' in + Angstrom.satisfy (function + | '0' .. '9' -> true + | _ -> false) + >>| fun c -> AST.Const (Char.code c - code0) + ;; + + let expr = + fix (fun self -> + let add a b = AST.Add (a, b) in + prio (expr_small <|> (char '(' *> self <* char ')')) [| [ char '+', add ] |]) + ;; +end + +let rec shrink_expr = + let open QCheck.Iter in + (* fun _ -> empty *) + function + | AST.Const _ -> empty + | Add (l, r) -> + of_list [ l; r ] + <+> (shrink_expr l >>= fun l -> return (AST.Add (l, r))) + <+> (shrink_expr r >>= fun r -> return (AST.Add (l, r))) +;; + +let arbitrary_expr = + (* let open QCheck.Iter in *) + QCheck.make AST.gen ~print:(Format.asprintf "%a" PP.pp) ~shrink:shrink_expr +;; + +let _ = + QCheck_runner.run_tests + [ QCheck.( + Test.make arbitrary_expr (fun l -> + match + Angstrom.parse_string + ~consume:Angstrom.Consume.All + Parser.expr + (Format.asprintf "%a" PP.pp l) + with + | Result.Ok after when after = l -> true + | Result.Ok after -> + Format.printf "before : %a\n%!" AST.pp l; + (* Format.printf " : `%a`\n%!" PP.pp l; *) + Format.printf "`%a`\n%!" AST.pp after; + false + | Result.Error _ -> + (* Format.printf "failed on : %a\n%!" Lam.pp l; *) + false)) + ] +;; diff --git a/DOOML/test_qc/test_qc.mli b/DOOML/test_qc/test_qc.mli new file mode 100644 index 00000000..a65c69d1 --- /dev/null +++ b/DOOML/test_qc/test_qc.mli @@ -0,0 +1,7 @@ +[@@@ocaml.text "/*"] + +(** Copyright 2023-2024, Kakadu and contributors *) + +(** SPDX-License-Identifier: LGPL-3.0-or-later *) + +[@@@ocaml.text "/*"]