diff --git a/slarnML/.gitignore b/slarnML/.gitignore new file mode 100644 index 000000000..732fd0fcc --- /dev/null +++ b/slarnML/.gitignore @@ -0,0 +1,9 @@ +.vscode +_build +trash + +*.o +*.out +demo/main.S +test/manytests +test/manytests_ \ No newline at end of file diff --git a/slarnML/.ocamlformat b/slarnML/.ocamlformat new file mode 100644 index 000000000..b0368510d --- /dev/null +++ b/slarnML/.ocamlformat @@ -0,0 +1,3 @@ +profile=janestreet +sequence-style=terminator +max-indent=2 \ No newline at end of file diff --git a/slarnML/Makefile b/slarnML/Makefile new file mode 100644 index 000000000..3c10647e9 --- /dev/null +++ b/slarnML/Makefile @@ -0,0 +1,23 @@ +.PHONY: repl tests test fmt lint celan + +all: + dune build + +repl: + dune build ./slarn.exe && rlwrap _build/default/slarn.exe + +test: + dune runtest + +clean: + @$(RM) -r _build + +fmt: + dune build @fmt --auto-promote + +lint: + dune build @lint --force + +release: + dune build --profile=release + dune runtest --profile=release diff --git a/slarnML/demo/.gdb_history b/slarnML/demo/.gdb_history new file mode 100644 index 000000000..8460b87e4 --- /dev/null +++ b/slarnML/demo/.gdb_history @@ -0,0 +1,85 @@ +b _start +c +ni +ni +ni +ni +ni +exit +c +b main +c +b fac +c +b fac_fack +b fack_fack +b fack_fac +c +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +exit +b fac_fack +b fack_fac +c +c +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +ni +exit diff --git a/slarnML/demo/.gdbinit b/slarnML/demo/.gdbinit new file mode 100644 index 000000000..0942d8c4e --- /dev/null +++ b/slarnML/demo/.gdbinit @@ -0,0 +1,23 @@ +set history save +set architecture riscv:rv64 +set sysroot /usr/riscv64−linux−gnu +target remote :1234 +tui enable +tui new-layout example {-horizontal regs 1 asm 1} 2 status 0 cmd 1 +layout example +# tui disable +focus cmd +b _start +b .breakpoint0 +b .breakpoint1 +b .breakpoint2 +b .breakpoint3 +b .breakpoint4 +b .breakpoint5 +b .breakpoint6 +b .breakpoint7 +b .breakpoint8 +b .breakpoint9 +b print_int +# c +# x/8xg $sp \ No newline at end of file diff --git a/slarnML/demo/demo.ml b/slarnML/demo/demo.ml new file mode 100644 index 000000000..ca6288235 --- /dev/null +++ b/slarnML/demo/demo.ml @@ -0,0 +1,23 @@ +open SlarnML_lib.Res + +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + let result = + match SlarnML_lib.Parser.parser s with + | Ok ast -> + SlarnML_lib.Clos_conv.clos_conv ast + >>= (fun ast -> SlarnML_lib.Lambda_lifting.lambda_lifting ast) + >>= fun ast -> + Result (SlarnML_lib.Anf_conv.anf ast) + >>= (fun anf -> SlarnML_lib.Riscv.asm anf) + >>= fun prog -> + Result + (String.concat + "\n" + (List.map (SlarnML_lib.Pprint_riscv.pp_instruction "\t") prog)) + | Error message -> SlarnML_lib.Res.Error message + in + match result with + | SlarnML_lib.Res.Result r -> print_string @@ r + | Error e -> Printf.eprintf "%s" e +;; diff --git a/slarnML/demo/dune b/slarnML/demo/dune new file mode 100644 index 000000000..6eba9e38c --- /dev/null +++ b/slarnML/demo/dune @@ -0,0 +1,72 @@ +;(rule +; (targets part_app.o) +; (deps ../lib/riscv64/part_app.c) +; (mode +; (promote (until-clean))) +; (action +; (run +; riscv64-linux-gnu-gcc +; -march=rv64gc +; -O2 +; -nostdlib +; -nostartfiles +; -ffreestanding +; -c +; %{deps} +; -o +; %{targets})) +; (enabled_if +; (= %{profile} demo))) +; +;(rule +; (targets main.S) +; (deps +; demo.ml +; main.ml) +; (mode +; (promote (until-clean))) +; (action +; (run dune exec demo < main.ml)) +; (enabled_if +; (= %{profile} demo))) +; +;(rule +; (targets main.o) +; (deps main.S) +; (mode +; (promote (until-clean))) +; (action +; (run riscv64-linux-gnu-as -march=rv64gc %{deps} -o %{targets})) +; (enabled_if +; (= %{profile} demo))) +; +;(rule +; (targets print.o) +; (deps ../lib/riscv64/print.S) +; (mode +; (promote (until-clean))) +; (action +; (run riscv64-linux-gnu-as -march=rv64gc %{deps} -o %{targets})) +; (enabled_if +; (= %{profile} demo))) +; +;(rule +; (targets a.out) +; (deps print.o part_app.o main.o) +; (mode +; (promote (until-clean))) +; (action +; (run riscv64-linux-gnu-ld -lc %{deps} -o %{targets})) +; (enabled_if +; (= %{profile} demo))) +; +;(executable +; (name demo) +; (public_name demo) +; (modules demo) +; (libraries slarnML.lib stdio)) +; +; (cram +; (applies_to riscvDemo) +; (deps ./a.out ./demoRiscv.exe)) +; diff --git a/slarnML/demo/main.ml b/slarnML/demo/main.ml new file mode 100644 index 000000000..b8224c214 --- /dev/null +++ b/slarnML/demo/main.ml @@ -0,0 +1,6 @@ +let fac n = + let rec fack n f = if n <= 1 then f 1 else fack (n - 1) (fun x -> x * f n) in + fack n (fun x -> x) +;; + +let main = print_int (fac 3) diff --git a/slarnML/dune-project b/slarnML/dune-project new file mode 100644 index 000000000..bc6dc6ea5 --- /dev/null +++ b/slarnML/dune-project @@ -0,0 +1,33 @@ +(lang dune 2.9) + +(name slarnML) + +(generate_opam_files true) + +(cram enable) + +(license LGPL-3.0-or-later) + +(source + (github ioannessh/comp24)) + +(authors "Ivan Shurenkov") + +(maintainers "Ivan Shurenkov") + +(package + (name slarnML) + (synopsis "SlarnML") + (version 0.0) + (depends + ocaml + dune + angstrom + base + (ppx_inline_test :with-test) + ppx_expect + ppx_deriving + bisect_ppx + (odoc :with-doc) + (ocamlformat :build))) + diff --git a/slarnML/lib/anf/anf_ast.ml b/slarnML/lib/anf/anf_ast.ml new file mode 100644 index 000000000..05e71d3f4 --- /dev/null +++ b/slarnML/lib/anf/anf_ast.ml @@ -0,0 +1,35 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +type immexpr = + | AId of string + | AInt of int + | ABool of bool + | AUnit +[@@deriving show { with_path = false }] + +type cexpr = + | ANot of immexpr + | AOr of immexpr * immexpr + | AAnd of immexpr * immexpr + | AEq of immexpr * immexpr + | AGt of immexpr * immexpr + | ALt of immexpr * immexpr + | AGte of immexpr * immexpr + | ALte of immexpr * immexpr + | AAdd of immexpr * immexpr + | ASub of immexpr * immexpr + | AMul of immexpr * immexpr + | ADiv of immexpr * immexpr + | CImmExpr of immexpr + | AIf of immexpr * aexpr * aexpr + | AApp of immexpr * immexpr list +[@@deriving show { with_path = false }] + +and aexpr = + | ALet of string * cexpr * aexpr + | ACExpr of cexpr +[@@deriving show { with_path = false }] + +type afun = AFun of string * string list * aexpr [@@deriving show { with_path = false }] diff --git a/slarnML/lib/anf/anf_conv.ml b/slarnML/lib/anf/anf_conv.ml new file mode 100644 index 000000000..0f8146e90 --- /dev/null +++ b/slarnML/lib/anf/anf_conv.ml @@ -0,0 +1,87 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ll_ast +open Anf_ast + +let free = ref 0 + +let next_free _ = + free := !free + 1; + !free +;; + +let clear_free _ = + free := 0; + !free +;; + +let get_name name = + let num = next_free () in + String.concat "" [ name; "#"; string_of_int num ] +;; + +let rec anf_expr e expr_with_hole = + let get_const = function + | Ast.CInt i -> AInt i + | Ast.CBool b -> ABool b + | Ast.CUnit -> AUnit + in + let anf_bin_op f e1 e2 = + anf_expr e1 (fun limm -> + anf_expr e2 (fun rimm -> + let name = get_name "anf_op" in + ALet (name, f limm rimm, expr_with_hole (AId name)))) + in + match e with + | LId id -> expr_with_hole (AId id) + | LConst c -> expr_with_hole (get_const c) + | LNot e -> + anf_expr e (fun imm -> + let name = get_name "anf_not" in + ALet (name, ANot imm, expr_with_hole (AId name))) + | LOr (e1, e2) -> anf_bin_op (fun e1 e2 -> AOr (e1, e2)) e1 e2 + | LAnd (e1, e2) -> anf_bin_op (fun e1 e2 -> AAnd (e1, e2)) e1 e2 + | LEq (e1, e2) -> anf_bin_op (fun e1 e2 -> AEq (e1, e2)) e1 e2 + | LGt (e1, e2) -> anf_bin_op (fun e1 e2 -> AGt (e1, e2)) e1 e2 + | LLt (e1, e2) -> anf_bin_op (fun e1 e2 -> ALt (e1, e2)) e1 e2 + | LGte (e1, e2) -> anf_bin_op (fun e1 e2 -> AGte (e1, e2)) e1 e2 + | LLte (e1, e2) -> anf_bin_op (fun e1 e2 -> ALte (e1, e2)) e1 e2 + | LAdd (e1, e2) -> anf_bin_op (fun e1 e2 -> AAdd (e1, e2)) e1 e2 + | LSub (e1, e2) -> anf_bin_op (fun e1 e2 -> ASub (e1, e2)) e1 e2 + | LMul (e1, e2) -> anf_bin_op (fun e1 e2 -> AMul (e1, e2)) e1 e2 + | LDiv (e1, e2) -> anf_bin_op (fun e1 e2 -> ADiv (e1, e2)) e1 e2 + | LIf (e1, e2, e3) -> + anf_expr e1 (fun cimm -> + let name = get_name "anf_if" in + let t_anf = anf_expr e2 (fun imm -> ACExpr (CImmExpr imm)) in + let f_anf = anf_expr e3 (fun imm -> ACExpr (CImmExpr imm)) in + ALet (name, AIf (cimm, t_anf, f_anf), expr_with_hole (AId name))) + | LApp (id, arg :: args) -> + let args = List.rev args in + anf_expr arg (fun imm_arg -> + (List.fold_left + (fun f a lst imm0 -> anf_expr a (fun imm1 -> f (imm0 :: lst) imm1)) + (fun lst imm -> + let name = get_name "anf_app" in + ALet (name, AApp (AId id, List.rev (imm :: lst)), expr_with_hole (AId name))) + args) + [] + imm_arg) + | LApp (id, []) -> + let name = get_name "anf_app" in + ALet (name, AApp (AId id, []), expr_with_hole (AId name)) + | LIn (id, e1, e2) -> + anf_expr e1 (fun limm -> + let name = "anf_" ^ get_name id in + ALet (name, AApp (limm, []), anf_expr e2 expr_with_hole)) +;; + +(* | LApp (id, []) -> expr_with_hole (AId id) *) + +let anf_fun = function + | LFun (id, args, e) -> AFun (id, args, anf_expr e (fun imm -> ACExpr (CImmExpr imm))) +;; + +let anf = List.map anf_fun diff --git a/slarnML/lib/anf/anf_conv.mli b/slarnML/lib/anf/anf_conv.mli new file mode 100644 index 000000000..8e5bc6a4f --- /dev/null +++ b/slarnML/lib/anf/anf_conv.mli @@ -0,0 +1,5 @@ +open Ll_ast +open Anf_ast + +val anf : gl_expr list -> afun list +val clear_free : 'a -> int diff --git a/slarnML/lib/anf/cc_ast.ml b/slarnML/lib/anf/cc_ast.ml new file mode 100644 index 000000000..ac502e392 --- /dev/null +++ b/slarnML/lib/anf/cc_ast.ml @@ -0,0 +1,29 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ast + +type c_expr = + | CId of string + | CConst of const + | CNot of c_expr + | COr of c_expr * c_expr + | CAnd of c_expr * c_expr + | CEq of c_expr * c_expr + | CGt of c_expr * c_expr + | CLt of c_expr * c_expr + | CGte of c_expr * c_expr + | CLte of c_expr * c_expr + | CAdd of c_expr * c_expr + | CSub of c_expr * c_expr + | CMul of c_expr * c_expr + | CDiv of c_expr * c_expr + | CIf of c_expr * c_expr * c_expr + | CLet of decl * c_expr + | CLetIn of decl * c_expr * c_expr + | CFun of args * c_expr (* anon fun *) + | CApp of c_expr * c_expr list +[@@deriving show { with_path = false }] + +type cc_ast = c_expr list [@@deriving show { with_path = false }] diff --git a/slarnML/lib/anf/clos_conv.ml b/slarnML/lib/anf/clos_conv.ml new file mode 100644 index 000000000..4452de65c --- /dev/null +++ b/slarnML/lib/anf/clos_conv.ml @@ -0,0 +1,232 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ast +open Cc_ast +open Res + +let get_ast = map (fun (ast, _, _, _, _) -> Result ast) + +let get_cc_args lvl = + map (fun (_, _, p_args, _, _) -> + let cc_args = + List.map (fun (a, _) -> a) (List.filter (fun (_, l) -> l <= lvl) p_args) + in + Result cc_args) +;; + +let get_app_args a_id res = + match res with + | Error _ -> [] + | Result (_, _, _, args, _) -> + (match a_id with + | CId id -> + (match List.find_opt (fun (i, _, _) -> i = id) args with + | None -> [] + | Some (_, args, _) -> List.map (fun a -> CId a) args) + | _ -> []) +;; + +let update_ast f = + map (fun (ast, args, p_args, app_args, funs) -> + Result (f ast, args, p_args, app_args, funs)) +;; + +let update_args c_args lvl = + map (fun (ast, args, p_args, app_args, funs) -> + Result + (ast, List.append (List.map (fun a -> a, lvl) c_args) args, p_args, app_args, funs)) +;; + +let update_app id i_args lvl = + map (fun (ast, args, p_args, app_args, funs) -> + Result (ast, args, p_args, (id, i_args, lvl) :: app_args, funs)) +;; + +let update_func f = + map (fun (ast, args, p_args, app_args, funs) -> + Result (ast, args, p_args, app_args, f funs)) +;; + +let filter lvl = + map (fun (ast, args, p_args, app_args, funs) -> + Result + ( ast + , List.filter (fun (_, l) -> lvl >= l) args + , List.filter (fun (_, l) -> lvl > l) p_args + , List.filter (fun (_, _, l) -> lvl >= l) app_args + , funs )) +;; + +let simplify_id id lvl f = + map (fun (ast, args, p_args, app_args, funs) -> + match List.find_opt (fun (a, _) -> a = id) args with + | None -> + (match List.find_opt (fun a -> a = id) funs with + | Some _ -> Result (f ast, args, p_args, app_args, funs) + | None -> Error (String.concat "" [ id; " not exist" ])) + | Some (_, l) -> + if l = lvl + then Result (f ast, args, p_args, app_args, funs) + else ( + match List.find_opt (fun (a, _) -> a = id) p_args with + | None -> Result (f ast, args, List.append p_args [ id, l ], app_args, funs) + | _ -> Result (f ast, args, p_args, app_args, funs))) +;; + +let rec simplify ast lvl f res = + let f_id _ a = a in + let simplify_bin_op f e1 e2 res = + res + |> simplify e1 lvl f_id + |> fun res1 -> + res1 + |> get_ast + >>= fun a1 -> res1 |> simplify e2 lvl f_id |> update_ast (fun a2 -> f a1 a2) + in + match ast with + | Id id -> res |> simplify_id id lvl (fun _ -> (f res) (CId id)) + | Const c -> res |> update_ast (fun _ -> CConst c) + | Not e -> res |> simplify e lvl f_id |> update_ast (fun e -> CNot e) + | Or (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> COr (e1, e2)) e1 e2 + | And (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CAnd (e1, e2)) e1 e2 + | Eq (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CEq (e1, e2)) e1 e2 + | Gt (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CGt (e1, e2)) e1 e2 + | Lt (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CLt (e1, e2)) e1 e2 + | Gte (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CGte (e1, e2)) e1 e2 + | Lte (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CLte (e1, e2)) e1 e2 + | Add (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CAdd (e1, e2)) e1 e2 + | Sub (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CSub (e1, e2)) e1 e2 + | Mul (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CMul (e1, e2)) e1 e2 + | Div (e1, e2) -> res |> simplify_bin_op (fun e1 e2 -> CDiv (e1, e2)) e1 e2 + | If (e1, e2, e3) -> + res + |> simplify e1 lvl f_id + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + r1 + |> simplify e2 lvl f_id + |> fun r2 -> + r2 + |> get_ast + >>= fun a2 -> r2 |> simplify e3 lvl f_id |> update_ast (fun a3 -> CIf (a1, a2, a3)) + | Let (d, e) -> + let id, args, env, dec = + match d with + | Decl (id, args) -> id, args, args, fun id args -> Decl (id, args) + | DeclRec (id, args) -> id, args, id :: args, fun id args -> DeclRec (id, args) + in + let res = + match d with + | DeclRec (id, _) -> res |> update_func (fun f -> id :: f) + | Decl _ -> res + in + res + |> update_args env (lvl + 1) + |> simplify e (lvl + 1) f_id + |> get_cc_args lvl + >>= fun new_args -> + res + |> update_app id new_args lvl + |> update_args env (lvl + 1) + |> simplify e (lvl + 1) f_id + |> filter lvl + |> update_ast (fun a -> + if id = "()" + then CLet (dec id args, a) + else CLet (dec id (List.append new_args args), a)) + |> update_args [ id ] lvl + | LetIn (d, e1, e2) -> + let id, args, env, dec = + match d with + | Decl (id, args) -> id, args, args, fun id args -> Decl (id, args) + | DeclRec (id, args) -> id, args, id :: args, fun id args -> DeclRec (id, args) + in + let res = + match d with + | DeclRec (id, _) -> res |> update_func (fun f -> id :: f) + | Decl _ -> res + in + res + |> update_args env (lvl + 1) + |> simplify e1 (lvl + 1) f_id + |> get_cc_args lvl + >>= fun new_args -> + res + |> update_app id new_args lvl + |> update_args env (lvl + 1) + |> simplify e1 (lvl + 1) f_id + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + r1 + |> filter lvl + |> update_args [ id ] lvl + |> simplify e2 lvl f_id + |> update_ast (fun a2 -> + if id = "()" + then CLetIn (dec id args, a1, a2) + else CLetIn (dec id (List.append new_args args), a1, a2)) + | Fun (a, e) -> + (match a with + | [] -> Error "Fun hasn't args" + | args -> + res + |> update_args args (lvl + 1) + |> simplify e (lvl + 1) f_id + |> fun r -> + r + |> get_cc_args lvl + >>= fun new_args -> + r + |> filter lvl + |> update_ast (fun a -> + CApp (CFun (List.append new_args args, a), List.map (fun a -> CId a) new_args))) + | App (func, args) -> + List.fold_left + (fun prev e -> + prev + >>= fun (ap, r) -> + Result r + |> simplify e lvl f_id + >>= fun r -> Result r |> get_ast >>= fun a -> Result (a :: ap, r)) + (res >>= fun r -> Result ([], r)) + args + >>= fun (r_args, res) -> + let args = List.rev r_args in + Result res + |> simplify func lvl (fun r a -> CApp (a, get_app_args a r)) + |> update_ast (fun a -> CApp (a, args)) +;; + +let default_res = Result (CId "Error", [], [], [], []) + +let get_func ast = + match ast with + | CLet (Decl (id, _), _) -> [ id ] + | CLetIn (Decl (id, _), _, _) -> [ id ] + | CLet (DeclRec (id, _), _) -> [ id ] + | CLetIn (DeclRec (id, _), _, _) -> [ id ] + | _ -> [] +;; + +let default_fun = List.map (fun (id, _) -> id) Call_define.default_func + +let clos_conv ast = + List.fold_left + (fun cc_ast ast -> + cc_ast + >>= fun (cc_ast, funs) -> + default_res + |> update_func (fun _ -> funs) + |> simplify ast 0 (fun _ a -> a) + |> get_ast + >>= fun ast -> Result (cc_ast @ [ ast ], get_func ast @ funs)) + (Result ([], default_fun)) + ast + >>= fun (ast, _) -> Result ast +;; diff --git a/slarnML/lib/anf/clos_conv.mli b/slarnML/lib/anf/clos_conv.mli new file mode 100644 index 000000000..458299049 --- /dev/null +++ b/slarnML/lib/anf/clos_conv.mli @@ -0,0 +1,5 @@ +open Ast +open Cc_ast +open Res + +val clos_conv : expr list -> c_expr list res diff --git a/slarnML/lib/anf/lambda_lifting.ml b/slarnML/lib/anf/lambda_lifting.ml new file mode 100644 index 000000000..479aed538 --- /dev/null +++ b/slarnML/lib/anf/lambda_lifting.ml @@ -0,0 +1,182 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ll_ast +open Cc_ast +open Res + +let new_anon = map (fun (ast, prog, env, num) -> Result (ast, prog, env, num + 1)) + +let get_anon_name = + map (fun (_, _, _, num) -> Result (String.concat "$" [ "anon"; string_of_int num ])) +;; + +let get_name id _ = id +(* String.concat "#" (id :: stack) *) + +let find_name id = + map (fun (_, _, env, _) -> + match List.find_opt (fun (_, name, _) -> name = id) env with + | None -> + Result (LApp (id, [])) + (* Error (String.concat "" ["Not found new name '"; id; "'\n"]) *) + | Some (_, _, new_name) -> Result (LId new_name)) +;; + +let insert_let a = map (fun (ast, lst, env, num) -> Result (ast, a :: lst, env, num)) + +let update_env name new_name lvl = + map (fun (ast, prog, env, num) -> Result (ast, prog, (lvl, name, new_name) :: env, num)) +;; + +let update_env_fun name stack lvl = update_env name (get_name name stack) lvl +let update_env_arg name lvl = update_env name name lvl +let get_ast = map (fun (ast, _, _, _) -> Result ast) +let get_prog = map (fun (_, prog, _, _) -> Result prog) + +let update_ast f = + map (fun (ast, prog, env, num) -> + f ast >>= fun new_ast -> Result (new_ast, prog, env, num)) +;; + +let filter lvl = + map (fun (ast, prog, env, num) -> + Result (ast, prog, List.filter (fun (l, _, _) -> l < lvl) env, num)) +;; + +let rec lifting cc_ast stack lvl res = + let lifting_bin_op f e1 e2 = + res + |> lifting e1 stack lvl + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> r1 |> lifting e2 stack lvl |> update_ast (fun a2 -> Result (f a1 a2)) + in + let get_id = function + | Ast.Decl (id, _) | Ast.DeclRec (id, _) -> id + in + let get_args = function + | Ast.Decl (_, args) | Ast.DeclRec (_, args) -> args + in + let get_fun_let d e = LFun (get_id d, get_args d, e) in + let get_decl = function + | Ast.Decl (id, args) -> Ast.Decl (get_name id stack, args) + | Ast.DeclRec (id, args) -> Ast.DeclRec (get_name id stack, args) + in + let update_env_decl args res = + List.fold_left (fun r a -> r |> update_env_arg a lvl) res args + in + let init_func d e1 res = + let id = get_id d in + let f1, f2 = + match d with + | Ast.Decl _ -> (fun x -> x), update_env_decl (get_args d) + | Ast.DeclRec _ -> update_env_decl (get_args d), fun x -> x + in + res |> f1 |> update_env_fun id stack lvl |> lifting e1 (id :: stack) (lvl + 1) |> f2 + in + match cc_ast with + | CId id -> res |> find_name id >>= fun ast -> update_ast (fun _ -> Result ast) res + | CConst c -> update_ast (fun _ -> Result (LConst c)) res + | CNot e -> res |> lifting e stack lvl + | COr (e1, e2) -> lifting_bin_op (fun a1 a2 -> LOr (a1, a2)) e1 e2 + | CAnd (e1, e2) -> lifting_bin_op (fun a1 a2 -> LAnd (a1, a2)) e1 e2 + | CEq (e1, e2) -> lifting_bin_op (fun a1 a2 -> LEq (a1, a2)) e1 e2 + | CGt (e1, e2) -> lifting_bin_op (fun a1 a2 -> LGt (a1, a2)) e1 e2 + | CLt (e1, e2) -> lifting_bin_op (fun a1 a2 -> LLt (a1, a2)) e1 e2 + | CGte (e1, e2) -> lifting_bin_op (fun a1 a2 -> LGte (a1, a2)) e1 e2 + | CLte (e1, e2) -> lifting_bin_op (fun a1 a2 -> LLte (a1, a2)) e1 e2 + | CAdd (e1, e2) -> lifting_bin_op (fun a1 a2 -> LAdd (a1, a2)) e1 e2 + | CSub (e1, e2) -> lifting_bin_op (fun a1 a2 -> LSub (a1, a2)) e1 e2 + | CMul (e1, e2) -> lifting_bin_op (fun a1 a2 -> LMul (a1, a2)) e1 e2 + | CDiv (e1, e2) -> lifting_bin_op (fun a1 a2 -> LDiv (a1, a2)) e1 e2 + | CIf (e1, e2, e3) -> + res + |> lifting e1 stack lvl + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + r1 + |> lifting e2 stack lvl + |> fun r2 -> + r2 + |> get_ast + >>= fun a2 -> + r2 |> lifting e3 stack lvl |> update_ast (fun a3 -> Result (LIf (a1, a2, a3))) + | CLet (d, e) -> + (* let id = get_id d in *) + res + |> init_func d e + |> fun r1 -> + r1 |> get_ast >>= fun a -> r1 |> insert_let (get_fun_let (get_decl d) a) |> filter lvl + | CLetIn (d, e1, e2) -> + let id = get_id d in + res + |> init_func d e1 + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + (if id = "()" then r1 else r1 |> insert_let (get_fun_let (get_decl d) a1)) + |> lifting e2 stack lvl + |> update_ast (fun a2 -> + Result (LIn ((if id = "()" then id else get_name id stack), a1, a2))) + |> filter lvl + | CFun (args, e) -> + res + |> new_anon + |> update_env_decl args + |> fun res -> + res + |> get_anon_name + >>= fun name -> + let new_name = get_name name stack in + res + |> lifting e (name :: stack) (lvl + 1) + |> fun r -> + r + |> get_ast + >>= (fun a -> r |> insert_let (get_fun_let (Ast.Decl (new_name, args)) a)) + |> update_ast (fun _ -> Result (LId new_name)) + | CApp (e, args) -> + List.fold_left + (fun r e -> + r + >>= fun (r, lst) -> + Result r + |> lifting e stack lvl + >>= fun res -> Result res |> get_ast >>= fun a -> Result (res, a :: lst)) + (res >>= fun r -> Result (r, [])) + args + >>= fun (r, args) -> + let args = + List.map + (fun a -> + match a with + | LId id -> LApp (id, []) + | e -> e) + (List.rev args) + in + Result r + |> lifting e stack lvl + |> update_ast (fun a -> + match a with + | LApp (a, new_args) -> Result (LApp (a, List.append new_args args)) + | LId a -> Result (LApp (a, args)) + | _ -> Error "Apply on not correct expr") +;; + +let default_res = Result (LId "Error", [], [], 0) + +let lambda_lifting cc_ast = + List.fold_left + (fun ll_ast ast -> + ll_ast + >>= fun ll_ast -> + lifting ast [] 0 default_res |> get_prog >>= fun p -> Result (ll_ast @ List.rev p)) + (Result []) + cc_ast +;; diff --git a/slarnML/lib/anf/lambda_lifting.mli b/slarnML/lib/anf/lambda_lifting.mli new file mode 100644 index 000000000..3b0575dce --- /dev/null +++ b/slarnML/lib/anf/lambda_lifting.mli @@ -0,0 +1,5 @@ +open Cc_ast +open Ll_ast +open Res + +val lambda_lifting : c_expr list -> gl_expr list res diff --git a/slarnML/lib/anf/ll_ast.ml b/slarnML/lib/anf/ll_ast.ml new file mode 100644 index 000000000..15f4d1b34 --- /dev/null +++ b/slarnML/lib/anf/ll_ast.ml @@ -0,0 +1,26 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +type l_expr = + | LId of string + | LConst of Ast.const + | LNot of l_expr + | LOr of l_expr * l_expr + | LAnd of l_expr * l_expr + | LEq of l_expr * l_expr + | LGt of l_expr * l_expr + | LLt of l_expr * l_expr + | LGte of l_expr * l_expr + | LLte of l_expr * l_expr + | LAdd of l_expr * l_expr + | LSub of l_expr * l_expr + | LMul of l_expr * l_expr + | LDiv of l_expr * l_expr + | LIf of l_expr * l_expr * l_expr + | LApp of string * l_expr list + | LIn of string * l_expr * l_expr +[@@deriving show { with_path = false }] + +type gl_expr = LFun of string * string list * l_expr (* declare function *) +type ll_ast = gl_expr list [@@deriving show { with_path = false }] diff --git a/slarnML/lib/dune b/slarnML/lib/dune new file mode 100644 index 000000000..9a368a203 --- /dev/null +++ b/slarnML/lib/dune @@ -0,0 +1,34 @@ +(library + (name slarnML_lib) + (public_name slarnML.lib) + (instrumentation + (backend bisect_ppx)) + (modules + Res + Pprint_ast + Pprint_cc + Pprint_ll + Pprint_anf + Pprint_riscv + Ast + Parser + Typedtree + Quick_check ; Inferencer + Cc_ast + Clos_conv + Ll_ast + Lambda_lifting + Anf_ast + Anf_conv + ; Anf_test + Riscv_ast + Call_define + Riscv + Pprint + Quick_check_ast) + (libraries base angstrom) ; llvm) + (preprocess + (pps ppx_expect ppx_inline_test)) + (inline_tests)) + +(include_subdirs unqualified) diff --git a/slarnML/lib/inferencer/quick_check.ml b/slarnML/lib/inferencer/quick_check.ml new file mode 100644 index 000000000..d3f4899ae --- /dev/null +++ b/slarnML/lib/inferencer/quick_check.ml @@ -0,0 +1,254 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ast +open Quick_check_ast + +let fresh_id = + let counter = ref 0 in + fun () -> + incr counter; + !counter +;; + +let fresh_var level = TVar (ref (Unbound (fresh_id (), level))) + +let rec deref = function + | TVar { contents = Link t } -> deref t + | t -> t +;; + +let rec string_of_ty t = + let t = deref t in + match t with + | TVar { contents = Unbound (id, _) } -> "'" ^ string_of_int id + | TVar { contents = Link t } -> string_of_ty t + | TInt -> "int" + | TBool -> "bool" + | TUnit -> "unit" + | TFun (a, r) -> Printf.sprintf "(%s -> %s)" (string_of_ty a) (string_of_ty r) +;; + +let rec unify t1 t2 = + let t1 = deref t1 in + let t2 = deref t2 in + match t1, t2 with + | ( TVar ({ contents = Unbound (_, l1) } as v1) + , TVar ({ contents = Unbound (_, l2) } as v2) ) -> + if v1 == v2 then () else if l1 < l2 then v2 := Link t1 else v1 := Link t2 + | TVar ({ contents = Unbound _ } as v), t | t, TVar ({ contents = Unbound _ } as v) -> + if occurs_check v t then failwith "Occurs check failed" else v := Link t + | TInt, TInt | TBool, TBool | TUnit, TUnit -> () + | TFun (a, b), TFun (c, d) -> + unify a c; + unify b d + | _ -> + failwith + (Printf.sprintf "Type mismatch: %s vs %s" (string_of_ty t1) (string_of_ty t2)) + +and occurs_check v t = + let rec check = function + | TVar v' when v == v' -> true + | TFun (a, r) -> check a || check r + | _ -> false + in + check (deref t) +;; + +let const_check = function + | CInt _ -> TInt + | CBool _ -> TBool + | CUnit -> TUnit +;; + +let type_check init_ctx expr = + let get_decl_name = function + | Decl (name, _) | DeclRec (name, _) -> name + in + let get_decl_args = function + | Decl (_, args) | DeclRec (_, args) -> args + in + let new_ctx ctx t = function + | Decl _ -> ctx + | DeclRec (x, _) -> (x, t) :: ctx + in + (* let next_level_f d = if (List.length (get_decl_args d))=0 then (fun x->x) else (fun x->x+0) in *) + let last_arg args = + match List.rev args with + | [] -> failwith (Printf.sprintf "Args can't be empty") + | arg :: tail -> arg, List.rev tail + in + let rec check ?(get_level = fun x -> x) ctx level expr = + match expr with + | Const c -> const_check c, ctx + | Id x -> + let t = List.assoc_opt x ctx in + (match t with + | None -> failwith (Printf.sprintf "Variable '%s' not found in context" x) + | Some t -> instantiate (get_level level) t, ctx) + | Fun ([], body) -> + let t, _ = check ctx level body in + t, ctx + | Fun (arg :: tail, body) -> + let arg_t = fresh_var level in + let body_t, ctx = check ((arg, arg_t) :: ctx) level (Fun (tail, body)) in + TFun (arg_t, body_t), ctx + | App (f, []) -> check ctx level f + | App (f, args) -> + let arg, tail = last_arg args in + let f_t, _ = check ctx level (App (f, tail)) in + let arg_t, _ = check ctx level arg in + (* print_endline ((string_of_ty f_t)^" "^(string_of_ty arg_t)); *) + let res_t = fresh_var level in + unify f_t (TFun (arg_t, res_t)); + res_t, ctx + | LetIn (d, e1, e2) -> + let x = get_decl_name d in + let exp_t = fresh_var (level + 1) in + let e1_t, _ = check (new_ctx ctx exp_t d) (level + 1) (Fun (get_decl_args d, e1)) in + unify exp_t e1_t; + let generalized = generalize ctx (level + 1) e1_t in + let ctx = (x, generalized) :: ctx in + let t, _ = check ctx level e2 in + t, ctx + | Let (d, e) -> + let x = get_decl_name d in + let exp_t = fresh_var (level + 1) in + let e_t, _ = check (new_ctx ctx exp_t d) (level + 1) (Fun (get_decl_args d, e)) in + unify exp_t e_t; + let generalized = generalize ctx (level + 1) e_t in + generalized, (x, generalized) :: ctx + | Not e -> check ctx level e + | Or (e1, e2) + | And (e1, e2) + | Eq (e1, e2) + | Lt (e1, e2) + | Gt (e1, e2) + | Gte (e1, e2) + | Lte (e1, e2) -> + let e1_t, _ = check ctx level e1 in + let e2_t, _ = check ctx level e2 in + unify e1_t e2_t; + TBool, ctx + | Add (e1, e2) | Sub (e1, e2) | Mul (e1, e2) | Div (e1, e2) -> + let e1_t, _ = check ctx level e1 in + let e2_t, _ = check ctx level e2 in + unify e1_t e2_t; + e2_t, ctx + | If (e1, e2, e3) -> + let e1_t, _ = check ctx level e1 in + let e2_t, _ = check ctx level e2 in + let e3_t, _ = check ctx level e3 in + unify e1_t TBool; + unify e2_t e3_t; + e2_t, ctx + and generalize _ level t = + let t = deref t in + let vars = ref [] in + let rec collect = function + | TVar { contents = Unbound (id, l) } when l > level && not (List.memq id !vars) -> + vars := id :: !vars + | TFun (a, r) -> + collect a; + collect r + | _ -> () + in + collect t; + List.fold_right (fun v acc -> TFun (TVar (ref (Unbound (v, level))), acc)) !vars t + and instantiate level t = + let t = deref t in + match t with + | TFun (a, r) -> + TFun (instantiate level a, instantiate level r) + (* | TVar({contents = Unbound(_, l)}) when l <= level -> *) + (* print_endline ((string_of_int level)^" "^(string_of_int level)); *) + (* fresh_var level *) + | t -> t + in + let t, ctx = check init_ctx 0 expr in + let rec finalize = function + | TVar { contents = Link t } -> finalize t + | TVar c -> TVar c + (* | TVar({contents = Unbound(_, _)}) -> TUnit *) + | TFun (a, r) -> TFun (finalize a, finalize r) + | t -> t + in + finalize t, ctx +;; + +open Res + +let type_check_res ctx ast = + try + let t, ctx = type_check ctx ast in + Result ((ast, t), ctx) + with + | Failure msg -> Error msg +;; + +let quick_check ast_lst = + List.fold_left + (fun res ast -> + res + >>= fun (types, ctx) -> + type_check_res ctx ast >>= fun (t, ctx) -> Result (types @ [ t ], ctx)) + (Result ([], [])) + ast_lst + >>= fun (lst, _) -> Result lst +;; + +(* let () = + let ast = + [ Let + ( Decl ("fac", [ "n" ]) + , LetIn + ( DeclRec ("help", [ "acc"; "n" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , Id "acc" + , App (Id "help", [ Sub (Id "n", Const (CInt 1)); Mul (Id "n", Id "acc") ]) + ) + , App (Id "help", [ Const (CInt 1); Id "n" ]) ) ) + ; Let + ( Decl ("fac2", [ "n" ]) + , LetIn + ( DeclRec ("help2", [ "n"; "f" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , App (Id "f", [ Const (CInt 1) ]) + , App + ( Id "help2" + , [ Sub (Id "n", Const (CInt 1)) + ; Fun ([ "x" ], Mul (App (Id "f", [ Id "n" ]), Id "x")) + ] ) ) + , App (Id "help2", [ Id "n"; Fun ([ "x" ], Id "x") ]) ) ) + (* Let(Decl("f",[]),LetIn(Decl("g", []),Fun(["x"],Id"x"), App(Id"g",[]))); *) + (* Let(Decl("id",["x"]),(Fun(["y"],App(Id"y",[Id"x"])))); *) + (* LetIn(Decl("id_i",[]),(Fun(["y"],Sub(Id"y",Const (CInt 1)))), + LetIn(Decl("_",[]), + App(Id"id_i", [Const (CBool true)]), + App(Id"id_i",[Const (CInt 1)])) + ); *) + (* Let(Decl("id_b",["x"]),Id"x"); *) + (* Let(Decl("f",["i"; "b"; "g"; "h"]), + If(App(Id"h", [Id "b"]), + (Id"i"), + App(Id"g", [Id"i"]) + )); *) + (* App(Id"id_i", [Const CUnit]); *) + (* App(Id"f", [Const(CInt 1);Const(CBool true);Id"id_i";Id"id_b"]) *) + ] + in + match quick_check ast with + | Error e -> print_endline e + | Result list -> + print_endline + (String.concat + "\n" + (List.map + (fun (ast, t) -> Pprint_ast.pp_expr ast ^ "\n[" ^ string_of_ty t ^ "]\n") + list)) + ;; *) + +(* print_endline "\n\n\n" *) diff --git a/slarnML/lib/inferencer/quick_check_ast.ml b/slarnML/lib/inferencer/quick_check_ast.ml new file mode 100644 index 000000000..46de89e28 --- /dev/null +++ b/slarnML/lib/inferencer/quick_check_ast.ml @@ -0,0 +1,16 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +type ty = + | TVar of tv ref + | TInt + | TBool + | TUnit + | TFun of ty * ty + +and tv = + | Unbound of int * int + | Link of ty + +type context = (string * ty) list diff --git a/slarnML/lib/inferencer/typedtree.ml b/slarnML/lib/inferencer/typedtree.ml new file mode 100644 index 000000000..8e8aae544 --- /dev/null +++ b/slarnML/lib/inferencer/typedtree.ml @@ -0,0 +1,31 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +type binder = int [@@deriving show { with_path = false }] + +module VarSet = struct + include Stdlib.Set.Make (Int) +end + +type constTy = + | UnitTy + | IntTy + | BoolTy + +type ty = + | PrimTy of constTy + | VarTy of binder + | ArrowTy of ty list +[@@deriving show { with_path = false }] + +type undefinedType = + | Type of ty + | Key of binder + | Undefined + +open Res + +let boolType = Result (Type (PrimTy BoolTy)) +let uniyType = Result (Type (PrimTy UnitTy)) +let intType = Result (Type (PrimTy IntTy)) diff --git a/slarnML/lib/parser/ast.ml b/slarnML/lib/parser/ast.ml new file mode 100644 index 000000000..41e43cb48 --- /dev/null +++ b/slarnML/lib/parser/ast.ml @@ -0,0 +1,40 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +type const = + | CInt of int + | CBool of bool + | CUnit +[@@deriving show { with_path = false }] + +type args = string list [@@deriving show { with_path = false }] + +type decl = + | DeclRec of string * args + | Decl of string * args +[@@deriving show { with_path = false }] + +type expr = + | Id of string + | Const of const + | Not of expr (* not expr *) + | Or of expr * expr (* expr || expr *) + | And of expr * expr (* expr && expr *) + | Eq of expr * expr (* expr = expr *) + | Gt of expr * expr (* expr > expr *) + | Lt of expr * expr (* expr < expr *) + | Gte of expr * expr (* expr >= expr *) + | Lte of expr * expr (* expr <= expr *) + | Add of expr * expr (* expr + expr *) + | Sub of expr * expr (* expr - expr *) + | Mul of expr * expr (* expr * expr *) + | Div of expr * expr (* expr / expr *) + | If of expr * expr * expr (* if expr then expr else expr *) + | Let of decl * expr (* let id arg1 arg2 = expr *) + | LetIn of decl * expr * expr (* let id arg1 arg2 = expr in expr *) + | Fun of args * expr (* fun arg1 arg2 -> expr *) + | App of expr * expr list +[@@deriving show { with_path = false }] + +type ast = expr list [@@deriving show { with_path = false }] diff --git a/slarnML/lib/parser/parser.ml b/slarnML/lib/parser/parser.ml new file mode 100644 index 000000000..2eaae6ad8 --- /dev/null +++ b/slarnML/lib/parser/parser.ml @@ -0,0 +1,707 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Angstrom +open Ast + +let is_whitespace = function + | ' ' -> true + | _ -> false +;; + +let is_tab = function + | '\t' -> true + | _ -> false +;; + +let is_newline = function + | '\n' | '\r' -> true + | _ -> false +;; + +let is_empty_char c = is_tab c || is_whitespace c || is_newline c + +let is_digit = function + | '0' .. '9' -> true + | _ -> false +;; + +let is_letter = function + | 'a' .. 'z' | 'A' .. 'Z' -> true + | _ -> false +;; + +let is_keyword = function + | "fun" | "let" | "in" | "if" | "then" | "else" | "true" | "false" | "not" | "rec" -> + true + | _ -> false +;; + +let skip_empty = skip_while is_empty_char +let take_empty1 = take_while1 is_empty_char +let parens p = char '(' *> p <* char ')' + +let integer = + let minus = skip_empty *> string "-" *> return (-1) in + (* let plus = skip_empty *> (string "+" <|> string "") *> return 1 in *) + let number sign = + skip_empty *> take_while1 is_digit + >>= fun num -> return (CInt (sign * int_of_string num)) + in + (* (minus <|> plus) >>= number *) + number 1 <|> skip_empty *> parens (minus >>= number <* skip_empty) +;; + +let boolean1 = + let true_w = take_empty1 *> string "true" *> return (CBool true) in + let false_w = take_empty1 *> string "false" *> return (CBool false) in + true_w <|> false_w +;; + +let boolean = + let true_w = skip_empty *> string "true" *> return (CBool true) in + let false_w = skip_empty *> string "false" *> return (CBool false) in + true_w <|> false_w +;; + +let unit_c = parens @@ (string "" *> return CUnit) + +let identifier = + let word = + skip_empty *> take_while1 (fun c -> Char.equal c '_' || is_digit c || is_letter c) + in + let checker word = + if is_digit (String.get word 0) || is_keyword word + then fail "Not correct identifier" + else return word + in + word >>= checker +;; + +let tuple el = + skip_empty + *> parens + (lift2 + (fun lst el -> List.concat [ lst; [ el ] ]) + (many (el <* skip_empty <* char ',')) + (el <* skip_empty)) +;; + +let arguments = tuple identifier <|> many identifier +let arguments1 = tuple identifier <|> many1 identifier + +let declaration is_rec = + skip_empty *> identifier + >>= fun id -> + skip_empty *> arguments + >>= fun arg_lst -> + if is_rec then return (DeclRec (id, arg_lst)) else return (Decl (id, arg_lst)) +;; + +let add = skip_empty *> char '+' *> return (fun e1 e2 -> Add (e1, e2)) +let sub = skip_empty *> char '-' *> return (fun e1 e2 -> Sub (e1, e2)) +let mul = skip_empty *> char '*' *> return (fun e1 e2 -> Mul (e1, e2)) +let div = skip_empty *> char '/' *> return (fun e1 e2 -> Div (e1, e2)) +let and_o = skip_empty *> string "&&" *> return (fun e1 e2 -> And (e1, e2)) +let or_o = skip_empty *> string "||" *> return (fun e1 e2 -> Or (e1, e2)) + +let not_op = + let is_parens = + peek_char_fail + >>= function + | '(' -> return "" + | _ -> take_empty1 + in + let not_o = (skip_empty *> string "not" <* is_parens) *> return (fun e -> Not e) in + let empty_o = skip_empty *> return (fun e -> e) in + not_o <|> empty_o +;; + +let compare_op = + let gt = skip_empty *> string ">" *> return (fun e1 e2 -> Gt (e1, e2)) in + let lt = skip_empty *> string "<" *> return (fun e1 e2 -> Lt (e1, e2)) in + let gte = skip_empty *> string ">=" *> return (fun e1 e2 -> Gte (e1, e2)) in + let lte = skip_empty *> string "<=" *> return (fun e1 e2 -> Lte (e1, e2)) in + let eq = skip_empty *> string "=" *> return (fun e1 e2 -> Eq (e1, e2)) in + let neq = + skip_empty *> (string "<>" <|> string "!=") *> return (fun e1 e2 -> Not (Eq (e1, e2))) + in + eq <|> neq <|> gte <|> lte <|> gt <|> lt +;; + +let chainl1 e op = + let rec go acc = lift2 (fun f x -> f acc x) op e >>= go <|> return acc in + e >>= fun init -> go init +;; + +let identifier_expr = identifier >>= fun id -> return @@ Id id + +let parse_math id_f = + fix (fun expr -> + let not_e ex = not_op >>= fun f -> lift f ex in + let integer_e = integer >>= fun c -> return @@ Const c in + let id_e = id_f in + let bool_e = boolean >>= fun b -> return @@ Const b in + let factor = + skip_empty *> parens expr + <|> bool_e + <|> integer_e + <|> parens id_e + <|> identifier_expr + in + let term = not_e factor in + let term = chainl1 term (mul <|> div) in + let term = chainl1 term (add <|> sub) in + let term = chainl1 term compare_op in + let term = chainl1 term and_o in + let term = chainl1 term or_o in + term <* skip_empty) +;; + +let parse_expr = + fix (fun expr -> + let unit_e = unit_c >>= fun c -> return @@ Const c in + let if_ex = + let if_e ex = (skip_empty *> string "if" <* take_empty1) *> ex in + let then_e ex = (skip_empty *> string "then" <* take_empty1) *> ex in + let else_e ex = (skip_empty *> string "else" <* take_empty1) *> ex in + lift3 + (fun i t e -> If (i, t, e)) + (if_e (parens expr <|> expr)) + (then_e (parens expr <|> expr)) + (else_e (parens expr <|> expr) <|> return (Const CUnit)) + in + let let_ex = + let let_d = + (skip_empty *> string "let" <* take_empty1) + *> (declaration false <|> unit_e *> return (Decl ("()", []))) + in + let let_rd = + (skip_empty *> string "let" *> take_empty1 *> string "rec" <* take_empty1) + *> declaration true + in + let eq_e ex = skip_empty *> string "=" *> ex in + lift2 (fun le eq -> Let (le, eq)) (let_rd <|> let_d) (eq_e expr) + in + let let_in_ex = + let let_d = + (skip_empty *> string "let" <* take_empty1) + *> (declaration false <|> unit_e *> return (Decl ("()", []))) + in + let let_rd = + (skip_empty *> string "let" *> take_empty1 *> string "rec" <* take_empty1) + *> declaration true + in + let eq_e ex = skip_empty *> string "=" *> ex in + let in_e ex = (skip_empty *> string "in" <* take_empty1) *> ex in + lift3 (fun le eq i -> LetIn (le, eq, i)) (let_rd <|> let_d) (eq_e expr) (in_e expr) + in + let fun_ex e = + let fun_a = (skip_empty *> string "fun" <* take_empty1) *> arguments1 in + let arrow_e ex = skip_empty *> string "->" *> ex in + lift2 (fun a f -> Fun (a, f)) fun_a (arrow_e e) + in + let integer_e = integer >>= fun c -> return @@ Const c in + let bool_e = boolean >>= fun b -> return @@ Const b in + let app_ex e = + let arg = bool_e <|> integer_e <|> identifier_expr <|> e in + let args_app = many1 @@ (parens @@ (fun_ex e <|> arg) <|> arg) in + let id = skip_empty *> identifier_expr <|> parens @@ fun_ex e in + let args = skip_empty *> args_app in + lift2 (fun id args -> App (id, args)) id args + in + let parse_math2 = + fix (fun m_expr -> + let not_e ex = not_op >>= fun f -> lift f ex in + let factor = + take_empty1 *> m_expr + <|> parens m_expr + <|> app_ex m_expr + <|> bool_e + <|> integer_e + (* <|> parens @@ app_ex m_expr *) + <|> parens @@ fun_ex expr + <|> identifier_expr + in + let term = not_e factor in + let term = chainl1 term (mul <|> div) in + let term = chainl1 term (add <|> sub) in + let term = chainl1 term compare_op in + let term = chainl1 term and_o in + let term = chainl1 term or_o in + term <* skip_empty) + in + take_empty1 *> expr + <|> parens expr + <|> let_in_ex + <|> let_ex + <|> if_ex + <|> parse_math2 + <|> app_ex expr + <|> fun_ex expr + <|> unit_e + <|> identifier_expr + (* <|> (parse_math identifier_expr) *)) +;; + +let parse_exprs = + many (parse_expr <* skip_empty <* (string ";;" <|> string "")) <* skip_empty +;; + +let parser str = parse_string ~consume:Consume.All parse_exprs str + +(*=============================*) +(*============TESTS============*) +(*=============================*) + +let test_ok parser input expected = + match parse_string ~consume:Consume.All parser input with + | Ok res when res = expected -> true + | Ok _ -> + Printf.printf "%s\n" input; + false + | Error e -> + Printf.printf "%s\n" e; + false +;; + +let test_fail parser input = + match parse_string ~consume:Consume.All parser input with + | Ok _ -> + Printf.printf "%s\n" input; + false + | Error _ -> true +;; + +(*== Test parse integer ==*) +let parse_ok = test_ok integer +let parse_fail = test_fail integer +let%test _ = parse_ok " 1" (CInt 1) +let%test _ = parse_ok " (-1234567890)" (CInt (-1234567890)) +let%test _ = parse_ok " 0901" (CInt 901) +let%test _ = parse_ok "( - 0001000 )" (CInt (-1000)) +let%test _ = parse_fail "" +let%test _ = parse_fail "aa" +let%test _ = parse_fail " " + +(*== Test parse boolean ==*) +let parse_ok = test_ok boolean1 +let parse_fail = test_fail boolean1 +let%test _ = parse_ok " true" (CBool true) +let%test _ = parse_ok " false" (CBool false) +let%test _ = parse_fail "1" +let%test _ = parse_fail "aa" +let%test _ = parse_fail " " +let%test _ = parse_fail "" + +(*== Test parse identifier ==*) +let parse_ok = test_ok identifier +let parse_fail = test_fail identifier +let%test _ = parse_ok " _" "_" +let%test _ = parse_ok " a" "a" + +let%test _ = + parse_ok "qwertyuiopasdfghjklzxcvbnm1234567890_" "qwertyuiopasdfghjklzxcvbnm1234567890_" +;; + +let%test _ = parse_ok "true_" "true_" +let%test _ = parse_ok "false_" "false_" +let%test _ = parse_ok "fun_" "fun_" +let%test _ = parse_ok "let_" "let_" +let%test _ = parse_ok "if_" "if_" +let%test _ = parse_ok "then_" "then_" +let%test _ = parse_ok "else_" "else_" +let%test _ = parse_ok "in_" "in_" +let%test _ = parse_ok "not_" "not_" +let%test _ = parse_ok "rec_" "rec_" +let%test _ = parse_fail "1" +let%test _ = parse_fail "1a" +let%test _ = parse_fail "true" +let%test _ = parse_fail "false" +let%test _ = parse_fail "fun" +let%test _ = parse_fail "let" +let%test _ = parse_fail "if" +let%test _ = parse_fail "then" +let%test _ = parse_fail "else" +let%test _ = parse_fail "in" +let%test _ = parse_fail "not" +let%test _ = parse_fail "rec" +let%test _ = parse_fail " " +let%test _ = parse_fail "" + +(*== Test parse tuple ==*) +let common_tuple = + let constant_e = boolean <|> integer <|> unit_c >>= fun c -> return @@ Const c in + let identifier_e = identifier >>= fun id -> return @@ Id id in + let tuple_el = skip_empty *> (constant_e <|> identifier_e) in + tuple tuple_el +;; + +let parse_ok = test_ok common_tuple +let parse_fail = test_fail common_tuple +let%test _ = parse_ok "(())" [ Const CUnit ] +let%test _ = parse_ok "(true)" [ Const (CBool true) ] +let%test _ = parse_ok "(1)" [ Const (CInt 1) ] +let%test _ = parse_ok "(a)" [ Id "a" ] +let%test _ = parse_ok " ( a )" [ Id "a" ] +let%test _ = parse_ok "(a, b)" [ Id "a"; Id "b" ] +let%test _ = parse_ok " ( a , b )" [ Id "a"; Id "b" ] +let%test _ = parse_fail "(a b)" +let%test _ = parse_fail "(a, )" +let%test _ = parse_fail "()" + +(*== Test parse argiments ==*) +(* TODO: arguments can accept Const(CUnit, CInt, CBool) and Id(string) *) + +let parse_ok = test_ok arguments +let parse_fail = test_fail arguments +let%test _ = parse_ok " _" [ "_" ] +let%test _ = parse_ok " _ _" [ "_"; "_" ] +let%test _ = parse_ok "a b" [ "a"; "b" ] +let%test _ = parse_ok "" [] +let%test _ = parse_ok "(a)" [ "a" ] +let%test _ = parse_ok "(a, b)" [ "a"; "b" ] +let%test _ = parse_fail "(a b)" +let%test _ = parse_fail "(a, )" +let%test _ = parse_fail "()" + +(*== Test parse declaration ==*) +let parse_ok flag = test_ok @@ declaration flag +let parse_fail flag = test_fail @@ declaration flag +let%test _ = parse_ok true "_" (DeclRec ("_", [])) +let%test _ = parse_ok false "a" (Decl ("a", [])) +let%test _ = parse_ok true "a b c" (DeclRec ("a", [ "b"; "c" ])) +let%test _ = parse_ok false "a b c" (Decl ("a", [ "b"; "c" ])) +let%test _ = parse_fail true "" +let%test _ = parse_fail false "" + +(*== Test parse math operations ==*) +let parse_ok = test_ok (parse_math identifier_expr) +let parse_fail = test_fail (parse_math identifier_expr) +let%test _ = parse_ok " ( a )" (Id "a") +let%test _ = parse_ok " a" (Id "a") +let%test _ = parse_ok "(a)" (Id "a") +let%test _ = parse_ok " (1)" (Const (CInt 1)) +let%test _ = parse_ok " 1" (Const (CInt 1)) +let%test _ = parse_ok "(1)" (Const (CInt 1)) +let%test _ = parse_ok " a + 2" (Add (Id "a", Const (CInt 2))) +let%test _ = parse_ok " a - 2" (Sub (Id "a", Const (CInt 2))) +let%test _ = parse_ok " a * 2" (Mul (Id "a", Const (CInt 2))) +let%test _ = parse_ok " a / 2" (Div (Id "a", Const (CInt 2))) +let%test _ = parse_ok " not a" (Not (Id "a")) +let%test _ = parse_ok " not (a)" (Not (Id "a")) +let%test _ = parse_ok "not(a)" (Not (Id "a")) +let%test _ = parse_ok " a && b" (And (Id "a", Id "b")) +let%test _ = parse_ok " a || b" (Or (Id "a", Id "b")) +let%test _ = parse_ok " a = b" (Eq (Id "a", Id "b")) +let%test _ = parse_ok " a != b" (Not (Eq (Id "a", Id "b"))) +let%test _ = parse_ok " a <> b" (Not (Eq (Id "a", Id "b"))) +let%test _ = parse_ok " not (a = b)" (Not (Eq (Id "a", Id "b"))) +let%test _ = parse_ok " a > b" (Gt (Id "a", Id "b")) +let%test _ = parse_ok " a >= b" (Gte (Id "a", Id "b")) +let%test _ = parse_ok " a < b" (Lt (Id "a", Id "b")) +let%test _ = parse_ok " a <= b" (Lte (Id "a", Id "b")) +let%test _ = parse_ok "a <= b" (Lte (Id "a", Id "b")) + +(*Test parse math priority*) +let%test _ = parse_ok " a - 2+b" (Add (Sub (Id "a", Const (CInt 2)), Id "b")) +let%test _ = parse_ok " a + 2-b" (Sub (Add (Id "a", Const (CInt 2)), Id "b")) +let%test _ = parse_ok " a + 2*b" (Add (Id "a", Mul (Const (CInt 2), Id "b"))) +let%test _ = parse_ok " a / 2*b" (Mul (Div (Id "a", Const (CInt 2)), Id "b")) +let%test _ = parse_ok "\n\n a*2/b" (Div (Mul (Id "a", Const (CInt 2)), Id "b")) +let%test _ = parse_ok " (a + 2)*b" (Mul (Add (Id "a", Const (CInt 2)), Id "b")) + +let%test _ = + parse_ok " not(not (a) + 2)*b" (Mul (Not (Add (Not (Id "a"), Const (CInt 2))), Id "b")) +;; + +let%test _ = + parse_ok + " not(not((a+(3/2-1)))+2)*b" + (Mul + ( Not + (Add + ( Not + (Add (Id "a", Sub (Div (Const (CInt 3), Const (CInt 2)), Const (CInt 1)))) + , Const (CInt 2) )) + , Id "b" )) +;; + +let%test _ = + parse_ok + " a + 2 = b * 3" + (Eq (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a \n+ 2 > b * 3" + (Gt (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a + 2\n >= b * 3" + (Gte (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a + 2 != b * 3" + (Not (Eq (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3))))) +;; + +let%test _ = + parse_ok + " a + 2 < b \t* 3" + (Lt (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a + 2 \n\n<= b * 3" + (Lte (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a < 2 && b = 3" + (And (Lt (Id "a", Const (CInt 2)), Eq (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a < 2 || b = 3" + (Or (Lt (Id "a", Const (CInt 2)), Eq (Id "b", Const (CInt 3)))) +;; + +let%test _ = parse_ok "a && b||c" (Or (And (Id "a", Id "b"), Id "c")) +let%test _ = parse_fail "(a && b||c" +let%test _ = parse_fail "a + " +let%test _ = parse_fail " + " +let%test _ = parse_fail " + a" +let%test _ = parse_fail "not" +let%test _ = parse_fail "a && b||c)" + +(*== Test parse apply ==*) + +let parse_ok = test_ok parse_expr + +let%test _ = + parse_ok + "let c = (a 1 b w c (fun x -> x))" + (Let + ( Decl ("c", []) + , App (Id "a", [ Const (CInt 1); Id "b"; Id "w"; Id "c"; Fun ([ "x" ], Id "x") ]) + )) +;; + +(* let parse_ok_anon = test_ok (parse_expr) *) +(* let%test _ = parse_ok_anon "(fun x -> x)" (Fun(["x"], Id "x")) *) + +(*== Test parse common expretion ==*) +let parse_ok = test_ok parse_expr +let parse_fail = test_fail parse_expr + +let%test _ = + parse_ok + " a + 2 \n\n<= b * 3" + (Lte (Add (Id "a", Const (CInt 2)), Mul (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + "a < 2 && b = 3" + (And (Lt (Id "a", Const (CInt 2)), Eq (Id "b", Const (CInt 3)))) +;; + +let%test _ = + parse_ok + " a < 2 || b = 3" + (Or (Lt (Id "a", Const (CInt 2)), Eq (Id "b", Const (CInt 3)))) +;; + +let%test _ = parse_ok " a && b||c" (Or (And (Id "a", Id "b"), Id "c")) + +(* let%test _ = parse_ok "(a b) * 3 + (b 1 (a f 2) (1 + a))" (Id "") *) +(* let%test _ = + parse_ok + "(a b 2 1+3 * b d (-2) (r f)) + 3" + (Add + ( Add + ( App (Id "a", [ Id "b"; Const (CInt 2); Const (CInt 1) ]) + , Mul + ( Const (CInt 3) + , App (Id "b", [ Id "d"; Const (CInt (-2)); App (Id "r", [ Id "f" ]) ]) ) + ) + , Const (CInt 3) )) + ;; *) + +let%test _ = + parse_ok + "a + (f 2 x) * 3" + (Add (Id "a", Mul (App (Id "f", [ Const (CInt 2); Id "x" ]), Const (CInt 3)))) +;; + +let%test _ = + parse_ok + "(a + (f 2 x (g 3 y)) * 3)" + (Add + ( Id "a" + , Mul + ( App + ( Id "f" + , [ Const (CInt 2); Id "x"; App (Id "g", [ Const (CInt 3); Id "y" ]) ] ) + , Const (CInt 3) ) )) +;; + +(* (a + (f 2 x (g (3*z) y)) * 3) - not work *) +let%test _ = + parse_ok + "(a + (f 2 x (g 3*z y)) * 3)" + (Add + ( Id "a" + , Mul + ( App + ( Id "f" + , [ Const (CInt 2) + ; Id "x" + ; Mul (App (Id "g", [ Const (CInt 3) ]), App (Id "z", [ Id "y" ])) + ] ) + , Const (CInt 3) ) )) +;; + +let%test _ = + parse_ok + "true && (a + (f false (g 3 y)) = 3 || 2)" + (And + ( Const (CBool true) + , Or + ( Eq + ( Add + ( Id "a" + , App + ( Id "f" + , [ Const (CBool false); App (Id "g", [ Const (CInt 3); Id "y" ]) ] + ) ) + , Const (CInt 3) ) + , Const (CInt 2) ) )) +;; + +let%test _ = parse_ok "()" (Const CUnit) +let%test _ = parse_ok "fun \n( a , c ) -> b" (Fun ([ "a"; "c" ], Id "b")) +let%test _ = parse_ok "(fun a -> b)" (Fun ([ "a" ], Id "b")) +let%test _ = parse_ok "let a (c, d) = (b)" (Let (Decl ("a", [ "c"; "d" ]), Id "b")) +let%test _ = parse_ok "fun (a, b) -> c" (Fun ([ "a"; "b" ], Id "c")) +let%test _ = parse_ok " let rec a = ()" (Let (DeclRec ("a", []), Const CUnit)) +let%test _ = parse_ok "let a = (b) in c" (LetIn (Decl ("a", []), Id "b", Id "c")) +let%test _ = parse_ok "\nlet rec a = b in (c)" (LetIn (DeclRec ("a", []), Id "b", Id "c")) +let%test _ = parse_ok "\nif a then b else c" (If (Id "a", Id "b", Id "c")) +let%test _ = parse_ok "if a then b" (If (Id "a", Id "b", Const CUnit)) +let%test _ = parse_ok "\n(let a = b)" (Let (Decl ("a", []), Id "b")) + +let%test _ = + parse_ok + "let a = \nlet b = 1 in\n\t let c = b in\n\t c" + (Let + ( Decl ("a", []) + , LetIn (Decl ("b", []), Const (CInt 1), LetIn (Decl ("c", []), Id "b", Id "c")) )) +;; + +let%test _ = + parse_ok + "let a = let b = 1 in let c = b in c" + (Let + ( Decl ("a", []) + , LetIn (Decl ("b", []), Const (CInt 1), LetIn (Decl ("c", []), Id "b", Id "c")) )) +;; + +let%test _ = parse_ok "let () = b" (Let (Decl ("()", []), Id "b")) +let%test _ = parse_fail "fun -> b" +let%test _ = parse_fail "(let a = b" +let%test _ = parse_fail "let a = b)" +let%test _ = parse_fail "let = b" +let%test _ = parse_fail "let a = " +let%test _ = parse_fail "let (a) = b" +let%test _ = parse_fail "let rec = b" +let%test _ = parse_fail "let rec a = " +let%test _ = parse_fail "let = b in c" +let%test _ = parse_fail "let a = in c" +let%test _ = parse_fail "let a = b in " +let%test _ = parse_fail "let rec = b in c" +let%test _ = parse_fail "let rec a = in c" +let%test _ = parse_fail "let rec a = b in " +let%test _ = parse_fail "if a else b" + +(*== Test parse ==*) +let parse_ok = test_ok parse_exprs +(*let parse_fail = test_fail parse_exprs*) + +let%test _ = + parse_ok + "let a = \nlet b = 1 in\n\t let c = b in\n\t c" + [ Let + ( Decl ("a", []) + , LetIn (Decl ("b", []), Const (CInt 1), LetIn (Decl ("c", []), Id "b", Id "c")) + ) + ] +;; + +let%test _ = + parse_ok + "let a = \nlet b = 1 in\n\t let c = b in\n\t c;;" + [ Let + ( Decl ("a", []) + , LetIn (Decl ("b", []), Const (CInt 1), LetIn (Decl ("c", []), Id "b", Id "c")) + ) + ] +;; + +let%test _ = parse_ok "\n\t \n" [] +let%test _ = parse_ok "" [] + +let%test _ = + parse_ok + "let a = (b) let a = b;;" + [ Let (Decl ("a", []), Id "b"); Let (Decl ("a", []), Id "b") ] +;; + +let%test _ = + parse_ok + "let a = b;; let a c d = b" + [ Let (Decl ("a", []), Id "b"); Let (Decl ("a", [ "c"; "d" ]), Id "b") ] +;; + +let%test _ = + parse_ok + "let a = b in c;; let a = let c = b in c" + [ LetIn (Decl ("a", []), Id "b", Id "c") + ; Let (Decl ("a", []), LetIn (Decl ("c", []), Id "b", Id "c")) + ] +;; + +let%test _ = + parse_ok + "let a b c = 1;; (a b c 1 (c + 2));; let b = (a c)" + [ Let (Decl ("a", [ "b"; "c" ]), Const (CInt 1)) + ; App (Id "a", [ Id "b"; Id "c"; Const (CInt 1); Add (Id "c", Const (CInt 2)) ]) + ; Let (Decl ("b", []), App (Id "a", [ Id "c" ])) + ] +;; + +let%test _ = + parse_ok + "let a = let b = 1 in let c = 2 in (d 3)" + [ Let + ( Decl ("a", []) + , LetIn + ( Decl ("b", []) + , Const (CInt 1) + , LetIn (Decl ("c", []), Const (CInt 2), App (Id "d", [ Const (CInt 3) ])) ) + ) + ] +;; + +let%test _ = parse_ok "a b c" [ App (Id "a", [ Id "b"; Id "c" ]) ] +let%test _ = parse_fail ";;" diff --git a/slarnML/lib/parser/parser.mli b/slarnML/lib/parser/parser.mli new file mode 100644 index 000000000..4469fd9e9 --- /dev/null +++ b/slarnML/lib/parser/parser.mli @@ -0,0 +1,7 @@ +(** Copyright 2023-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ast + +val parser : string -> (expr list, string) result diff --git a/slarnML/lib/pretty_print/pprint.ml b/slarnML/lib/pretty_print/pprint.ml new file mode 100644 index 000000000..f90bd1f6b --- /dev/null +++ b/slarnML/lib/pretty_print/pprint.ml @@ -0,0 +1,196 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Res +open String + +(* open Pprint_ast *) +open Pprint_cc +open Pprint_ll +open Pprint_anf +open Pprint_riscv +open Ast +open Clos_conv +open Lambda_lifting +open Anf_conv +open Riscv + +(* let p = String.concat "\n" [ + "let fac n = "; + "let rec fack n f = "; + "if (n <= 1) then (f 1)"; + "else (fack n f)"; + "in"; + "(fack (n-1) (fun x -> x));;"; + "let main = (print_int (fac 3));;" +] + ;; + let _ = String.concat "\n" ["let c=(a 1 b w c (fun x->x));;"] + ;; + let _ = String.concat "\n" ["((fun x -> x) 10)"] + ;; + Pprint_ast.print_expr p;; *) + +let pp_clos_conv ast = + match clos_conv ast with + | Result cc_ast -> print_string @@ concat "\n" (List.map pp_cc_expr cc_ast) + | Error e -> print_string e +;; + +let pp_lambda_lifting ast = + match lambda_lifting ast with + | Result ll_ast -> print_string @@ concat "\n" (List.map pp_gl_expr ll_ast) + | Error e -> print_string e +;; + +let pp_anf ast = print_string @@ concat "\n" (List.map pp_anf_afun (anf ast)) + +(* let pp_cc_ll ast = + match clos_conv ast with + | Result cc_ast -> pp_lambda_lifting cc_ast + | Error e -> print_string e + ;; *) + +let pp_cc_ll_anf ast = + match clos_conv ast >>= fun ast -> lambda_lifting ast with + | Result ll_ast -> pp_anf ll_ast + | Error e -> print_string e +;; + +let ast1 = + Let + ( Decl ("a", [ "b" ]) + , LetIn + ( Decl ("c", [ "d"; "e" ]) + , Add (Id "e", Add (Id "d", Id "b")) + , App (Id "c", [ Const (CInt 2); Id "b" ]) ) ) +;; + +let ast2 = + Let + ( Decl ("fac", [ "n" ]) + , LetIn + ( DeclRec ("fack", [ "n"; "k" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , App (Id "k", [ Const (CInt 1) ]) + , App + ( Id "fack" + , [ Sub (Id "n", Const (CInt 1)) + ; Fun ([ "m" ], App (Id "k", [ Mul (Id "m", Id "n") ])) + ] ) ) + , App (Id "fack", [ Id "n"; Fun ([ "x" ], Id "x") ]) ) ) +;; + +let ast3 = + Let + ( Decl ("fac", [ "n" ]) + , LetIn + ( DeclRec ("fack", [ "k" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , App (Id "k", [ Const (CInt 1) ]) + , App + ( Id "fack" + , [ Sub (Id "n", Const (CInt 1)) + ; Fun ([ "m" ], App (Id "k", [ Mul (Id "m", Id "n") ])) + ] ) ) + , App (Id "fack", [ Fun ([ "x" ], Id "x") ]) ) ) +;; + +(* + let anf1 = [ +AFun("anon$1#fack#fac",["k";"n";"m"], + ALet("anf_op#1",AMul(AId"m",AId"n"), + ALet("anf_op#2",AMul(AId"k",AId"anf_op#1"), + ACExpr(CImmExpr(AId"anf_op#2")) + ))); +AFun("fack#fac",["n";"k"], + ALet("anf_op#3",ALte(AId"n",AInt 1), + ALet("anf_if#4",AIf(AId"anf_op#3", + ALet("anf_op#5",ASub(AId"n",AInt 1), + ALet("anf_app#6",AApp(AId"n", [AId"anf_op#5"]), + ACExpr(CImmExpr(AId"anf_app#6")) + )), + ALet("anf_app#7",AApp(AId"anon$1#fack#fac",[AId"k";AId"n"]), + ACExpr(CImmExpr(AId"anf_app#7")) + ) + ), + ACExpr(CImmExpr(AId"anf_if#4")) + ))) +(* AFun("anon$2#fac",["x"],ACExpr(CImmExpr(AId"x"))); +AFun("fac",["n"], + ALet("anf_app#8",AApp(AId"fack#fac",[AId"n";AId"anon$2#fac"]), + ACExpr(CImmExpr(AId "anf_app#8")) + )) *) +];; *) + +(* + let ast = ast2 + ;; + pp_ast ast;; + print_string "\n\n" + ;; + pp_clos_conv ast;; + print_string "\n\n" + ;; + pp_cc_ll ast;; + print_string "\n\n" + ;; + pp_cc_ll_anf ast;; + print_string "\n\n\n=====\n\n\n" + ;; +*) +(* pp_clos_conv Clos_conv.ast1;; + print_string@@pp_cc_expr Clos_conv.cc1;; *) + +let pp_asm asm = + match asm with + | Error e -> print_string e + | Result prog -> + print_string @@ String.concat "\n" (List.map (pp_instruction "\t") prog) +;; + +let pp_cc_ll_anf_asm ast = + match clos_conv ast >>= fun ast -> lambda_lifting ast with + | Result ll_ast -> pp_asm (asm (anf ll_ast)) + | Error e -> print_string e +;; + +(* pp_cc_ll_anf_asm [];; *) + +let ast_fac = + [ Let + ( DeclRec ("fac", [ "n" ]) + , If + ( Gt (Id "n", Const (CInt 1)) + , Const (CInt 1) + , Mul (Id "n", App (Id "fac", [ Sub (Id "n", Const (CInt 1)) ])) ) ) + ] +;; + +let ast_fac_1 = + [ Let + ( Decl ("fac", [ "n" ]) + , LetIn + ( DeclRec ("fack", [ "n"; "k" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , App (Id "k", [ Const (CInt 1) ]) + , App + ( Id "fack" + , [ Sub (Id "n", Const (CInt 1)) + ; Fun ([ "x" ], Mul (Id "x", App (Id "k", [ Id "n" ]))) + ] ) ) + , App (Id "fack", [ Id "n"; Fun ([ "x" ], Id "x") ]) ) ) + ; Let (Decl ("main", []), App (Id "print_int", [ App (Id "fac", [ Const (CInt 6) ]) ])) + ] +;; + +(* pp_cc_ll_anf [];; *) +(* print_string "\n\n\n";; + pp_cc_ll_anf_asm ast_fac_1 + ;; *) +(* pp_cc_ll_anf ast_fac_1 + ;; *) diff --git a/slarnML/lib/pretty_print/pprint_anf.ml b/slarnML/lib/pretty_print/pprint_anf.ml new file mode 100644 index 000000000..c934a2cf1 --- /dev/null +++ b/slarnML/lib/pretty_print/pprint_anf.ml @@ -0,0 +1,75 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Anf_ast +open String + +let pp_anf_immexpr = function + | AId id -> id + | AInt i -> string_of_int i + | ABool b -> string_of_bool b + | AUnit -> "()" +;; + +let rec pp_anf_aexpr tab ae = + let next_tab = concat "" [ "\t"; tab ] in + let pp_anf_cexpr tab = function + | CImmExpr imm -> pp_anf_immexpr imm + | ANot e -> concat "" [ "not "; pp_anf_immexpr e ] + | AOr (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "||"; pp_anf_immexpr e2; ")" ] + | AAnd (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "&&"; pp_anf_immexpr e2; ")" ] + | AEq (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "="; pp_anf_immexpr e2; ")" ] + | AGt (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; ">"; pp_anf_immexpr e2; ")" ] + | ALt (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "<"; pp_anf_immexpr e2; ")" ] + | AGte (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; ">="; pp_anf_immexpr e2; ")" ] + | ALte (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "<="; pp_anf_immexpr e2; ")" ] + | AAdd (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "+"; pp_anf_immexpr e2; ")" ] + | ASub (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "-"; pp_anf_immexpr e2; ")" ] + | AMul (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "*"; pp_anf_immexpr e2; ")" ] + | ADiv (e1, e2) -> concat "" [ "("; pp_anf_immexpr e1; "/"; pp_anf_immexpr e2; ")" ] + | AIf (e1, e2, e3) -> + let next_tab = concat "" [ "\t"; tab ] in + concat + "" + [ "if (" + ; pp_anf_immexpr e1 + ; ")\n" + ; tab + ; "then (\n" + ; next_tab + ; pp_anf_aexpr next_tab e2 + ; "\n" + ; tab + ; ") else (\n" + ; next_tab + ; pp_anf_aexpr next_tab e3 + ; ")" + ] + | AApp (e, args) -> + concat + "" + [ "("; pp_anf_immexpr e; " "; concat " " (List.map pp_anf_immexpr args); ")" ] + in + match ae with + | ALet (id, e1, e2) -> + concat + "" + [ "(let " + ; id + ; "=" + ; pp_anf_cexpr next_tab e1 + ; "\n" + ; tab + ; "in\n" + ; tab + ; pp_anf_aexpr tab e2 + ; ")" + ] + | ACExpr e -> pp_anf_cexpr tab e +;; + +let pp_anf_afun = function + | AFun (id, args, e) -> + concat "" [ "(fun "; id; "("; concat " " args; ")->\n\t"; pp_anf_aexpr "\t" e; "\n)" ] +;; diff --git a/slarnML/lib/pretty_print/pprint_ast.ml b/slarnML/lib/pretty_print/pprint_ast.ml new file mode 100644 index 000000000..4f14612db --- /dev/null +++ b/slarnML/lib/pretty_print/pprint_ast.ml @@ -0,0 +1,91 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ast +open Parser +open Printf +open String +open Typedtree + +let pp_const = function + | CInt i -> if i < 0 then concat "" [ "("; string_of_int i; ")" ] else string_of_int i + | CBool b -> string_of_bool b + | CUnit -> "()" +;; + +let expr_of_decl = function + | Decl (id, args) -> concat " " (id :: args) + | DeclRec (id, args) -> concat " " ("rec" :: id :: args) +;; + +let rec pp_expr expr = + match expr with + | Id id -> id + | Const c -> pp_const c + | Not e -> concat "" [ "not "; pp_expr e ] + | Or (e1, e2) -> concat "" [ "("; pp_expr e1; "||"; pp_expr e2; ")" ] + | And (e1, e2) -> concat "" [ "("; pp_expr e1; "&&"; pp_expr e2; ")" ] + | Eq (e1, e2) -> concat "" [ "("; pp_expr e1; "="; pp_expr e2; ")" ] + | Gt (e1, e2) -> concat "" [ "("; pp_expr e1; ">"; pp_expr e2; ")" ] + | Lt (e1, e2) -> concat "" [ "("; pp_expr e1; "<"; pp_expr e2; ")" ] + | Gte (e1, e2) -> concat "" [ "("; pp_expr e1; ">="; pp_expr e2; ")" ] + | Lte (e1, e2) -> concat "" [ "("; pp_expr e1; "<="; pp_expr e2; ")" ] + | Add (e1, e2) -> concat "" [ "("; pp_expr e1; "+"; pp_expr e2; ")" ] + | Sub (e1, e2) -> concat "" [ "("; pp_expr e1; "-"; pp_expr e2; ")" ] + | Mul (e1, e2) -> concat "" [ "("; pp_expr e1; "*"; pp_expr e2; ")" ] + | Div (e1, e2) -> concat "" [ "("; pp_expr e1; "/"; pp_expr e2; ")" ] + | If (e1, e2, e3) -> + concat "" [ "if ("; pp_expr e1; ") then ("; pp_expr e2; ") else ("; pp_expr e3; ")" ] + | Let (d, e2) -> concat "" [ "(let "; expr_of_decl d; "="; pp_expr e2; ")" ] + | LetIn (d, e2, e3) -> + concat "" [ "(let "; expr_of_decl d; "="; pp_expr e2; " in "; pp_expr e3; ")" ] + | Fun (args, e) -> concat "" [ "(fun "; concat " " args; "->"; pp_expr e; ")" ] + | App (e, args) -> + concat "" [ "("; pp_expr e; "->"; concat "->" (List.map pp_expr args); ")" ] +;; + +let pp_exprs exprs = concat "\t\n" @@ List.map pp_expr exprs + +let print_expr str = + match parser str with + | Ok e -> print_string @@ concat "\t\t\n" [ pp_exprs e; ";;\n\n" ] + | Error e -> eprintf "there was an error: %s\n" e +;; + +let pp_ast ast = print_string @@ pp_expr ast + +let pp_const_ty = function + | UnitTy -> "Unit" + | BoolTy -> "Bool" + | IntTy -> "Int" +;; + +let rec pp_type = function + | PrimTy c -> pp_const_ty c + | VarTy n -> string_of_int n + | ArrowTy types -> concat "" [ "("; concat "->" (List.map pp_type types); ")" ] +;; + +(* + " not (not ( not_1 ) + 1 *2 / 1 + 2)" + "let a = \nlet b = 1 in\n\t let c = b in\n\t c " + "let t = let k = if a then (let rec a x = x) else (fun x b -> 2*b+x) in k;;" + "let t = let k = if a then (let rec a x = x) else (fun x b -> 2*b+x) in k;; let q = 0" +*) +(* + string " not (not ( not_1 ) + 1 *2 / 1 + 2)" (fun _ -> printf ";;\n"; ());; +*) +(* string "let a b c = 1;; a b c;; let b = a c" (fun _ -> printf ";;\n"; ());; *) +(* print_expr "a + 2 \n\n<= b * 3"; + print_string "\n\n\n"; + print_expr "let a b c = 1;; a b c;; let b = a c";; + print_string "\n\n\n"; + print_expr "(a b) * 3 + (b 1 (a f 2))" + print_string "\n\n\n"; *) +(* print_expr "(a b 2 1+3 * b d + 2)" *) +(* print_expr "(a b 1)" *) +(* print_expr "(a b 2 1+3 * b d (-2) (r f) true) + 3 = 10 && false || 1" ;; *) +(* print_expr "let a = let b = 1 in let c = 2 in d" *) +(* print_expr "true && (a + (f false (g 3 y)) = 3 || 2)";; *) +(* + (b 1 (a f 2) (1 + a)) *) diff --git a/slarnML/lib/pretty_print/pprint_cc.ml b/slarnML/lib/pretty_print/pprint_cc.ml new file mode 100644 index 000000000..00c245830 --- /dev/null +++ b/slarnML/lib/pretty_print/pprint_cc.ml @@ -0,0 +1,44 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Cc_ast +open String + +let rec pp_cc_expr expr = + match expr with + | CId id -> id + | CConst c -> Pprint_ast.pp_const c + | CNot e -> concat "" [ "not "; pp_cc_expr e ] + | COr (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "||"; pp_cc_expr e2; ")" ] + | CAnd (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "&&"; pp_cc_expr e2; ")" ] + | CEq (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "="; pp_cc_expr e2; ")" ] + | CGt (e1, e2) -> concat "" [ "("; pp_cc_expr e1; ">"; pp_cc_expr e2; ")" ] + | CLt (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "<"; pp_cc_expr e2; ")" ] + | CGte (e1, e2) -> concat "" [ "("; pp_cc_expr e1; ">="; pp_cc_expr e2; ")" ] + | CLte (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "<="; pp_cc_expr e2; ")" ] + | CAdd (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "+"; pp_cc_expr e2; ")" ] + | CSub (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "-"; pp_cc_expr e2; ")" ] + | CMul (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "*"; pp_cc_expr e2; ")" ] + | CDiv (e1, e2) -> concat "" [ "("; pp_cc_expr e1; "/"; pp_cc_expr e2; ")" ] + | CIf (e1, e2, e3) -> + concat + "" + [ "if ("; pp_cc_expr e1; ") then ("; pp_cc_expr e2; ") else ("; pp_cc_expr e3; ")" ] + | CLet (d, e2) -> + concat "" [ "(let "; Pprint_ast.expr_of_decl d; "="; pp_cc_expr e2; ")" ] + | CLetIn (d, e2, e3) -> + concat + "" + [ "(let " + ; Pprint_ast.expr_of_decl d + ; "=" + ; pp_cc_expr e2 + ; " in " + ; pp_cc_expr e3 + ; ")" + ] + | CFun (args, e) -> concat "" [ "(fun "; concat " " args; "->"; pp_cc_expr e; ")" ] + | CApp (e, args) -> + concat "" [ "("; pp_cc_expr e; " "; concat " " (List.map pp_cc_expr args); ")" ] +;; diff --git a/slarnML/lib/pretty_print/pprint_ll.ml b/slarnML/lib/pretty_print/pprint_ll.ml new file mode 100644 index 000000000..0e585900c --- /dev/null +++ b/slarnML/lib/pretty_print/pprint_ll.ml @@ -0,0 +1,38 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Ll_ast +open String +open Pprint_ast + +let rec pp_ll_expr expr = + match expr with + | LId id -> id + | LConst c -> pp_const c + | LNot e -> concat "" [ "not "; pp_ll_expr e ] + | LOr (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "||"; pp_ll_expr e2; ")" ] + | LAnd (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "&&"; pp_ll_expr e2; ")" ] + | LEq (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "="; pp_ll_expr e2; ")" ] + | LGt (e1, e2) -> concat "" [ "("; pp_ll_expr e1; ">"; pp_ll_expr e2; ")" ] + | LLt (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "<"; pp_ll_expr e2; ")" ] + | LGte (e1, e2) -> concat "" [ "("; pp_ll_expr e1; ">="; pp_ll_expr e2; ")" ] + | LLte (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "<="; pp_ll_expr e2; ")" ] + | LAdd (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "+"; pp_ll_expr e2; ")" ] + | LSub (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "-"; pp_ll_expr e2; ")" ] + | LMul (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "*"; pp_ll_expr e2; ")" ] + | LDiv (e1, e2) -> concat "" [ "("; pp_ll_expr e1; "/"; pp_ll_expr e2; ")" ] + | LIf (e1, e2, e3) -> + concat + "" + [ "if ("; pp_ll_expr e1; ") then ("; pp_ll_expr e2; ") else ("; pp_ll_expr e3; ")" ] + | LApp (e, args) -> + concat "" [ "("; e; " "; concat " " (List.map pp_ll_expr args); ")" ] + | LIn (id, e1, e2) -> + concat "" [ "let "; id; " = ("; pp_ll_expr e1; " in "; pp_ll_expr e2; ")" ] +;; + +let pp_gl_expr = function + | LFun (id, args, e) -> + concat "" [ "(fun "; id; "("; concat " " args; ")->("; pp_ll_expr e; "))" ] +;; diff --git a/slarnML/lib/pretty_print/pprint_riscv.ml b/slarnML/lib/pretty_print/pprint_riscv.ml new file mode 100644 index 000000000..4293049d7 --- /dev/null +++ b/slarnML/lib/pretty_print/pprint_riscv.ml @@ -0,0 +1,91 @@ +open Riscv_ast +open String + +let pp_reg = function + | Zero -> "zero" + | Ra -> "ra" + | Sp -> "sp" + | S n -> "s" ^ string_of_int n + | A n -> "a" ^ string_of_int n + | T n -> "t" ^ string_of_int n +;; + +let pp_cond = function + | Beq -> "beq " + | Bge -> "bge " + | Bgt -> "bgt " + | Blt -> "blt " + | Ble -> "ble " + | Bne -> "bne " +;; + +let pp_addr = function + | Id id -> id + | Reg r -> pp_reg r +;; + +let pp_math rd r1 r2 op = + let pp_rr rd r1 r2 = concat "," [ pp_reg rd; pp_reg r1; pp_reg r2 ] in + match op with + | I op -> + (match op with + | Add -> "add " ^ pp_rr rd r1 r2 + | And -> "and " ^ pp_rr rd r1 r2 + | Or -> "or " ^ pp_rr rd r1 r2 + | Xor -> "xor " ^ pp_rr rd r1 r2 + | Sll -> "sll " ^ pp_rr rd r1 r2 + | Srl -> "srl " ^ pp_rr rd r1 r2) + | Mul -> "mul " ^ pp_rr rd r1 r2 + | Sub -> "sub " ^ pp_rr rd r1 r2 + | Div -> "div " ^ pp_rr rd r1 r2 +;; + +let pp_imm = function + | ImmInt i -> string_of_int i + | ConstAddr (c, f) -> concat "" [ "%"; c; ""; "("; f; ")" ] +;; + +let pp_mathi rd r1 n op = + let pp_rn rd r1 n = concat "," [ pp_reg rd; pp_reg r1; pp_imm n ] in + match op with + | Add -> "addi " ^ pp_rn rd r1 n + | And -> "andi " ^ pp_rn rd r1 n + | Or -> "ori " ^ pp_rn rd r1 n + | Xor -> "xori " ^ pp_rn rd r1 n + | Sll -> "slli " ^ pp_rn rd r1 n + | Srl -> "srli " ^ pp_rn rd r1 n +;; + +let pp_instruction tab instr = + let pp_stack_arg rd n r1 = + concat "" [ pp_reg rd; ","; pp_imm n; "("; pp_reg r1; ")" ] + in + match instr with + | Tag t -> t ^ ":" + | Math (op, rd, r1, r2) -> tab ^ pp_math rd r1 r2 op + | Mathi (op, rd, r1, r2) -> tab ^ pp_mathi rd r1 r2 op + | Beqz (r1, a) -> "beqz " ^ concat "," [ pp_reg r1; pp_addr a ] + | Bnez (r1, a) -> "bnez " ^ concat "," [ pp_reg r1; pp_addr a ] + | Bnch (cond, r1, r2, a) -> + pp_cond cond ^ concat "," [ pp_reg r1; pp_reg r2; pp_addr a ] + | Call a -> "call " ^ pp_addr a + | Jmp a -> tab ^ "j " ^ pp_addr a + | La (rd, a) -> tab ^ "la " ^ concat "," [ pp_reg rd; pp_addr a ] + | Li (rd, n) -> tab ^ "li " ^ concat "," [ pp_reg rd; pp_imm n ] + | Mv (rd, rs) -> tab ^ "mv " ^ concat "," [ pp_reg rd; pp_reg rs ] + | Ret -> "ret" + | Ld (rd, n, r1) -> tab ^ "ld " ^ pp_stack_arg rd n r1 + | Sd (rd, n, r1) -> tab ^ "sd " ^ pp_stack_arg rd n r1 + | Lui (rd, imm) -> tab ^ "lui " ^ concat "," [ pp_reg rd; pp_imm imm ] + | Ecall -> "ecall" + | Global g -> ".global " ^ g + | Attribute a -> ".attribute " ^ a +;; +(* Unused + | Lb (rd, n, r1) -> "la "^(pp_stack_arg rd n r1) + | Lh (rd, n, r1) -> "lh "^(pp_stack_arg rd n r1) + | Lw (rd, n, r1) -> "lw "^(pp_stack_arg rd n r1) + | Sb (rd, n, r1) -> "sa "^(pp_stack_arg rd n r1) + | Sh (rd, n, r1) -> "sh "^(pp_stack_arg rd n r1) + | Sw (rd, n, r1) -> "sw "^(pp_stack_arg rd n r1) +*) diff --git a/slarnML/lib/res.ml b/slarnML/lib/res.ml new file mode 100644 index 000000000..bc53aba95 --- /dev/null +++ b/slarnML/lib/res.ml @@ -0,0 +1,13 @@ +type 'a res = + | Result of 'a + | Error of string +[@@deriving show { with_path = false }] + +let map f = function + | Result o -> f o + | Error e -> Error e +;; + +let bind r f = f r +let ( >>= ) r f = map f r +let ( |> ) = bind diff --git a/slarnML/lib/riscv64/.gdbinit b/slarnML/lib/riscv64/.gdbinit new file mode 100644 index 000000000..98b540775 --- /dev/null +++ b/slarnML/lib/riscv64/.gdbinit @@ -0,0 +1,14 @@ +set history save +set architecture riscv:rv64 +set sysroot /usr/riscv64−linux−gnu +target remote :1234 +tui enable +# tui new−layout example {−horizontal regs 1 asm 1} 2 status +# cmd 1 +tui new-layout example {-horizontal regs 1 asm 1} 2 status 0 cmd 1 +layout example +# tui disable +focus cmd +b _start +c +# x/8xg $sp \ No newline at end of file diff --git a/slarnML/lib/riscv64/call_define.ml b/slarnML/lib/riscv64/call_define.ml new file mode 100644 index 000000000..b9e5cb59a --- /dev/null +++ b/slarnML/lib/riscv64/call_define.ml @@ -0,0 +1,2 @@ +let exit = 93 +let default_func = [ "print_int", 1; "print_char", 1 ] diff --git a/slarnML/lib/riscv64/part_app.c b/slarnML/lib/riscv64/part_app.c new file mode 100644 index 000000000..1be02822f --- /dev/null +++ b/slarnML/lib/riscv64/part_app.c @@ -0,0 +1,122 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include + +// const uint16_t MAX_APPS = 100; +// const uint8_t MAX_ARGS = 4; +#define MAX_APPS 100 +#define MAX_ARGS 4 + + +int64_t min(int64_t a, int64_t b) { + if (a < b) return a; + else return b; +} + +struct Func +{ + uint8_t argscnt; + uint8_t cnt; + void *ptr; + int64_t *argsfun; +}; +struct Func func_init(void *ptr, uint8_t cnt) { + struct Func new; + new.ptr = ptr; + new.argscnt = cnt; + new.argsfun = malloc(sizeof(int64_t)*min((int64_t)MAX_ARGS, cnt)); + new.cnt = 0; + return new; +} +struct Func *part_apps; +uint16_t last_app = 0; + +int64_t app_n(struct Func *f) { + switch ((*f).argscnt) { + case 0: + int64_t(*f_ptr0)(); + f_ptr0 = (*f).ptr; + return f_ptr0(); + case 1: + int64_t(*f_ptr1)(int64_t); + f_ptr1 = (*f).ptr; + return f_ptr1(f->argsfun[0]); + case 2: + int64_t(*f_ptr2)(int64_t, int64_t); + f_ptr2 = (*f).ptr; + return f_ptr2(f->argsfun[0], f->argsfun[1]); + case 3: + int64_t(*f_ptr3)(int64_t, int64_t, int64_t); + f_ptr3 = (*f).ptr; + return f_ptr3(f->argsfun[0], f->argsfun[1], f->argsfun[2]); + case 4: + int64_t(*f_ptr4)(int64_t, int64_t, int64_t, int64_t); + f_ptr4 = (*f).ptr; + return f_ptr4(f->argsfun[0], f->argsfun[1], f->argsfun[2], f->argsfun[3]); + default: + return -1; + } +} + +int64_t app(struct Func *f, uint8_t cnt, int64_t *args) { + uint8_t f_cnt = f->cnt; + for (; f->cnt < min(MAX_ARGS, min(f_cnt + cnt, f->argscnt)); f->cnt++) { + f->argsfun[f->cnt] = args[f->cnt - f_cnt]; + } + int64_t ret; + if (f->cnt < f->argscnt) { + return (int64_t)f; + } else { + ret = app_n(f); + } + if (f_cnt + cnt > f->argscnt) { + int64_t new_args[MAX_ARGS]; + for (int i = f->argscnt - f_cnt; i < min(MAX_ARGS, cnt); i++) { + new_args[i - (f->argscnt - f_cnt)] = args[i]; + } + return app((void*)ret, f_cnt + cnt - f->argscnt, new_args); + } + else return ret; +} + +int64_t part_app(void *f_ptr, int argcnt, int appcnt, ...) { + int cnt = 0; + int64_t args[MAX_ARGS]; + va_list argptr; + va_start(argptr, appcnt); + for (int i = 0; i < min(appcnt, MAX_ARGS); i++) { + args[i] = va_arg(argptr, int64_t); + } + va_end(argptr); + if ((int64_t)&part_apps[0] <= (int64_t)f_ptr && (int64_t)f_ptr <= (int64_t)&part_apps[MAX_APPS]) { + part_apps[last_app] = *(struct Func *)f_ptr; + } else { + part_apps[last_app] = func_init(f_ptr, argcnt); + } + last_app = (last_app + 1) % MAX_APPS; + return app(&part_apps[last_app-1], appcnt, args); +} + +void init_part_apps() { + part_apps = malloc(sizeof(struct Func) * MAX_APPS); +} + +int many_arg(int n,int n1,int n2,int n3,int n4,int n5,int n6,int n7,int n8,int n9,int n10,int n11,int n12,int n13) { + int ret = n+n1+n3+(n4/n2)+n5+n6+n7+n8+n9+n10+n11*n12*n13; + return ret % 256; +} + +int fun ( int a, int b) +{ + return(10*a+b); +} + +int notmain () +{ + return many_arg(0,1,2,3,4,5,6,7,8,9,10,11,12,13); +} + diff --git a/slarnML/lib/riscv64/print.S b/slarnML/lib/riscv64/print.S new file mode 100644 index 000000000..f06f04e82 --- /dev/null +++ b/slarnML/lib/riscv64/print.S @@ -0,0 +1,86 @@ +.global print_char +.global print_int + +print_char: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + + sd a0,-24(s0) + addi a1,s0,-24 + li a0, 1 + li a7, 64 + li a2, 1 + ecall + + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + +print_uint: + addi sp,sp,-64 + sd ra,56(sp) + sd s0,48(sp) + addi s0,sp,64 + + li t0,10 # const + li t1, 8 + li a2, 0 # buffer_size + addi s1,s0,-24 + + .loop1: + li a4,0 + li t2,0 + .loop2: + rem a5,a0,t0 + addi a5,a5,48 + slli a4,a4, 8 + add a4,a4,a5 + addi t2,t2, 1 + div a0,a0,t0 + + beq t1,t2, .end_loop2 + beqz a0, .end_loop2 + j .loop2 + .end_loop2: + sd a4,0(s1) + addi a2,a2, 8 + addi s1,s1,-8 + beqz a0, .end_loop1 + j .loop1 + .end_loop1: + + li a0, 1 + addi a1,s1,8 # & + li a7, 64 # write + ecall + + + ld ra,56(sp) + ld s0,48(sp) + addi sp,sp,64 + ret + +print_int: + addi sp,sp,-48 + sd ra,40(sp) + sd s0,32(sp) + addi s0,sp,48 + + bge a0,zero, .posit + li a3,-1 + mul a0,a0,a3 + sd a0,-24(s0) + li a0,45 # '-' + call print_char + + ld a0,-24(s0) + .posit: + call print_uint + + ld ra,40(sp) + ld s0,32(sp) + addi sp,sp,48 + ret diff --git a/slarnML/lib/riscv64/riscv.ml b/slarnML/lib/riscv64/riscv.ml new file mode 100644 index 000000000..eb1270d81 --- /dev/null +++ b/slarnML/lib/riscv64/riscv.ml @@ -0,0 +1,653 @@ +open Riscv_ast +open Anf_ast + +(* open Pprint_riscv *) +open List +open Res +open Call_define + +let split_at_n n lst = + let rec helper m l r = + if m = 0 + then rev l, r + else ( + match r with + | [] -> rev l, r + | head :: tail -> helper (m - 1) (head :: l) tail) + in + helper n [] lst +;; + +let int_of_bool b = if b then 1 else 0 +let get_offset = map (fun (offset, _, _, _, _, _) -> Result offset) +let get_regs = map (fun (_, regs, _, _, _, _) -> Result regs) +let get_offsets = map (fun (_, _, offsets, _, _, _) -> Result offsets) +let get_free = map (fun (_, _, _, free, _, _) -> Result free) +let get_cond = map (fun (_, _, _, _, cond, _) -> Result cond) + +let update_env f f1 f2 f3 = + map (fun (offset, regs, offsets, free, conds, funs) -> + Result (f offset, f1 regs, f2 offset offsets, f3 free, conds, funs)) +;; + +let update_cond f = + map (fun (offset, regs, offsets, free, conds, funs) -> + Result (offset, regs, offsets, free, f conds, funs)) +;; + +let f_id x = x + +let get_fun name = + map (fun (_, _, _, _, _, funs) -> + Result (List.find_opt (fun (f_name, _) -> f_name = name) funs)) +;; + +let update_funs f = + map (fun (offset, regs, offsets, free, conds, funs) -> + Result (offset, regs, offsets, free, conds, f funs)) +;; + +let add_fun name args_cnt = + map (fun (offset, regs, offsets, free, conds, funs) -> + Result (offset, regs, offsets, free, conds, (name, args_cnt) :: funs)) +;; + +let rec count_max_call_offset offset a = + let count_offset_cexpr = function + | ANot _ + | AOr _ + | AAnd _ + | AEq _ + | AGt _ + | AGte _ + | ALt _ + | ALte _ + | AAdd _ + | ASub _ + | AMul _ + | ADiv _ + | CImmExpr _ -> 0 + | AIf (_, e1, e2) -> + max offset (max (count_max_call_offset offset e1) (count_max_call_offset offset e2)) + | AApp (_, args) -> max 0 (length args - 8) * 8 + in + match a with + | ACExpr e -> count_offset_cexpr e + | ALet (_, c, a) -> + max offset (max (count_offset_cexpr c) (count_max_call_offset offset a)) +;; + +let rec count_offset_aexpr a = + let count_offset_cexpr = function + | ANot _ + | AOr _ + | AAnd _ + | AEq _ + | AGt _ + | AGte _ + | ALt _ + | ALte _ + | AAdd _ + | ASub _ + | AMul _ + | ADiv _ + | CImmExpr _ -> 0 + | AApp (_, args) -> max 3 (length args - 5) * 8 + | AIf (_, e1, e2) -> count_offset_aexpr e1 + count_offset_aexpr e2 + in + match a with + | ACExpr e -> count_offset_cexpr e + | ALet (_, c, a) -> count_offset_cexpr c + count_offset_aexpr a + 8 +;; + +let save_id f id reg res = + map + (fun env -> + res + |> get_offsets + >>= fun offsets -> + match List.find_opt (fun (i, _) -> i = id) offsets with + | Some _ -> Result ([], env) + | None -> + res + |> get_offset + >>= fun offset -> + res + |> update_env f f_id (fun off os -> (id, off) :: os) f_id + >>= fun n_env -> Result ([ Sd (reg, ImmInt offset, S 0) ], n_env)) + res +;; + +let free_some_reg f res = + map + (fun env -> + get_free res + >>= fun free -> + match free with + | [] -> + get_regs res + >>= fun regs -> + (match regs with + | [] -> Error "Regs not exists" + | (rid_opt, reg) :: n_regs -> + res + |> get_offset + >>= fun env_offset -> + res + |> get_offsets + >>= fun offsets -> + let instr, f_offset, f_offsets = + match List.find_opt (fun (i, _) -> Some i = rid_opt) offsets, rid_opt with + | None, Some rid -> + [ Sd (reg, ImmInt (-env_offset), S 0) ], f, fun off os -> (rid, off) :: os + | Some _, _ | None, None -> [], f_id, fun _ x -> x + in + res + |> update_env f_offset (fun _ -> n_regs) f_offsets (fun fr -> reg :: fr) + >>= fun n_env -> Result (instr, n_env)) + | _ -> Result ([], env)) + res +;; + +let free_reg f reg = + map (fun env -> + Result env + |> get_regs + >>= fun regs -> + match List.find_opt (fun (_, r) -> r = reg) regs with + | None -> Result ([], env) + | Some (Some id, reg) -> + Result env + |> save_id f id reg + >>= fun (instr, env) -> + Result env + |> update_env + f_id + (List.filter (fun (_, r) -> r <> reg)) + (fun _ x -> x) + (fun fr -> reg :: fr) + >>= fun env -> Result (instr, env) + | Some (None, reg) -> + update_env + f_id + (List.filter (fun (_, r) -> r <> reg)) + (fun _ x -> x) + (fun fr -> reg :: fr) + (Result env) + >>= fun env -> Result ([], env)) +;; + +let block_reg f opt reg res = + res + |> get_regs + >>= fun regs -> + match List.find_opt (fun (i, r) -> i = opt && r = reg) regs with + | Some _ -> res >>= fun env -> Result ([], env) + | None -> + res + |> free_reg f reg + >>= fun (instr, env) -> + Result env + |> update_env + f_id + (fun rs -> rs @ [ opt, reg ]) + (fun _ x -> x) + (List.filter (fun f -> f <> reg)) + >>= fun env -> Result (instr, env) +;; + +let get_free_reg f res = + res + |> free_some_reg f + >>= fun (instr1, env) -> + Result env + |> get_free + >>= fun free -> + match free with + | [] -> Error "Free is empty" + | reg :: _ -> + res |> free_reg f reg >>= fun (b_instr, env) -> Result (instr1 @ b_instr, reg, env) +;; + +let find_id f id reg_opt res = + map + (fun env -> + get_regs res + >>= fun regs -> + let q_opt = find_opt (fun (i, _) -> i = Some id) regs in + match q_opt with + | Some (_, q) -> + (match reg_opt with + | None -> + Result env + |> block_reg f (Some id) q + >>= fun (instr, env) -> Result (instr, q, env) + | Some r -> + res + |> block_reg f (Some id) r + >>= fun (instr, env) -> Result (instr @ [ Mv (r, q) ], r, env)) + | None -> + get_offsets res + >>= fun offsets -> + (match List.find_opt (fun (i, _) -> i = id) offsets with + | None -> Error (id ^ " not found") + | Some (_, offset) -> + (match reg_opt with + | None -> free_some_reg f res + | Some r -> free_reg f r res) + >>= fun (p_instr, env) -> + (match reg_opt with + | Some r -> + Result env + |> block_reg f (Some id) r + >>= fun (instr, env) -> + Result (p_instr @ instr @ [ Ld (r, ImmInt offset, S 0) ], r, env) + | None -> + Result env + |> get_free_reg f + >>= fun (instr0, r, env) -> + Result env + |> block_reg f (Some id) r + >>= fun (instr, env) -> + Result (p_instr @ instr0 @ instr @ [ Ld (r, ImmInt offset, S 0) ], r, env)))) + res +;; + +let free_regs f res = + res + |> get_regs + >>= fun regs -> + res + >>= fun env -> + List.fold_left + (fun res (_, r) -> + res + >>= fun (instr, env) -> + Result env |> free_reg f r >>= fun (n_instr, env) -> Result (instr @ n_instr, env)) + (Result ([], env)) + regs +;; + +let init_args args res = + let f x = x - 8 in + let s_left_arg cnt a res = + match a with + | AId a -> + res |> find_id f a (Some (A cnt)) >>= fun (instr, _, env) -> Result (instr, env) + | AInt i -> + res + |> block_reg f None (A cnt) + >>= fun (instr, env) -> Result (instr @ [ Li (A cnt, ImmInt i) ], env) + | ABool b -> + res + |> block_reg f None (A cnt) + >>= fun (instr, env) -> Result (instr @ [ Li (A cnt, ImmInt (int_of_bool b)) ], env) + | AUnit -> res >>= fun env -> Result ([], env) + in + let s_right_arg offset a res = + match a with + | AId a -> + res + |> find_id f a (Some (T 6)) + >>= fun (instr, _, env) -> Result (instr @ [ Sd (T 6, ImmInt offset, Sp) ], env) + | AInt i -> + res + |> free_reg f (T 6) + >>= fun (instr, env) -> + Result (instr @ [ Li (T 6, ImmInt i); Sd (T 6, ImmInt offset, Sp) ], env) + | ABool b -> + res + |> free_reg f (T 6) + >>= fun (instr, env) -> + Result + (instr @ [ Li (T 6, ImmInt (int_of_bool b)); Sd (T 6, ImmInt offset, Sp) ], env) + | AUnit -> res |> free_reg f (T 6) >>= fun (instr, env) -> Result (instr, env) + in + let left, right = split_at_n 7 args in + let r_len = length right in + res + >>= fun c_env -> + res + >>= (fun env -> + fold_right + (fun a r -> + r + >>= fun (offset, lst, e) -> + Result e + |> s_right_arg offset a + >>= fun (instr, e) -> Result (offset - 8, instr @ lst, e)) + right + (Result ((r_len - 1) * 8, [], env))) + >>= fun (_, right, env) -> + fold_left + (fun r a -> + r + >>= fun (cnt, lst, e) -> + Result e |> s_left_arg cnt a >>= fun (instr, e) -> Result (cnt + 1, instr @ lst, e)) + (Result (1, [], env)) + left + >>= fun (_, left, _) -> Result (right @ left, c_env) +;; + +let save_args offset args res = + let f o = o + 8 in + res + |> get_offset + >>= fun env_offset -> + res + |> update_env (fun _ -> offset) f_id (fun _ x -> x) f_id + >>= fun env -> + let left, right = split_at_n 8 args in + let _, r_offsets = + List.fold_left (fun (offset, lst) r -> offset + 8, (r, offset) :: lst) (0, []) right + in + fold_right + (fun l r -> + r + >>= fun (cnt, lst, e) -> + Result e + |> block_reg f (Some l) (A cnt) + >>= fun (p_instr, e) -> + Result e + |> save_id f l (A cnt) + >>= fun (instr, e) -> Result (cnt - 1, lst @ p_instr @ instr, e)) + left + (Result (min (length args - 1) 7, [], env)) + >>= fun (_, instr, env) -> + Result env + |> update_env (fun _ -> env_offset) f_id (fun _ x -> r_offsets @ x) f_id + >>= fun env -> Result (instr, env) +;; + +let load_imm f a res = + let load_const n_instr = + res + |> free_some_reg f + >>= fun (instr, env) -> + Result env + |> get_free_reg f + >>= fun (g_instr, reg, env) -> + Result env + |> block_reg f None reg + >>= fun (b_instr, env) -> Result (instr @ g_instr @ b_instr @ n_instr reg, reg, env) + in + match a with + | AId a -> res |> find_id f a None + | AInt i -> load_const (fun reg -> [ Li (reg, ImmInt i) ]) + | ABool b -> load_const (fun reg -> [ Li (reg, ImmInt (int_of_bool b)) ]) + | AUnit -> load_const (fun _ -> []) +;; + +let filter_tag = String.map (fun c -> if c = '#' || c = '$' then '_' else c) + +let rec build_aexpr tag a res = + let f o = o - 8 in + let get_tag id = ".tag_" ^ filter_tag id in + let get_tag_addr id = Id (get_tag (filter_tag id)) in + let get_true_tag id = ".tag_" ^ filter_tag id ^ "_t" in + let get_true_tag_addr id = Id (get_true_tag (filter_tag id)) in + let build_cexpr tag c res = + let bin_op op i1 i2 = + res + |> load_imm f i1 + >>= fun (instr1, reg1, env) -> + Result env + |> load_imm f i2 + >>= fun (instr2, reg2, env) -> + Result env + |> free_some_reg f + >>= fun (instrf, env) -> + Result env + |> get_free_reg f + >>= fun (instrg, regd, env) -> + Result (instr1 @ instr2 @ instrf @ instrg @ [ op regd reg1 reg2 ], Some regd, env) + in + let cond_op op i1 i2 = + res + |> load_imm f i1 + >>= fun (instr1, reg1, env) -> + Result env + |> load_imm f i2 + >>= fun (instr2, reg2, env) -> + Result env + |> update_cond (fun c -> (tag, op reg1 reg2) :: c) + >>= fun env -> Result (instr1 @ instr2, None, env) + in + match c with + | AOr (i1, i2) -> bin_op (fun rd r1 r2 -> Math (I Or, rd, r1, r2)) i1 i2 + | AAnd (i1, i2) -> bin_op (fun rd r1 r2 -> Math (I And, rd, r1, r2)) i1 i2 + | AAdd (i1, i2) -> bin_op (fun rd r1 r2 -> Math (I Add, rd, r1, r2)) i1 i2 + | ASub (i1, i2) -> bin_op (fun rd r1 r2 -> Math (Sub, rd, r1, r2)) i1 i2 + | AMul (i1, i2) -> bin_op (fun rd r1 r2 -> Math (Mul, rd, r1, r2)) i1 i2 + | ADiv (i1, i2) -> bin_op (fun rd r1 r2 -> Math (Div, rd, r1, r2)) i1 i2 + | AEq (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Beq, r1, r2, tag)) i1 i2 + | AGte (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Bge, r2, r1, tag)) i1 i2 + | ALte (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Ble, r2, r1, tag)) i1 i2 + | AGt (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Bgt, r2, r1, tag)) i1 i2 + | ALt (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Blt, r2, r1, tag)) i1 i2 + | ANot i -> + res + |> load_imm f i + >>= fun (instr, reg, env) -> + Result (instr @ [ Mathi (Xor, reg, reg, ImmInt (-1)) ], Some reg, env) + | CImmExpr i -> + res |> load_imm f i >>= fun (instr, reg, env) -> Result (instr, Some reg, env) + | AApp (i, args) -> + (match i with + | AId id -> + res + |> get_fun id + >>= fun c_opt -> + let load_ptr c_opt r = + match c_opt with + | None -> + r + |> find_id f id (Some (A 0)) + >>= fun (instr_fun, _, env) -> Result (instr_fun, 0, env) + | Some (_, c) -> + r + |> block_reg f None (A 0) + >>= fun (instr_fun, env) -> + Result + ( instr_fun + @ [ Lui (A 0, ConstAddr ("hi", filter_tag id)) + ; Mathi (Add, A 0, A 0, ConstAddr ("lo", filter_tag id)) + ] + , c + , env ) + in + res + |> free_regs f + >>= fun (instr_free, env) -> + Result env + |> load_ptr c_opt + >>= fun (instr_fun, c, env) -> + Result env + |> init_args ([ AInt c; AInt (List.length args) ] @ args) + >>= fun (instr_args, env) -> + Result + ( instr_free @ instr_fun @ instr_args @ [ Call (Id "part_app") ] + , Some (A 0) + , env ) + | _ -> Error "Call some shit") + | AIf (ec, e1, e2) -> + let free_a0 = free_reg f (A 0) in + let id = "if_bnch" in + let dflt_bnch res = + res + >>= (fun (instr0, reg, env) -> + Result ([], None, env) + |> build_aexpr tag e1 + >>= fun (instr1, reg1, env) -> + (match reg1 with + | Some reg when reg <> A 0 -> + Result env + |> free_a0 + >>= fun (instr, env) -> Result (instr @ [ Mv (A 0, reg) ], env) + | Some _ -> Result ([], env) + | _ -> Error "Error in if") + >>= fun (instr2, env) -> + Result + ( instr0 + @ (Beqz (reg, get_tag_addr id) :: instr1) + @ instr2 + @ [ Jmp (get_true_tag_addr id); Tag (get_tag id) ] + , Some (A 0) + , env )) + |> build_aexpr tag e2 + >>= fun (instr1, reg2, env) -> + (match reg2 with + | Some reg when reg <> A 0 -> + Result env + |> free_a0 + >>= fun (instr, env) -> Result (instr @ [ Mv (A 0, reg) ], env) + | Some _ -> Result ([], env) + | _ -> Error "Error in if") + >>= fun (instr2, env) -> + Result (instr1 @ instr2 @ [ Tag (get_true_tag id) ], Some (A 0), env) + in + (match ec with + | AId id -> + res + |> get_cond + >>= fun conds -> + (match List.find_opt (fun (t, _) -> t = get_tag_addr id) conds with + | Some (_, cond) -> + res + >>= (fun env -> + Result ([], None, env) + |> build_aexpr tag e1 + >>= fun (instr1, reg1, env) -> + (match reg1 with + | Some reg when reg <> A 0 -> + Result env + |> free_a0 + >>= fun (instr, env) -> Result (instr @ [ Mv (A 0, reg) ], env) + | Some _ -> Result ([], env) + | _ -> Error "Error in if") + >>= fun (instr2, env) -> + Result + ( (cond :: instr1) + @ instr2 + @ [ Jmp (get_true_tag_addr id); Tag (get_tag id) ] + , Some (A 0) + , env )) + |> build_aexpr tag e2 + >>= fun (instr1, reg2, env) -> + (match reg2 with + | Some reg when reg <> A 0 -> + Result env + |> free_a0 + >>= fun (instr, env) -> Result (instr @ [ Mv (A 0, reg) ], env) + | Some _ -> Result ([], env) + | _ -> Error "Error in if") + >>= fun (instr2, env) -> + Result (instr1 @ instr2 @ [ Tag (get_true_tag id) ], Some (A 0), env) + | None -> res |> load_imm f ec |> dflt_bnch) + | _ -> res |> load_imm f ec |> dflt_bnch) + in + res + >>= fun (instr0, _, env) -> + match a with + | ACExpr c -> + Result env + |> build_cexpr tag c + >>= fun (instr1, reg, env) -> Result (instr0 @ instr1, reg, env) + | ALet (id, c, a) -> + Result env + |> build_cexpr (get_tag_addr id) c + >>= fun (instr1, reg_opt, env) -> + (match reg_opt with + | None -> Result (instr0 @ instr1, None, env) |> build_aexpr tag a + | Some reg -> + Result env + |> block_reg f (Some id) reg + >>= fun (instr2, env) -> + Result (instr0 @ instr1 @ instr2, Some reg, env) |> build_aexpr tag a) +;; + +let init_fun anf res = + match anf with + | AFun (id, args, e) -> + let offset_call = 0 in + let offset_args = min 8 (length args) * 8 in + let offset_expr = count_offset_aexpr e in + let offset_reserved = 2 * 8 in + let offset_full = offset_call + offset_args + offset_expr + offset_reserved in + let offset_align = (offset_full + 15) / 16 * 16 in + res + |> add_fun id (List.length args) + |> save_args (-offset_full) args + >>= fun (s_argsi, env) -> + Result ([], None, env) + |> build_aexpr (Id "") e + >>= fun (e_instr, reg, _) -> + (match reg with + | None -> Error "Void?" + | Some reg -> + Result + ( (Tag (filter_tag id) + :: [ Mathi (Add, Sp, Sp, ImmInt (-offset_align)) + ; Sd (Ra, ImmInt (offset_full - 8), Sp) + ; Sd (S 0, ImmInt (offset_full - 16), Sp) + ; Mathi (Add, S 0, Sp, ImmInt offset_align) + ]) + @ s_argsi + @ e_instr + @ [ Mv (A 0, reg) + ; Ld (Ra, ImmInt (offset_full - 8), Sp) + ; Ld (S 0, ImmInt (offset_full - 16), Sp) + ; Mathi (Add, Sp, Sp, ImmInt offset_align) + ; Ret + ] + , [ id, List.length args ] )) +;; + +let head = + [ Attribute "unaligned_access, 0" + ; Attribute "stack_align, 16" + ; Global "_start" + ; Tag "_start" + ; Mathi (Add, Sp, Sp, ImmInt (-24)) + ; Sd (Ra, ImmInt 16, Sp) + ; Sd (S 0, ImmInt 8, Sp) + ; Sd (S 1, ImmInt 0, Sp) + ; Mathi (Add, S 0, Sp, ImmInt 24) + ; Call (Id "init_part_apps") + ; Call (Id "main") + ; Ld (Ra, ImmInt 16, Sp) + ; Ld (S 0, ImmInt 8, Sp) + ; Ld (S 1, ImmInt 0, Sp) + ; Mathi (Add, Sp, Sp, ImmInt 24) + ; Li (A 7, ImmInt exit) + ; Ecall + ] +;; + +let default_res = + Result + ( -24 + , [] + , [] + , [ T 0; T 1; T 2; T 3; T 4; T 5; T 6; A 0; A 1; A 2; A 3; A 4; A 5; A 6; A 7 ] + , [] + , default_func ) +;; + +(* let asm anf = + List.fold_left (fun prog r -> prog >>= (fun prog -> r >>= (fun (a, _)->Result(prog@a)))) (Result []) + (List.map (init_fun default_res) anf) + ;; *) +let asm anf_lst = + List.fold_left + (fun r anf -> + r + >>= fun (prog, p_f) -> + default_res + |> update_funs (fun d -> d @ p_f) + |> init_fun anf + >>= fun (instr, f) -> Result (prog @ instr, p_f @ f)) + (Result (head, [])) + anf_lst + >>= fun (prog, _) -> Result prog +;; diff --git a/slarnML/lib/riscv64/riscv_ast.ml b/slarnML/lib/riscv64/riscv_ast.ml new file mode 100644 index 000000000..fd8823da5 --- /dev/null +++ b/slarnML/lib/riscv64/riscv_ast.ml @@ -0,0 +1,71 @@ +type reg = + | Zero (* Вечный и неизменный ноль *) + | Ra (* Адрес возврата *) + | Sp (* Stack pointer, указатель стека *) + | S of int (* Рабочие регистры 0-11 *) + | A of int (* Аргументы функции 0-7 / Возвращаемое значение функции 0,1 *) + | T of int (* Временные регистры 0-6 *) +[@@deriving show { with_path = false }] + +type imm = + | ImmInt of int + | ConstAddr of string * string +[@@deriving show { with_path = false }] + +type addr = + | Id of string + | Reg of reg +[@@deriving show { with_path = false }] + +type cond = + | Beq (* if(r1==r2)goto addr *) + | Bge (* if(r1>=r2)goto addr *) + | Bgt (* if(r1>r2)goto addr *) + | Blt (* if(r1=r2)goto addr *) + | Bne (* if(r1!=r2)goto addr *) +[@@deriving show { with_path = false }] + +type math_i = + | Add (* + *) + | And (* & *) + | Sll (* << *) + | Srl (* >> *) + | Or (* | *) + | Xor (* ^ *) + +type math_op = + | I of math_i + | Mul (* * *) + | Sub (* - *) + | Div (* / *) +[@@deriving show { with_path = false }] + +type instruction = + | Attribute of string + | Global of string + | Tag of string + | Math of math_op * reg * reg * reg (* rd = r1 (op) r2 *) + | Mathi of math_i * reg * reg * imm (* rd = r1 (op) N *) + | Beqz of reg * addr (* if(r1==0)goto addr *) + | Bnez of reg * addr (* if(r1!=0)goto addr *) + | Bnch of cond * reg * reg * addr (* if(r1 ? r2)goto addr *) + | Call of addr (* вызов функции func *) + | Jmp of addr (* goto addr *) + | La of reg * addr (* rd = addr *) + | Li of reg * imm (* rd = N *) + | Mv of reg * reg (* rd = rs *) + | Ret (* возврат из функции *) + | Ld of reg * imm * reg (* считать 8 байта по адресу r1+N *) + | Sd of reg * imm * reg (* записать 8 байта по адресу r1+N *) + | Lui of reg * imm + | Ecall +(* Unused + | Lb of reg * int * reg (* считать 1 байт по адресу r1+N *) + | Lh of reg * int * reg (* cчитать 2 байта по адресу r1+N *) + | Lw of reg * int * reg (* считать 4 байта по адресу r1+N *) + | Sb of reg * int * reg (* записать 1 байт по адресу r1+N *) + | Sh of reg * int * reg (* записать 2 байта по адресу r1+N *) + | Sw of reg * int * reg (* записать 4 байта по адресу r1+N *) +*) +[@@deriving show { with_path = false }] diff --git a/slarnML/lib/test/anf_test.ml b/slarnML/lib/test/anf_test.ml new file mode 100644 index 000000000..776ea10ef --- /dev/null +++ b/slarnML/lib/test/anf_test.ml @@ -0,0 +1,496 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +open Res + +(*==============================*) +(*======Closure conversion======*) +(*==============================*) +open Ast +open Cc_ast +open Clos_conv +open Pprint_cc + +let cc_ok n res expected = + match res with + | Result c_ast when c_ast = expected -> true + | Result c_ast -> + print_string + @@ String.concat + "" + [ n + ; ":\n" + ; String.concat "\n" (List.map pp_cc_expr c_ast) + ; "\n" + ; String.concat "\n" (List.map pp_cc_expr expected) + ; "\n====\n" + ]; + false + | Error e -> + Printf.printf "%s: %s\n" n e; + false +;; + +let ast1 = + [ Let + ( Decl ("fac", [ "n" ]) + , LetIn + ( DeclRec ("fack", [ "n"; "k" ]) + , If + ( Lte (Id "n", Const (CInt 1)) + , App (Id "n", [ Sub (Id "n", Const (CInt 1)) ]) + , Fun ([ "m" ], Mul (Id "k", Mul (Id "m", Id "n"))) ) + , App (Id "fack", [ Id "n"; Fun ([ "x" ], Id "x") ]) ) ) + ] +;; + +let cc1 = + [ CLet + ( Decl ("fac", [ "n" ]) + , CLetIn + ( DeclRec ("fack", [ "n"; "k" ]) + , CIf + ( CLte (CId "n", CConst (CInt 1)) + , CApp (CApp (CId "n", []), [ CSub (CId "n", CConst (CInt 1)) ]) + , CApp + ( CFun ([ "k"; "n"; "m" ], CMul (CId "k", CMul (CId "m", CId "n"))) + , [ CId "k"; CId "n" ] ) ) + , CApp (CApp (CId "fack", []), [ CId "n"; CApp (CFun ([ "x" ], CId "x"), []) ]) + ) ) + ] +;; + +let%test _ = cc_ok "cc_1" (clos_conv ast1) cc1 + +let ast2 = + [ Let + ( Decl ("f", [ "a" ]) + , LetIn + ( Decl ("g", [ "c"; "d" ]) + , LetIn + ( Decl ("h", [ "e" ]) + , Mul (Id "a", Add (Id "c", Mul (Id "d", Id "e"))) + , App (Id "h", [ Const (CInt 4) ]) ) + , App (Id "g", [ Const (CInt 2); Const (CInt 3) ]) ) ) + ] +;; + +let cc2 = + [ CLet + ( Decl ("f", [ "a" ]) + , CLetIn + ( Decl ("g", [ "a"; "c"; "d" ]) + , CLetIn + ( Decl ("h", [ "a"; "c"; "d"; "e" ]) + , CMul (CId "a", CAdd (CId "c", CMul (CId "d", CId "e"))) + , CApp (CApp (CId "h", [ CId "a"; CId "c"; CId "d" ]), [ CConst (CInt 4) ]) + ) + , CApp (CApp (CId "g", [ CId "a" ]), [ CConst (CInt 2); CConst (CInt 3) ]) ) ) + ] +;; + +let%test _ = cc_ok "cc_2" (clos_conv ast2) cc2 + +let ast3 = + [ Let + ( Decl ("f", [ "a"; "b" ]) + , LetIn + ( Decl ("g", [ "c" ]) + , LetIn + ( Decl ("h", []) + , Fun ([ "x" ], Mul (Id "x", App (Id "a", [ Mul (Id "c", Id "b") ]))) + , App (Id "h", [ Id "a" ]) ) + , App (Id "g", [ Const (CInt 3) ]) ) ) + ] +;; + +let cc3 = + [ CLet + ( Decl ("f", [ "a"; "b" ]) + , CLetIn + ( Decl ("g", [ "b"; "a"; "c" ]) + , CLetIn + ( Decl ("h", [ "c"; "b"; "a" ]) + , CApp + ( CFun + ( [ "c"; "b"; "a"; "x" ] + , CMul + (CId "x", CApp (CApp (CId "a", []), [ CMul (CId "c", CId "b") ])) + ) + , [ CId "c"; CId "b"; CId "a" ] ) + , CApp (CApp (CId "h", [ CId "c"; CId "b"; CId "a" ]), [ CId "a" ]) ) + , CApp (CApp (CId "g", [ CId "b"; CId "a" ]), [ CConst (CInt 3) ]) ) ) + ] +;; + +let%test _ = cc_ok "cc_3" (clos_conv ast3) cc3 + +let ast4 = + [ Let + ( Decl ("f", [ "a" ]) + , LetIn + ( Decl ("g", [ "a"; "b" ]) + , LetIn + ( Decl ("h", [ "b"; "c" ]) + , Mul (Id "a", Div (Id "b", Id "c")) + , App (Id "h", [ Const (CInt 2); Const (CInt 3) ]) ) + , App (Id "g", [ Add (Const (CInt 1), Const (CInt 0)); Id "a" ]) ) ) + ] +;; + +let cc4 = + [ CLet + ( Decl ("f", [ "a" ]) + , CLetIn + ( Decl ("g", [ "a"; "b" ]) + , CLetIn + ( Decl ("h", [ "a"; "b"; "c" ]) + , CMul (CId "a", CDiv (CId "b", CId "c")) + , CApp (CApp (CId "h", [ CId "a" ]), [ CConst (CInt 2); CConst (CInt 3) ]) + ) + , CApp (CApp (CId "g", []), [ CAdd (CConst (CInt 1), CConst (CInt 0)); CId "a" ]) + ) ) + ] +;; + +let%test _ = cc_ok "cc_4" (clos_conv ast4) cc4 + +let ast5 = + [ Let + ( Decl ("f", [ "a" ]) + , LetIn + ( Decl ("g", [ "b" ]) + , Div (Id "a", Id "b") + , LetIn + ( Decl ("h", [ "c" ]) + , Mul (Id "a", Id "c") + , Add (App (Id "h", [ Const (CInt 1) ]), App (Id "g", [ Const (CInt 2) ])) + ) ) ) + ] +;; + +let cc5 = + [ CLet + ( Decl ("f", [ "a" ]) + , CLetIn + ( Decl ("g", [ "a"; "b" ]) + , CDiv (CId "a", CId "b") + , CLetIn + ( Decl ("h", [ "a"; "c" ]) + , CMul (CId "a", CId "c") + , CAdd + ( CApp (CApp (CId "h", [ CId "a" ]), [ CConst (CInt 1) ]) + , CApp (CApp (CId "g", [ CId "a" ]), [ CConst (CInt 2) ]) ) ) ) ) + ] +;; + +let%test _ = cc_ok "cc_5" (clos_conv ast5) cc5 + +let ast6 = + [ Let + ( Decl ("f", [ "a" ]) + , LetIn + ( Decl ("g", []) + , Fun ([ "x" ], Id "x") + , LetIn + ( Decl ("h", []) + , Fun ([ "x" ], Mul (Id "a", Id "x")) + , Add (App (Id "g", [ Id "a" ]), App (Id "h", [ Id "a" ])) ) ) ) + ] +;; + +let cc6 = + [ CLet + ( Decl ("f", [ "a" ]) + , CLetIn + ( Decl ("g", []) + , CApp (CFun ([ "x" ], CId "x"), []) + , CLetIn + ( Decl ("h", [ "a" ]) + , CApp (CFun ([ "a"; "x" ], CMul (CId "a", CId "x")), [ CId "a" ]) + , CAdd + ( CApp (CApp (CId "g", []), [ CId "a" ]) + , CApp (CApp (CId "h", [ CId "a" ]), [ CId "a" ]) ) ) ) ) + ] +;; + +let%test _ = cc_ok "cc_6" (clos_conv ast6) cc6 + +(*==========================*) +(*======Lambda lifting======*) +(*==========================*) +open Ll_ast +open Lambda_lifting +open Pprint_ll + +let ll_ok n res expected = + match res with + | Result l_ast when l_ast = expected -> true + | Result l_ast -> + print_string + @@ String.concat + "" + [ n + ; ":\n" + ; String.concat "\n" (List.map pp_gl_expr l_ast) + ; "\n---\n" + ; String.concat "\n" (List.map pp_gl_expr expected) + ; "\n====\n" + ]; + false + | Error e -> + Printf.printf "%s: %s\n" n e; + false +;; + +let ll1 = + [ LFun ("anon$1#fack#fac", [ "k"; "n"; "m" ], LMul (LId "k", LMul (LId "m", LId "n"))) + ; LFun + ( "fack#fac" + , [ "n"; "k" ] + , LIf + ( LLte (LId "n", LConst (CInt 1)) + , LApp ("n", [ LSub (LId "n", LConst (CInt 1)) ]) + , LApp ("anon$1#fack#fac", [ LId "k"; LId "n" ]) ) ) + ; LFun ("anon$2#fac", [ "x" ], LId "x") + ; LFun ("fac", [ "n" ], LApp ("fack#fac", [ LId "n"; LApp ("anon$2#fac", []) ])) + ] +;; + +ll_ok "ll_1" (lambda_lifting cc1) ll1 + +let ll2 = + [ LFun + ( "h#g#f" + , [ "a"; "c"; "d"; "e" ] + , LMul (LId "a", LAdd (LId "c", LMul (LId "d", LId "e"))) ) + ; LFun + ( "g#f" + , [ "a"; "c"; "d" ] + , LApp ("h#g#f", [ LId "a"; LId "c"; LId "d"; LConst (CInt 4) ]) ) + ; LFun ("f", [ "a" ], LApp ("g#f", [ LId "a"; LConst (CInt 2); LConst (CInt 3) ])) + ] +;; + +ll_ok "ll_2" (lambda_lifting cc2) ll2 + +let ll3 = + [ LFun + ( "anon$1#h#g#f" + , [ "c"; "b"; "a"; "x" ] + , LMul (LId "x", LApp ("a", [ LMul (LId "c", LId "b") ])) ) + ; LFun ("h#g#f", [ "c"; "b"; "a" ], LApp ("anon$1#h#g#f", [ LId "c"; LId "b"; LId "a" ])) + ; LFun ("g#f", [ "b"; "a"; "c" ], LApp ("h#g#f", [ LId "c"; LId "b"; LId "a"; LId "a" ])) + ; LFun ("f", [ "a"; "b" ], LApp ("g#f", [ LId "b"; LId "a"; LConst (CInt 3) ])) + ] +;; + +ll_ok "ll_3" (lambda_lifting cc3) ll3 + +let ll4 = + [ LFun ("h#g#f", [ "a"; "b"; "c" ], LMul (LId "a", LDiv (LId "b", LId "c"))) + ; LFun + ("g#f", [ "a"; "b" ], LApp ("h#g#f", [ LId "a"; LConst (CInt 2); LConst (CInt 3) ])) + ; LFun ("f", [ "a" ], LApp ("g#f", [ LAdd (LConst (CInt 1), LConst (CInt 0)); LId "a" ])) + ] +;; + +ll_ok "ll_4" (lambda_lifting cc4) ll4 + +let ll5 = + [ LFun ("g#f", [ "a"; "b" ], LDiv (LId "a", LId "b")) + ; LFun ("h#f", [ "a"; "c" ], LMul (LId "a", LId "c")) + ; LFun + ( "f" + , [ "a" ] + , LAdd + ( LApp ("h#f", [ LId "a"; LConst (CInt 1) ]) + , LApp ("g#f", [ LId "a"; LConst (CInt 2) ]) ) ) + ] +;; + +ll_ok "ll_5" (lambda_lifting cc5) ll5 + +let ll6 = + [ LFun ("anon$1#g#f", [ "x" ], LId "x") + ; LFun ("g#f", [], LApp ("anon$1#g#f", [])) + ; LFun ("anon$2#h#f", [ "a"; "x" ], LMul (LId "a", LId "x")) + ; LFun ("h#f", [ "a" ], LApp ("anon$2#h#f", [ LId "a" ])) + ; LFun + ("f", [ "a" ], LAdd (LApp ("g#f", [ LId "a" ]), LApp ("h#f", [ LId "a"; LId "a" ]))) + ] +;; + +ll_ok "ll_6" (lambda_lifting cc6) ll6 + +(*=========================*) +(*===========ANF===========*) +(*=========================*) +open Anf_ast +open Anf_conv +open Pprint_anf + +let anf_ok n ll expected = + let _ = clear_free () in + match anf ll with + | l_ast when l_ast = expected -> true + | l_ast -> + print_string + @@ String.concat + "" + [ n + ; ":\n" + ; String.concat "\n" (List.map pp_anf_afun l_ast) + ; "\n---\n" + ; String.concat "\n" (List.map pp_anf_afun expected) + ; "\n====\n" + ]; + false +;; + +let anf1 = + [ AFun + ( "anon$1#fack#fac" + , [ "k"; "n"; "m" ] + , ALet + ( "anf_op#1" + , AMul (AId "m", AId "n") + , ALet + ( "anf_op#2" + , AMul (AId "k", AId "anf_op#1") + , ACExpr (CImmExpr (AId "anf_op#2")) ) ) ) + ; AFun + ( "fack#fac" + , [ "n"; "k" ] + , ALet + ( "anf_op#3" + , ALte (AId "n", AInt 1) + , ALet + ( "anf_if#4" + , AIf + ( AId "anf_op#3" + , ALet + ( "anf_op#5" + , ASub (AId "n", AInt 1) + , ALet + ( "anf_app#6" + , AApp (AId "n", [ AId "anf_op#5" ]) + , ACExpr (CImmExpr (AId "anf_app#6")) ) ) + , ALet + ( "anf_app#7" + , AApp (AId "anon$1#fack#fac", [ AId "k"; AId "n" ]) + , ACExpr (CImmExpr (AId "anf_app#7")) ) ) + , ACExpr (CImmExpr (AId "anf_if#4")) ) ) ) + ; AFun ("anon$2#fac", [ "x" ], ACExpr (CImmExpr (AId "x"))) + ; AFun + ( "fac" + , [ "n" ] + , ALet + ( "anf_app#8" + , AApp (AId "anon$2#fac", []) + , ALet + ( "anf_app#9" + , AApp (AId "fack#fac", [ AId "n"; AId "anf_app#8" ]) + , ACExpr (CImmExpr (AId "anf_app#9")) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_1" ll1 anf1 + +let anf4 = + [ AFun + ( "h#g#f" + , [ "a"; "b"; "c" ] + , ALet + ( "anf_op#1" + , ADiv (AId "b", AId "c") + , ALet + ( "anf_op#2" + , AMul (AId "a", AId "anf_op#1") + , ACExpr (CImmExpr (AId "anf_op#2")) ) ) ) + ; AFun + ( "g#f" + , [ "a"; "b" ] + , ALet + ( "anf_app#3" + , AApp (AId "h#g#f", [ AId "a"; AInt 2; AInt 3 ]) + , ACExpr (CImmExpr (AId "anf_app#3")) ) ) + ; AFun + ( "f" + , [ "a" ] + , ALet + ( "anf_op#4" + , AAdd (AInt 1, AInt 0) + , ALet + ( "anf_app#5" + , AApp (AId "g#f", [ AId "anf_op#4"; AId "a" ]) + , ACExpr (CImmExpr (AId "anf_app#5")) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_4" ll4 anf4 + +let anf5 = + [ AFun + ( "g#f" + , [ "a"; "b" ] + , ALet ("anf_op#1", ADiv (AId "a", AId "b"), ACExpr (CImmExpr (AId "anf_op#1"))) ) + ; AFun + ( "h#f" + , [ "a"; "c" ] + , ALet ("anf_op#2", AMul (AId "a", AId "c"), ACExpr (CImmExpr (AId "anf_op#2"))) ) + ; AFun + ( "f" + , [ "a" ] + , ALet + ( "anf_app#3" + , AApp (AId "h#f", [ AId "a"; AInt 1 ]) + , ALet + ( "anf_app#4" + , AApp (AId "g#f", [ AId "a"; AInt 2 ]) + , ALet + ( "anf_op#5" + , AAdd (AId "anf_app#3", AId "anf_app#4") + , ACExpr (CImmExpr (AId "anf_op#5")) ) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_5" ll5 anf5 + +let anf6 = + [ AFun ("anon$1#g#f", [ "x" ], ACExpr (CImmExpr (AId "x"))) + ; AFun + ( "g#f" + , [] + , ALet + ("anf_app#1", AApp (AId "anon$1#g#f", []), ACExpr (CImmExpr (AId "anf_app#1"))) + ) + ; AFun + ( "anon$2#h#f" + , [ "a"; "x" ] + , ALet ("anf_op#2", AMul (AId "a", AId "x"), ACExpr (CImmExpr (AId "anf_op#2"))) ) + ; AFun + ( "h#f" + , [ "a" ] + , ALet + ( "anf_app#3" + , AApp (AId "anon$2#h#f", [ AId "a" ]) + , ACExpr (CImmExpr (AId "anf_app#3")) ) ) + ; AFun + ( "f" + , [ "a" ] + , ALet + ( "anf_app#4" + , AApp (AId "g#f", [ AId "a" ]) + , ALet + ( "anf_app#5" + , AApp (AId "h#f", [ AId "a"; AId "a" ]) + , ALet + ( "anf_op#6" + , AAdd (AId "anf_app#4", AId "anf_app#5") + , ACExpr (CImmExpr (AId "anf_op#6")) ) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_6" ll6 anf6 diff --git a/slarnML/slarnML.opam b/slarnML/slarnML.opam new file mode 100644 index 000000000..468d9889a --- /dev/null +++ b/slarnML/slarnML.opam @@ -0,0 +1,38 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "0.0" +synopsis: "SlarnML" +maintainer: ["Ivan Shurenkov"] +authors: ["Ivan Shurenkov"] +license: "LGPL-3.0-or-later" +homepage: "https://github.com/ioannessh/comp24" +bug-reports: "https://github.com/ioannessh/comp24/issues" +depends: [ + "ocaml" + "dune" {>= "2.9"} + "angstrom" + "base" + "ppx_inline_test" {with-test} + "ppx_expect" + "ppx_deriving" + "bisect_ppx" + "odoc" {with-doc} + "ocamlformat" {build} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] +] +dev-repo: "git+https://github.com/ioannessh/comp24.git" diff --git a/slarnML/test/anf_conv_test.ml b/slarnML/test/anf_conv_test.ml new file mode 100644 index 000000000..27fcc56a5 --- /dev/null +++ b/slarnML/test/anf_conv_test.ml @@ -0,0 +1,17 @@ +open SlarnML_lib.Res + +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + let result = + match SlarnML_lib.Parser.parser s with + | Ok ast -> + SlarnML_lib.Clos_conv.clos_conv ast + >>= (fun ast -> SlarnML_lib.Lambda_lifting.lambda_lifting ast) + >>= fun ast -> Result (SlarnML_lib.Anf_conv.anf ast) + | Error message -> SlarnML_lib.Res.Error message + in + match result with + | SlarnML_lib.Res.Result r -> + print_string @@ String.concat "\n" (List.map SlarnML_lib.Pprint_anf.pp_anf_afun r) + | Error e -> Printf.eprintf "%s" e +;; diff --git a/slarnML/test/anf_conv_test.t b/slarnML/test/anf_conv_test.t new file mode 100644 index 000000000..9b20f5e67 --- /dev/null +++ b/slarnML/test/anf_conv_test.t @@ -0,0 +1,712 @@ + $ dune exec anf_conv_test << EOF + > let fac n = + > let rec fack n f = if (n <= 1) then (f 1) else (fack (n - 1) (fun x -> x * (f n))) in + > (fack n (fun x -> x)) + > ;; + > EOF + (fun anon$1(n f x)-> + (let anf_app#1=(n ) + in + (let anf_app#2=(f anf_app#1) + in + (let anf_op#3=(x*anf_app#2) + in + anf_op#3))) + ) + (fun fack(n f)-> + (let anf_op#4=(n<=1) + in + (let anf_if#5=if (anf_op#4) + then ( + (let anf_app#6=(f 1) + in + anf_app#6) + ) else ( + (let anf_op#7=(n-1) + in + (let anf_app#8=(n ) + in + (let anf_app#9=(f ) + in + (let anf_app#10=(anon$1 anf_app#8 anf_app#9) + in + (let anf_app#11=(fack anf_op#7 anf_app#10) + in + anf_app#11)))))) + in + anf_if#5)) + ) + (fun anon$2(x)-> + x + ) + (fun fac(n)-> + (let anf_op#12=(n<=1) + in + (let anf_if#13=if (anf_op#12) + then ( + (let anf_app#14=(f 1) + in + anf_app#14) + ) else ( + (let anf_op#15=(n-1) + in + (let anf_app#16=(n ) + in + (let anf_app#17=(f ) + in + (let anf_app#18=(anon$1 anf_app#16 anf_app#17) + in + (let anf_app#19=(fack anf_op#15 anf_app#18) + in + anf_app#19)))))) + in + (let anf_fack#20=(anf_if#13 ) + in + (let anf_app#21=(n ) + in + (let anf_app#22=(anon$2 ) + in + (let anf_app#23=(fack anf_app#21 anf_app#22) + in + anf_app#23)))))) + ) + $ dune exec anf_conv_test << EOF + > let fac n = + > let rec fack n = if (n < 1) then n else n * (fack (n - 1)) in + > (fack n) + > ;; + > EOF + (fun fack(n)-> + (let anf_op#1=(n<1) + in + (let anf_if#2=if (anf_op#1) + then ( + n + ) else ( + (let anf_op#3=(n-1) + in + (let anf_app#4=(fack anf_op#3) + in + (let anf_op#5=(n*anf_app#4) + in + anf_op#5)))) + in + anf_if#2)) + ) + (fun fac(n)-> + (let anf_op#6=(n<1) + in + (let anf_if#7=if (anf_op#6) + then ( + n + ) else ( + (let anf_op#8=(n-1) + in + (let anf_app#9=(fack anf_op#8) + in + (let anf_op#10=(n*anf_app#9) + in + anf_op#10)))) + in + (let anf_fack#11=(anf_if#7 ) + in + (let anf_app#12=(n ) + in + (let anf_app#13=(fack anf_app#12) + in + anf_app#13))))) + ) + $ dune exec anf_conv_test << EOF + > let f a = + > let g c d = + > let h e = a * (c + d * e) in + > (h 4) + > in + > (g 2 3) + > EOF + (fun h(a c d e)-> + (let anf_app#1=(a ) + in + (let anf_app#2=(c ) + in + (let anf_app#3=(d ) + in + (let anf_app#4=(e ) + in + (let anf_op#5=(anf_app#3*anf_app#4) + in + (let anf_op#6=(anf_app#2+anf_op#5) + in + (let anf_op#7=(anf_app#1*anf_op#6) + in + anf_op#7))))))) + ) + (fun g(a c d)-> + (let anf_app#8=(a ) + in + (let anf_app#9=(c ) + in + (let anf_app#10=(d ) + in + (let anf_app#11=(e ) + in + (let anf_op#12=(anf_app#10*anf_app#11) + in + (let anf_op#13=(anf_app#9+anf_op#12) + in + (let anf_op#14=(anf_app#8*anf_op#13) + in + (let anf_h#15=(anf_op#14 ) + in + (let anf_app#16=(a ) + in + (let anf_app#17=(c ) + in + (let anf_app#18=(d ) + in + (let anf_app#19=(h anf_app#16 anf_app#17 anf_app#18 4) + in + anf_app#19)))))))))))) + ) + (fun f(a)-> + (let anf_app#20=(a ) + in + (let anf_app#21=(c ) + in + (let anf_app#22=(d ) + in + (let anf_app#23=(e ) + in + (let anf_op#24=(anf_app#22*anf_app#23) + in + (let anf_op#25=(anf_app#21+anf_op#24) + in + (let anf_op#26=(anf_app#20*anf_op#25) + in + (let anf_h#27=(anf_op#26 ) + in + (let anf_app#28=(a ) + in + (let anf_app#29=(c ) + in + (let anf_app#30=(d ) + in + (let anf_app#31=(h anf_app#28 anf_app#29 anf_app#30 4) + in + (let anf_g#32=(anf_app#31 ) + in + (let anf_app#33=(a ) + in + (let anf_app#34=(g anf_app#33 2 3) + in + anf_app#34))))))))))))))) + ) + $ dune exec anf_conv_test < manytests/do_not_type/001.ml + fac not exist + $ dune exec anf_conv_test < manytests/do_not_type/002if.ml + (fun main()-> + (let anf_if#1=if (true) + then ( + 1 + ) else ( + false) + in + anf_if#1) + ) + $ dune exec anf_conv_test < manytests/do_not_type/003occurs.ml + f not exist + $ dune exec anf_conv_test < manytests/typed/001fac.ml + (fun fac(n)-> + (let anf_op#1=(n<=1) + in + (let anf_if#2=if (anf_op#1) + then ( + 1 + ) else ( + (let anf_op#3=(n-1) + in + (let anf_app#4=(fac anf_op#3) + in + (let anf_op#5=(n*anf_app#4) + in + anf_op#5)))) + in + anf_if#2)) + ) + (fun main()-> + (let anf_app#6=(fac 4) + in + (let anf_app#7=(print_int anf_app#6) + in + (let anf_()#8=(anf_app#7 ) + in + 0))) + ) + $ dune exec anf_conv_test < manytests/typed/002fac.ml + (fun anon$1(n k p)-> + (let anf_op#1=(p*n) + in + (let anf_app#2=(k anf_op#1) + in + anf_app#2)) + ) + (fun fac_cps(n k)-> + (let anf_op#3=(n=1) + in + (let anf_if#4=if (anf_op#3) + then ( + (let anf_app#5=(k 1) + in + anf_app#5) + ) else ( + (let anf_op#6=(n-1) + in + (let anf_app#7=(n ) + in + (let anf_app#8=(k ) + in + (let anf_app#9=(anon$1 anf_app#7 anf_app#8) + in + (let anf_app#10=(fac_cps anf_op#6 anf_app#9) + in + anf_app#10)))))) + in + anf_if#4)) + ) + (fun anon$1(print_int)-> + print_int + ) + (fun main()-> + (let anf_app#11=(anon$1 ) + in + (let anf_app#12=(fac_cps 4 anf_app#11) + in + (let anf_app#13=(print_int anf_app#12) + in + (let anf_()#14=(anf_app#13 ) + in + 0)))) + ) + $ dune exec anf_conv_test < manytests/typed/003fib.ml + (fun n1(n)-> + (let anf_op#1=(n-1) + in + anf_op#1) + ) + (fun ab(a b)-> + (let anf_op#2=(a+b) + in + anf_op#2) + ) + (fun fib_acc(a b n)-> + (let anf_op#3=(n=1) + in + (let anf_if#4=if (anf_op#3) + then ( + b + ) else ( + (let anf_op#5=(n-1) + in + (let anf_n1#6=(anf_op#5 ) + in + (let anf_op#7=(a+b) + in + (let anf_ab#8=(anf_op#7 ) + in + (let anf_app#9=(b ) + in + (let anf_app#10=(ab ) + in + (let anf_app#11=(n1 ) + in + (let anf_app#12=(fib_acc anf_app#9 anf_app#10 anf_app#11) + in + anf_app#12))))))))) + in + anf_if#4)) + ) + (fun fib(n)-> + (let anf_op#13=(n<2) + in + (let anf_if#14=if (anf_op#13) + then ( + n + ) else ( + (let anf_op#15=(n-1) + in + (let anf_op#16=(n-2) + in + (let anf_app#17=(fib anf_op#16) + in + (let anf_op#18=(anf_op#15+anf_app#17) + in + (let anf_app#19=(fib anf_op#18) + in + anf_app#19)))))) + in + anf_if#14)) + ) + (fun main()-> + (let anf_app#20=(fib_acc 0 1 4) + in + (let anf_app#21=(print_int anf_app#20) + in + (let anf_()#22=(anf_app#21 ) + in + (let anf_app#23=(fib 4) + in + (let anf_app#24=(print_int anf_app#23) + in + (let anf_()#25=(anf_app#24 ) + in + 0)))))) + ) + $ dune exec anf_conv_test < manytests/typed/004manyargs.ml + (fun wrap(f)-> + (let anf_op#1=(1=1) + in + (let anf_if#2=if (anf_op#1) + then ( + (let anf_app#3=(f ) + in + anf_app#3) + ) else ( + (let anf_app#4=(f ) + in + anf_app#4)) + in + anf_if#2)) + ) + (fun a(a)-> + (let anf_app#5=(a ) + in + (let anf_app#6=(print_int anf_app#5) + in + anf_app#6)) + ) + (fun b(b)-> + (let anf_app#7=(b ) + in + (let anf_app#8=(print_int anf_app#7) + in + anf_app#8)) + ) + (fun c(c)-> + (let anf_app#9=(c ) + in + (let anf_app#10=(print_int anf_app#9) + in + anf_app#10)) + ) + (fun test3(a b c)-> + (let anf_app#11=(a ) + in + (let anf_app#12=(print_int anf_app#11) + in + (let anf_a#13=(anf_app#12 ) + in + (let anf_app#14=(b ) + in + (let anf_app#15=(print_int anf_app#14) + in + (let anf_b#16=(anf_app#15 ) + in + (let anf_app#17=(c ) + in + (let anf_app#18=(print_int anf_app#17) + in + (let anf_c#19=(anf_app#18 ) + in + 0))))))))) + ) + (fun test10(a b c d e f g h i j)-> + (let anf_app#20=(a ) + in + (let anf_app#21=(b ) + in + (let anf_op#22=(anf_app#20+anf_app#21) + in + (let anf_app#23=(c ) + in + (let anf_op#24=(anf_op#22+anf_app#23) + in + (let anf_app#25=(d ) + in + (let anf_op#26=(anf_op#24+anf_app#25) + in + (let anf_app#27=(e ) + in + (let anf_op#28=(anf_op#26+anf_app#27) + in + (let anf_app#29=(f ) + in + (let anf_op#30=(anf_op#28+anf_app#29) + in + (let anf_app#31=(g ) + in + (let anf_op#32=(anf_op#30+anf_app#31) + in + (let anf_app#33=(h ) + in + (let anf_op#34=(anf_op#32+anf_app#33) + in + (let anf_app#35=(i ) + in + (let anf_op#36=(anf_op#34+anf_app#35) + in + (let anf_app#37=(j ) + in + (let anf_op#38=(anf_op#36+anf_app#37) + in + anf_op#38))))))))))))))))))) + ) + (fun rez()-> + (let anf_app#39=(test10 ) + in + (let anf_app#40=(wrap anf_app#39 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000) + in + anf_app#40)) + ) + (fun temp2()-> + (let anf_app#41=(test3 ) + in + (let anf_app#42=(wrap anf_app#41 1 10 100) + in + anf_app#42)) + ) + (fun main()-> + (let anf_app#43=(test10 ) + in + (let anf_app#44=(wrap anf_app#43 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000) + in + (let anf_rez#45=(anf_app#44 ) + in + (let anf_app#46=(rez ) + in + (let anf_app#47=(print_int anf_app#46) + in + (let anf_()#48=(anf_app#47 ) + in + (let anf_app#49=(test3 ) + in + (let anf_app#50=(wrap anf_app#49 1 10 100) + in + (let anf_temp2#51=(anf_app#50 ) + in + 0))))))))) + ) + $ dune exec anf_conv_test < manytests/typed/005fix.ml + (fun fix(f x)-> + (let anf_app#1=(f ) + in + (let anf_app#2=(fix anf_app#1) + in + (let anf_app#3=(x ) + in + (let anf_app#4=(f anf_app#2 anf_app#3) + in + anf_app#4)))) + ) + (fun fac(self n)-> + (let anf_app#5=(n ) + in + (let anf_op#6=(anf_app#5<=1) + in + (let anf_if#7=if (anf_op#6) + then ( + 1 + ) else ( + (let anf_app#8=(n ) + in + (let anf_app#9=(n ) + in + (let anf_op#10=(anf_app#9-1) + in + (let anf_app#11=(self anf_op#10) + in + (let anf_op#12=(anf_app#8*anf_app#11) + in + anf_op#12)))))) + in + anf_if#7))) + ) + (fun main()-> + (let anf_app#13=(fac ) + in + (let anf_app#14=(fix anf_app#13 6) + in + (let anf_app#15=(print_int anf_app#14) + in + (let anf_()#16=(anf_app#15 ) + in + 0)))) + ) + $ dune exec anf_conv_test < manytests/typed/006partial.ml + (fun anon$1(foo)-> + (let anf_op#1=(foo+2) + in + anf_op#1) + ) + (fun anon$2(foo)-> + (let anf_op#2=(foo*10) + in + anf_op#2) + ) + (fun foo(b)-> + (let anf_app#3=(b ) + in + (let anf_if#4=if (anf_app#3) + then ( + (let anf_app#5=(anon$1 ) + in + anf_app#5) + ) else ( + (let anf_app#6=(anon$2 ) + in + anf_app#6)) + in + anf_if#4)) + ) + (fun foo(x)-> + (let anf_app#7=(x ) + in + (let anf_app#8=(foo false anf_app#7) + in + (let anf_app#9=(foo true anf_app#8) + in + (let anf_app#10=(foo false anf_app#9) + in + (let anf_app#11=(foo true anf_app#10) + in + anf_app#11))))) + ) + (fun main()-> + (let anf_app#12=(foo 11) + in + (let anf_app#13=(print_int anf_app#12) + in + (let anf_()#14=(anf_app#13 ) + in + 0))) + ) + $ dune exec anf_conv_test < manytests/typed/006partial2.ml + (fun foo(a b c)-> + (let anf_app#1=(a ) + in + (let anf_app#2=(print_int anf_app#1) + in + (let anf_()#3=(anf_app#2 ) + in + (let anf_app#4=(b ) + in + (let anf_app#5=(print_int anf_app#4) + in + (let anf_()#6=(anf_app#5 ) + in + (let anf_app#7=(c ) + in + (let anf_app#8=(print_int anf_app#7) + in + (let anf_()#9=(anf_app#8 ) + in + (let anf_app#10=(a ) + in + (let anf_app#11=(b ) + in + (let anf_app#12=(c ) + in + (let anf_op#13=(anf_app#11*anf_app#12) + in + (let anf_op#14=(anf_app#10+anf_op#13) + in + anf_op#14)))))))))))))) + ) + (fun foo()-> + (let anf_app#15=(foo 1) + in + anf_app#15) + ) + (fun foo(foo)-> + (let anf_app#16=(foo ) + in + (let anf_app#17=(foo anf_app#16 2) + in + anf_app#17)) + ) + (fun foo(foo)-> + (let anf_app#18=(foo ) + in + (let anf_app#19=(foo anf_app#18 3) + in + anf_app#19)) + ) + (fun main()-> + (let anf_app#20=(foo 1) + in + (let anf_foo#21=(anf_app#20 ) + in + (let anf_app#22=(foo ) + in + (let anf_app#23=(foo anf_app#22 2) + in + (let anf_foo#24=(anf_app#23 ) + in + (let anf_app#25=(foo ) + in + (let anf_app#26=(foo anf_app#25 3) + in + (let anf_foo#27=(anf_app#26 ) + in + (let anf_app#28=(foo ) + in + (let anf_app#29=(print_int anf_app#28) + in + (let anf_()#30=(anf_app#29 ) + in + 0))))))))))) + ) + $ dune exec anf_conv_test < manytests/typed/006partial3.ml + (fun anon$2(c)-> + (let anf_app#1=(c ) + in + (let anf_app#2=(print_int anf_app#1) + in + anf_app#2)) + ) + (fun anon$1(b)-> + (let anf_app#3=(b ) + in + (let anf_app#4=(print_int anf_app#3) + in + (let anf_()#5=(anf_app#4 ) + in + (let anf_app#6=(anon$2 ) + in + anf_app#6)))) + ) + (fun foo(a)-> + (let anf_app#7=(a ) + in + (let anf_app#8=(print_int anf_app#7) + in + (let anf_()#9=(anf_app#8 ) + in + (let anf_app#10=(anon$1 ) + in + anf_app#10)))) + ) + (fun main()-> + (let anf_app#11=(foo 4 8 9) + in + (let anf_()#12=(anf_app#11 ) + in + 0)) + ) + $ dune exec anf_conv_test < manytests/typed/007order.ml + : end_of_input + $ dune exec anf_conv_test < manytests/typed/008ascription.ml + : end_of_input + $ dune exec anf_conv_test < manytests/typed/015tuples.ml + : end_of_input + $ dune exec anf_conv_test < manytests/typed/016lists.ml + : end_of_input diff --git a/slarnML/test/clos_conv_test.ml b/slarnML/test/clos_conv_test.ml new file mode 100644 index 000000000..9d5f17c68 --- /dev/null +++ b/slarnML/test/clos_conv_test.ml @@ -0,0 +1,12 @@ +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + let result = + match SlarnML_lib.Parser.parser s with + | Ok ast -> SlarnML_lib.Clos_conv.clos_conv ast + | Error message -> SlarnML_lib.Res.Error message + in + match result with + | SlarnML_lib.Res.Result r -> + print_string @@ String.concat "\n" (List.map SlarnML_lib.Pprint_cc.pp_cc_expr r) + | Error e -> Printf.eprintf "%s" e +;; diff --git a/slarnML/test/clos_conv_test.t b/slarnML/test/clos_conv_test.t new file mode 100644 index 000000000..46857d584 --- /dev/null +++ b/slarnML/test/clos_conv_test.t @@ -0,0 +1,69 @@ + $ dune exec clos_conv_test << EOF + > let fac n = + > let rec fack n f = if (n <= 1) then (f 1) else (fack (n - 1) (fun x -> x * (f n))) in + > (fack n (fun x -> x)) + > ;; + > EOF + (let fac n=(let rec fack n f=if ((n<=1)) then (((f ) 1)) else (((fack ) (n-1) ((fun n f x->(x*((f ) n))) n f))) in ((fack ) n ((fun x->x) )))) + $ dune exec clos_conv_test << EOF + > let fac n = + > let rec fack n = if (n < 1) then n else n * (fack (n - 1)) in + > (fack n) + > ;; + > EOF + (let fac n=(let rec fack n=if ((n<1)) then (n) else ((n*((fack ) (n-1)))) in ((fack ) n))) + $ dune exec clos_conv_test << EOF + > let f a = + > let g c d = + > let h e = a * (c + d * e) in + > (h 4) + > in + > (g 2 3) + > EOF + (let f a=(let g a c d=(let h a c d e=(a*(c+(d*e))) in ((h a c d) 4)) in ((g a) 2 3))) + $ dune exec clos_conv_test << EOF + > let rec fac n = if n<=1 then 1 else n * fac (n-1) + > + > let main = + > let () = print_int (fac 4) in + > 0 + > EOF + (let rec fac n=if ((n<=1)) then (1) else ((n*((fac ) (n-1))))) + (let main=(let ()=((print_int ) ((fac ) 4)) in 0)) + $ dune exec clos_conv_test < manytests/typed/001fac.ml + (let rec fac n=if ((n<=1)) then (1) else ((n*((fac ) (n-1))))) + (let main=(let ()=((print_int ) ((fac ) 4)) in 0)) + $ dune exec clos_conv_test < manytests/typed/002fac.ml + (let rec fac_cps n k=if ((n=1)) then (((k ) 1)) else (((fac_cps ) (n-1) ((fun n k p->((k ) (p*n))) n k)))) + (let main=(let ()=((print_int ) ((fac_cps ) 4 ((fun print_int->print_int) ))) in 0)) + $ dune exec clos_conv_test < manytests/typed/003fib.ml + (let rec fib_acc a b n=if ((n=1)) then (b) else ((let n1 n=(n-1) in (let ab a b=(a+b) in ((fib_acc ) b ab n1))))) + (let rec fib n=if ((n<2)) then (n) else (((fib ) ((n-1)+((fib ) (n-2)))))) + (let main=(let ()=((print_int ) ((fib_acc ) 0 1 4)) in (let ()=((print_int ) ((fib ) 4)) in 0))) + $ dune exec clos_conv_test < manytests/typed/004manyargs.ml + (let wrap f=if ((1=1)) then (f) else (f)) + (let test3 a b c=(let a a=((print_int ) a) in (let b b=((print_int ) b) in (let c c=((print_int ) c) in 0)))) + (let test10 a b c d e f g h i j=(((((((((a+b)+c)+d)+e)+f)+g)+h)+i)+j)) + (let main=(let rez=((wrap ) test10 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000) in (let ()=((print_int ) rez) in (let temp2=((wrap ) test3 1 10 100) in 0)))) + $ dune exec clos_conv_test < manytests/typed/005fix.ml + (let rec fix f x=((f ) ((fix ) f) x)) + (let fac self n=if ((n<=1)) then (1) else ((n*((self ) (n-1))))) + (let main=(let ()=((print_int ) ((fix ) fac 6)) in 0)) + $ dune exec clos_conv_test < manytests/typed/006partial.ml + (let foo b=if (b) then (((fun foo->(foo+2)) )) else (((fun foo->(foo*10)) ))) + (let foo x=((foo ) true ((foo ) false ((foo ) true ((foo ) false x))))) + (let main=(let ()=((print_int ) ((foo ) 11)) in 0)) + $ dune exec clos_conv_test < manytests/typed/006partial2.ml + (let foo a b c=(let ()=((print_int ) a) in (let ()=((print_int ) b) in (let ()=((print_int ) c) in (a+(b*c)))))) + (let main=(let foo=((foo ) 1) in (let foo foo=((foo foo) 2) in (let foo foo=((foo foo) 3) in (let ()=((print_int ) foo) in 0))))) + $ dune exec clos_conv_test < manytests/typed/006partial3.ml + (let foo a=(let ()=((print_int ) a) in ((fun b->(let ()=((print_int ) b) in ((fun c->((print_int ) c)) ))) ))) + (let main=(let ()=((foo ) 4 8 9) in 0)) + $ dune exec clos_conv_test < manytests/typed/007order.ml + : end_of_input + $ dune exec clos_conv_test < manytests/typed/008ascription.ml + : end_of_input + $ dune exec clos_conv_test < manytests/typed/015tuples.ml + : end_of_input + $ dune exec clos_conv_test < manytests/typed/016lists.ml + : end_of_input diff --git a/slarnML/test/dune b/slarnML/test/dune new file mode 100644 index 000000000..49cf44220 --- /dev/null +++ b/slarnML/test/dune @@ -0,0 +1,155 @@ +(executable + (name parser_test) + (public_name parser_test) + (modules parser_test) + (preprocess + (pps bisect_ppx)) + (libraries slarnML.lib stdio)) + +(executable + (name clos_conv_test) + (public_name clos_conv_test) + (modules clos_conv_test) + (preprocess + (pps bisect_ppx)) + (libraries slarnML.lib stdio)) + +(executable + (name lambda_lifting_test) + (public_name lambda_lifting_test) + (modules lambda_lifting_test) + (preprocess + (pps bisect_ppx)) + (libraries slarnML.lib stdio)) + +(executable + (name anf_conv_test) + (public_name anf_conv_test) + (modules anf_conv_test) + (preprocess + (pps bisect_ppx)) + (libraries slarnML.lib stdio)) + +(executable + (name riscv64_instr_test) + (public_name riscv64_instr_test) + (modules riscv64_instr_test) + (preprocess + (pps bisect_ppx)) + (libraries slarnML.lib stdio)) + +(cram + (applies_to parser_tests) + (deps + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to clos_conv_test) + (deps + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to lambda_lifting_test) + (deps + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to anf_conv_test) + (deps + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +(cram + (applies_to riscv64_instr_test) + (deps + manytests/do_not_type/001.ml + manytests/do_not_type/002if.ml + manytests/do_not_type/003occurs.ml + manytests/typed/001fac.ml + manytests/typed/002fac.ml + manytests/typed/003fib.ml + manytests/typed/004manyargs.ml + manytests/typed/005fix.ml + manytests/typed/006partial.ml + manytests/typed/006partial2.ml + manytests/typed/006partial3.ml + manytests/typed/007order.ml + manytests/typed/008ascription.ml + manytests/typed/015tuples.ml + manytests/typed/016lists.ml)) + +;(cram +; (applies_to exec_test) +; (deps +; ../lib/riscv64/print.S +; ../lib/riscv64/part_app.c +; manytests/do_not_type/001.ml +; manytests/do_not_type/002if.ml +; manytests/do_not_type/003occurs.ml +; manytests/typed/001fac.ml +; manytests/typed/002fac.ml +; manytests/typed/003fib.ml +; manytests/typed/004manyargs.ml +; manytests/typed/005fix.ml +; manytests/typed/006partial.ml +; manytests/typed/006partial2.ml +; manytests/typed/006partial3.ml +; manytests/typed/007order.ml +; manytests/typed/008ascription.ml +; manytests/typed/015tuples.ml +; manytests/typed/016lists.ml)) diff --git a/slarnML/test/exec_test.t_ b/slarnML/test/exec_test.t_ new file mode 100644 index 000000000..de4a63260 Binary files /dev/null and b/slarnML/test/exec_test.t_ differ diff --git a/slarnML/test/lambda_lifting_test.ml b/slarnML/test/lambda_lifting_test.ml new file mode 100644 index 000000000..92418e07f --- /dev/null +++ b/slarnML/test/lambda_lifting_test.ml @@ -0,0 +1,16 @@ +open SlarnML_lib.Res + +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + let result = + match SlarnML_lib.Parser.parser s with + | Ok ast -> + SlarnML_lib.Clos_conv.clos_conv ast + >>= fun ast -> SlarnML_lib.Lambda_lifting.lambda_lifting ast + | Error message -> SlarnML_lib.Res.Error message + in + match result with + | SlarnML_lib.Res.Result r -> + print_string @@ String.concat "\n" (List.map SlarnML_lib.Pprint_ll.pp_gl_expr r) + | Error e -> Printf.eprintf "%s" e +;; diff --git a/slarnML/test/lambda_lifting_test.t b/slarnML/test/lambda_lifting_test.t new file mode 100644 index 000000000..ed04be25b --- /dev/null +++ b/slarnML/test/lambda_lifting_test.t @@ -0,0 +1,88 @@ + $ dune exec lambda_lifting_test << EOF + > let fac n = + > let rec fack n f = if (n <= 1) then (f 1) else (fack (n - 1) (fun x -> x * (f n))) in + > (fack n (fun x -> x)) + > ;; + > EOF + (fun anon$1(n f x)->((x*(f (n ))))) + (fun fack(n f)->(if ((n<=1)) then ((f 1)) else ((fack (n-1) (anon$1 (n ) (f )))))) + (fun anon$2(x)->(x)) + (fun fac(n)->(let fack = (if ((n<=1)) then ((f 1)) else ((fack (n-1) (anon$1 (n ) (f )))) in (fack (n ) (anon$2 ))))) + $ dune exec lambda_lifting_test << EOF + > let fac n = + > let rec fack n = if (n < 1) then n else n * (fack (n - 1)) in + > (fack n) + > ;; + > EOF + (fun fack(n)->(if ((n<1)) then (n) else ((n*(fack (n-1)))))) + (fun fac(n)->(let fack = (if ((n<1)) then (n) else ((n*(fack (n-1)))) in (fack (n ))))) + $ dune exec lambda_lifting_test << EOF + > let f a = + > let g c d = + > let h e = a * (c + d * e) in + > (h 4) + > in + > (g 2 3) + > EOF + (fun h(a c d e)->(((a )*((c )+((d )*(e )))))) + (fun g(a c d)->(let h = (((a )*((c )+((d )*(e )))) in (h (a ) (c ) (d ) 4)))) + (fun f(a)->(let g = (let h = (((a )*((c )+((d )*(e )))) in (h (a ) (c ) (d ) 4)) in (g (a ) 2 3)))) + $ dune exec lambda_lifting_test < manytests/do_not_type/001.ml + fac not exist + $ dune exec lambda_lifting_test < manytests/do_not_type/002if.ml + (fun main()->(if (true) then (1) else (false))) + $ dune exec lambda_lifting_test < manytests/do_not_type/003occurs.ml + f not exist + $ dune exec lambda_lifting_test < manytests/typed/001fac.ml + (fun fac(n)->(if ((n<=1)) then (1) else ((n*(fac (n-1)))))) + (fun main()->(let () = ((print_int (fac 4)) in 0))) + $ dune exec lambda_lifting_test < manytests/typed/002fac.ml + (fun anon$1(n k p)->((k (p*n)))) + (fun fac_cps(n k)->(if ((n=1)) then ((k 1)) else ((fac_cps (n-1) (anon$1 (n ) (k )))))) + (fun anon$1(print_int)->(print_int)) + (fun main()->(let () = ((print_int (fac_cps 4 (anon$1 ))) in 0))) + $ dune exec lambda_lifting_test < manytests/typed/003fib.ml + (fun n1(n)->((n-1))) + (fun ab(a b)->((a+b))) + (fun fib_acc(a b n)->(if ((n=1)) then (b) else (let n1 = ((n-1) in let ab = ((a+b) in (fib_acc (b ) (ab ) (n1 ))))))) + (fun fib(n)->(if ((n<2)) then (n) else ((fib ((n-1)+(fib (n-2))))))) + (fun main()->(let () = ((print_int (fib_acc 0 1 4)) in let () = ((print_int (fib 4)) in 0)))) + $ dune exec lambda_lifting_test < manytests/typed/004manyargs.ml + (fun wrap(f)->(if ((1=1)) then ((f )) else ((f )))) + (fun a(a)->((print_int (a )))) + (fun b(b)->((print_int (b )))) + (fun c(c)->((print_int (c )))) + (fun test3(a b c)->(let a = ((print_int (a )) in let b = ((print_int (b )) in let c = ((print_int (c )) in 0))))) + (fun test10(a b c d e f g h i j)->(((((((((((a )+(b ))+(c ))+(d ))+(e ))+(f ))+(g ))+(h ))+(i ))+(j )))) + (fun rez()->((wrap (test10 ) 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000))) + (fun temp2()->((wrap (test3 ) 1 10 100))) + (fun main()->(let rez = ((wrap (test10 ) 1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000) in let () = ((print_int (rez )) in let temp2 = ((wrap (test3 ) 1 10 100) in 0))))) + $ dune exec lambda_lifting_test < manytests/typed/005fix.ml + (fun fix(f x)->((f (fix (f )) (x )))) + (fun fac(self n)->(if (((n )<=1)) then (1) else (((n )*(self ((n )-1)))))) + (fun main()->(let () = ((print_int (fix (fac ) 6)) in 0))) + $ dune exec lambda_lifting_test < manytests/typed/006partial.ml + (fun anon$1(foo)->((foo+2))) + (fun anon$2(foo)->((foo*10))) + (fun foo(b)->(if ((b )) then ((anon$1 )) else ((anon$2 )))) + (fun foo(x)->((foo true (foo false (foo true (foo false (x ))))))) + (fun main()->(let () = ((print_int (foo 11)) in 0))) + $ dune exec lambda_lifting_test < manytests/typed/006partial2.ml + (fun foo(a b c)->(let () = ((print_int (a )) in let () = ((print_int (b )) in let () = ((print_int (c )) in ((a )+((b )*(c )))))))) + (fun foo()->((foo 1))) + (fun foo(foo)->((foo (foo ) 2))) + (fun foo(foo)->((foo (foo ) 3))) + (fun main()->(let foo = ((foo 1) in let foo = ((foo (foo ) 2) in let foo = ((foo (foo ) 3) in let () = ((print_int (foo )) in 0)))))) + $ dune exec lambda_lifting_test < manytests/typed/006partial3.ml + (fun anon$2(c)->((print_int (c )))) + (fun anon$1(b)->(let () = ((print_int (b )) in (anon$2 )))) + (fun foo(a)->(let () = ((print_int (a )) in (anon$1 )))) + (fun main()->(let () = ((foo 4 8 9) in 0))) + $ dune exec lambda_lifting_test < manytests/typed/007order.ml + : end_of_input + $ dune exec lambda_lifting_test < manytests/typed/008ascription.ml + : end_of_input + $ dune exec lambda_lifting_test < manytests/typed/015tuples.ml + : end_of_input + $ dune exec lambda_lifting_test < manytests/typed/016lists.ml + : end_of_input diff --git a/slarnML/test/manytests b/slarnML/test/manytests new file mode 120000 index 000000000..0bd48791d --- /dev/null +++ b/slarnML/test/manytests @@ -0,0 +1 @@ +../../manytests \ No newline at end of file diff --git a/slarnML/test/parser_test.ml b/slarnML/test/parser_test.ml new file mode 100644 index 000000000..44aaa666c --- /dev/null +++ b/slarnML/test/parser_test.ml @@ -0,0 +1,6 @@ +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + match SlarnML_lib.Parser.parser s with + | Ok ast -> print_string @@ SlarnML_lib.Pprint_ast.pp_exprs ast + | Error message -> Format.printf "Error: %s\n" message +;; diff --git a/slarnML/test/parser_tests.t b/slarnML/test/parser_tests.t new file mode 100644 index 000000000..37f7923f8 --- /dev/null +++ b/slarnML/test/parser_tests.t @@ -0,0 +1,138 @@ + $ dune exec parser_test << EOF + > let a = 3 + > EOF + (let a=3) + $ dune exec parser_test << EOF + > let () = 0 + > EOF + (let ()=0) + $ dune exec parser_test << EOF + > (fun a -> b) + > EOF + (fun a->b) + $ dune exec parser_test << EOF + > let rec a = b in (c) + > EOF + (let rec a=b in c) + $ dune exec parser_test << EOF + > if a then b else c + > EOF + if (a) then (b) else (c) + $ dune exec parser_test << EOF + > let a = + > let b = 1 in + > let c = b in + > c + > EOF + (let a=(let b=1 in (let c=b in c))) + $ dune exec parser_test << EOF + > true && (a + (f false (g 3 y)) = 3 || 2) + > EOF + (true&&(((a+(f->false->(g->3->y)))=3)||2)) + $ dune exec parser_test << EOF + > (a b 2 1+3 * b d (-2) (r f)) + 3 + > EOF + Error: : end_of_input + $ dune exec parser_test << EOF + > a b c + > EOF + (a->b->c) + $ dune exec parser_test << EOF + > (a + (f 2 x (g 3*z y)) * 3) + > EOF + (a+((f->2->x->((g->3)*(z->y)))*3)) + $ dune exec parser_test << EOF + > (a + f 2 x (g 3*z y) * 3) + > EOF + (a+(f->2->x->(((g->3)*(z->y))*3))) + $ dune exec parser_test << EOF + > a + 2 <= b * 3 + > EOF + ((a+2)<=(b*3)) + $ dune exec parser_test << EOF + > a < 2 && b = 3 + > EOF + ((a<2)&&(b=3)) + $ dune exec parser_test << EOF + > ((a b 2 1 + 3 * b d (-2) (r f)) + 3) + > EOF + (((a->b->2->1)+(3*(b->d->(-2)->(r->f))))+3) + $ dune exec parser_test << EOF + > let fac n = + > let rec fack n f = + > if n <= 1 + > then f 1 + > else fack (n - 1) (fun x -> x * f n) + > in + > fack n (fun x -> x) + > ;; + > EOF + (let fac n=(let rec fack n f=if ((n<=1)) then ((f->1)) else ((fack->(n-1)->(fun x->(x*(f->n))))) in (fack->n->(fun x->x)))) + $ dune exec parser_test << EOF + > let fac n = + > let rec fack n = if n < 1 then n else n * fack (n - 1) in + > fack n + > ;; + > EOF + (let fac n=(let rec fack n=if ((n<1)) then (n) else ((n*(fack->(n-1)))) in (fack->n))) + $ dune exec parser_test << EOF + > let x = fack n + > ;; + > EOF + (let x=(fack->n)) + $ dune exec parser_test << EOF + > f 1 + f 2 + > EOF + ((f->1)+(f->2)) + $ dune exec parser_test << EOF + > let rec fib n = + > if n<2 + > then n + > else (fib (n - 1) + fib (n - 2)) + > EOF + (let rec fib n=if ((n<2)) then (n) else ((fib->((n-1)+(fib->(n-2)))))) + $ dune exec parser_test < manytests/do_not_type/001.ml + (let recfac n=if ((n<=1)) then (1) else ((n*(fac->(n-1))))) + $ dune exec parser_test < manytests/do_not_type/002if.ml + (let main=if (true) then (1) else (false)) + $ dune exec parser_test < manytests/do_not_type/003occurs.ml + (let fix f=(fun x->(f->(fun f->(x->x->f))))) + (fun x->(f->(fun f->(x->x->f)))) + $ dune exec parser_test < manytests/typed/001fac.ml + (let rec fac n=if ((n<=1)) then (1) else ((n*(fac->(n-1))))) + (let main=(let ()=(print_int->(fac->4)) in 0)) + $ dune exec parser_test < manytests/typed/002fac.ml + (let rec fac_cps n k=if ((n=1)) then ((k->1)) else ((fac_cps->(n-1)->(fun p->(k->(p*n)))))) + (let main=(let ()=(print_int->(fac_cps->4->(fun print_int->print_int))) in 0)) + $ dune exec parser_test < manytests/typed/003fib.ml + (let rec fib_acc a b n=if ((n=1)) then (b) else ((let n1=(n-1) in (let ab=(a+b) in (fib_acc->b->ab->n1))))) + (let rec fib n=if ((n<2)) then (n) else ((fib->((n-1)+(fib->(n-2)))))) + (let main=(let ()=(print_int->(fib_acc->0->1->4)) in (let ()=(print_int->(fib->4)) in 0))) + $ dune exec parser_test < manytests/typed/004manyargs.ml + (let wrap f=if ((1=1)) then (f) else (f)) + (let test3 a b c=(let a=(print_int->a) in (let b=(print_int->b) in (let c=(print_int->c) in 0)))) + (let test10 a b c d e f g h i j=(((((((((a+b)+c)+d)+e)+f)+g)+h)+i)+j)) + (let main=(let rez=(wrap->test10->1->10->100->1000->10000->100000->1000000->10000000->100000000->1000000000) in (let ()=(print_int->rez) in (let temp2=(wrap->test3->1->10->100) in 0)))) + $ dune exec parser_test < manytests/typed/005fix.ml + (let rec fix f x=(f->(fix->f)->x)) + (let fac self n=if ((n<=1)) then (1) else ((n*(self->(n-1))))) + (let main=(let ()=(print_int->(fix->fac->6)) in 0)) + $ dune exec parser_test < manytests/typed/006partial.ml + (let foo b=if (b) then ((fun foo->(foo+2))) else ((fun foo->(foo*10)))) + (let foo x=(foo->true->(foo->false->(foo->true->(foo->false->x))))) + (let main=(let ()=(print_int->(foo->11)) in 0)) + $ dune exec parser_test < manytests/typed/006partial2.ml + (let foo a b c=(let ()=(print_int->a) in (let ()=(print_int->b) in (let ()=(print_int->c) in (a+(b*c)))))) + (let main=(let foo=(foo->1) in (let foo=(foo->2) in (let foo=(foo->3) in (let ()=(print_int->foo) in 0))))) + $ dune exec parser_test < manytests/typed/006partial3.ml + (let foo a=(let ()=(print_int->a) in (fun b->(let ()=(print_int->b) in (fun c->(print_int->c)))))) + (let main=(let ()=(foo->4->8->9) in 0)) + $ dune exec parser_test < manytests/typed/007order.ml + Error: : end_of_input + $ dune exec parser_test < manytests/typed/008ascription.ml + Error: : end_of_input + $ dune exec parser_test < manytests/typed/015tuples.ml + Error: : end_of_input + $ dune exec parser_test < manytests/typed/016lists.ml + Error: : end_of_input + diff --git a/slarnML/test/riscv64_instr_test.ml b/slarnML/test/riscv64_instr_test.ml new file mode 100644 index 000000000..ca6288235 --- /dev/null +++ b/slarnML/test/riscv64_instr_test.ml @@ -0,0 +1,23 @@ +open SlarnML_lib.Res + +let () = + let s = Stdio.In_channel.input_all Stdlib.stdin in + let result = + match SlarnML_lib.Parser.parser s with + | Ok ast -> + SlarnML_lib.Clos_conv.clos_conv ast + >>= (fun ast -> SlarnML_lib.Lambda_lifting.lambda_lifting ast) + >>= fun ast -> + Result (SlarnML_lib.Anf_conv.anf ast) + >>= (fun anf -> SlarnML_lib.Riscv.asm anf) + >>= fun prog -> + Result + (String.concat + "\n" + (List.map (SlarnML_lib.Pprint_riscv.pp_instruction "\t") prog)) + | Error message -> SlarnML_lib.Res.Error message + in + match result with + | SlarnML_lib.Res.Result r -> print_string @@ r + | Error e -> Printf.eprintf "%s" e +;; diff --git a/slarnML/test/riscv64_instr_test.t b/slarnML/test/riscv64_instr_test.t new file mode 100644 index 000000000..20345adae --- /dev/null +++ b/slarnML/test/riscv64_instr_test.t @@ -0,0 +1,1673 @@ + $ dune exec riscv64_instr_test << EOF + > let fac n = + > let rec fack n f = if (n <= 1) then (f 1) else (fack (n - 1) (fun x -> x * (f n))) in + > (fack n (fun x -> x)) + > ;; + > EOF + f not found + $ dune exec riscv64_instr_test << EOF + > let fac n = + > let rec fack n = if (n < 1) then n else n * (fack (n - 1)) in + > (fack n) + > ;; + > EOF + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + fack: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + li t0,1 + blt t0,a0,.tag_anf_op_1 + j .tag_anf_op_1_t + .tag_anf_op_1: + li t1,1 + sub t2,a0,t1 + sd t2,-24(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + ld t2,-88(s0) + mul t1,t2,a0 + sd a0,-32(s0) + mv a0,t1 + .tag_anf_op_1_t: + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + fac: + addi sp,sp,-192 + sd ra,176(sp) + sd s0,168(sp) + addi s0,sp,192 + sd a0,-184(s0) + li t0,1 + blt t0,a0,.tag_anf_op_6 + j .tag_anf_op_6_t + .tag_anf_op_6: + li t1,1 + sub t2,a0,t1 + sd t2,-24(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + ld t2,-184(s0) + mul t1,t2,a0 + sd a0,-32(s0) + mv a0,t1 + .tag_anf_op_6_t: + sd t1,-40(s0) + sd a0,-48(s0) + ld a0,-48(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-56(s0) + ld a0,-184(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-64(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a3,-64(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,176(sp) + ld s0,168(sp) + addi sp,sp,192 + ret + $ dune exec riscv64_instr_test << EOF + > let f a = + > let g c d = + > let h e = a * (c + d * e) in + > (h 4) + > in + > (g 2 3) + > EOF + e not found + $ dune exec riscv64_instr_test < manytests/do_not_type/001.ml + fac not exist + + $ dune exec riscv64_instr_test < manytests/do_not_type/002if.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + addi s0,sp,32 + li t0,1 + beqz t0,.tag_if_bnch + li t1,1 + mv a0,t1 + j .tag_if_bnch_t + .tag_if_bnch: + li t2,0 + mv a0,t2 + .tag_if_bnch_t: + mv a0,a0 + ld ra,16(sp) + ld s0,8(sp) + addi sp,sp,32 + ret + + $ dune exec riscv64_instr_test < manytests/do_not_type/003occurs.ml + f not exist + + $ dune exec riscv64_instr_test < manytests/typed/001fac.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + fac: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + li t0,1 + ble t0,a0,.tag_anf_op_1 + li t1,1 + mv a0,t1 + j .tag_anf_op_1_t + .tag_anf_op_1: + ld a0,-88(s0) + li t2,1 + sub t3,a0,t2 + sd t3,-24(s0) + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + ld t3,-88(s0) + mul t2,t3,a0 + sd a0,-32(s0) + mv a0,t2 + .tag_anf_op_1_t: + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + main: + addi sp,sp,-112 + sd ra,104(sp) + sd s0,96(sp) + addi s0,sp,112 + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + li a3,4 + li a2,1 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,104(sp) + ld s0,96(sp) + addi sp,sp,112 + ret + + $ dune exec riscv64_instr_test < manytests/typed/002fac.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + anon_1: + addi sp,sp,-80 + sd ra,72(sp) + sd s0,64(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(s0) + mul t0,a2,a0 + sd t0,-24(s0) + ld a0,-72(s0) + ld a3,-24(s0) + li a2,1 + li a1,0 + call part_app + mv a0,a0 + ld ra,72(sp) + ld s0,64(sp) + addi sp,sp,80 + ret + fac_cps: + addi sp,sp,-224 + sd ra,208(sp) + sd s0,200(sp) + addi s0,sp,224 + sd a1,-216(s0) + sd a0,-208(s0) + li t0,1 + beq a0,t0,.tag_anf_op_3 + ld a0,-216(s0) + li a3,1 + li a2,1 + li a1,0 + call part_app + j .tag_anf_op_3_t + .tag_anf_op_3: + ld t0,-208(s0) + li a1,1 + sub t1,t0,a1 + sd a0,-24(s0) + sd t1,-32(s0) + ld a0,-208(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + ld a0,-216(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-48(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + ld a4,-48(s0) + ld a3,-40(s0) + li a2,2 + li a1,3 + call part_app + sd a0,-56(s0) + lui a0,%hi(fac_cps) + addi a0,a0,%lo(fac_cps) + ld a4,-56(s0) + ld a3,-32(s0) + li a2,2 + li a1,2 + call part_app + .tag_anf_op_3_t: + sd a0,-64(s0) + mv a0,a0 + ld ra,208(sp) + ld s0,200(sp) + addi sp,sp,224 + ret + anon_1: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + addi s0,sp,32 + sd a0,-24(s0) + mv a0,a0 + ld ra,16(sp) + ld s0,8(sp) + addi sp,sp,32 + ret + main: + addi sp,sp,-144 + sd ra,136(sp) + sd s0,128(sp) + addi s0,sp,144 + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + li a2,0 + li a1,3 + call part_app + sd a0,-24(s0) + lui a0,%hi(fac_cps) + addi a0,a0,%lo(fac_cps) + ld a4,-24(s0) + li a3,4 + li a2,2 + li a1,2 + call part_app + sd a0,-32(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-40(s0) + ld a0,-40(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,136(sp) + ld s0,128(sp) + addi sp,sp,144 + ret + + $ dune exec riscv64_instr_test < manytests/typed/003fib.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + n1: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + sd a0,-32(s0) + li t0,1 + sub t1,a0,t0 + mv a0,t1 + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + ab: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a1,-40(s0) + sd a0,-32(s0) + add t0,a0,a1 + mv a0,t0 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + fib_acc: + addi sp,sp,-272 + sd ra,256(sp) + sd s0,248(sp) + addi s0,sp,272 + sd a2,-264(s0) + sd a1,-256(s0) + sd a0,-248(s0) + li t0,1 + beq a2,t0,.tag_anf_op_3 + mv a0,a1 + j .tag_anf_op_3_t + .tag_anf_op_3: + li a0,1 + sub t1,a2,a0 + sd t1,-24(s0) + ld a0,-24(s0) + li a2,0 + li a1,0 + call part_app + ld t1,-248(s0) + ld t0,-256(s0) + add a1,t1,t0 + sd a0,-32(s0) + sd a1,-40(s0) + ld a0,-40(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-48(s0) + ld a0,-256(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-56(s0) + lui a0,%hi(ab) + addi a0,a0,%lo(ab) + li a2,0 + li a1,2 + call part_app + sd a0,-64(s0) + lui a0,%hi(n1) + addi a0,a0,%lo(n1) + li a2,0 + li a1,1 + call part_app + sd a0,-72(s0) + lui a0,%hi(fib_acc) + addi a0,a0,%lo(fib_acc) + ld a5,-72(s0) + ld a4,-64(s0) + ld a3,-56(s0) + li a2,3 + li a1,3 + call part_app + .tag_anf_op_3_t: + sd a0,-80(s0) + mv a0,a0 + ld ra,256(sp) + ld s0,248(sp) + addi sp,sp,272 + ret + fib: + addi sp,sp,-128 + sd ra,120(sp) + sd s0,112(sp) + addi s0,sp,128 + sd a0,-128(s0) + li t0,2 + blt t0,a0,.tag_anf_op_13 + j .tag_anf_op_13_t + .tag_anf_op_13: + li t1,1 + sub t2,a0,t1 + li t3,2 + sub t4,a0,t3 + sd t2,-24(s0) + sd t4,-32(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + ld t4,-24(s0) + add t3,t4,a0 + sd a0,-40(s0) + sd t3,-48(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + ld a3,-48(s0) + li a2,1 + li a1,1 + call part_app + .tag_anf_op_13_t: + sd a0,-56(s0) + mv a0,a0 + ld ra,120(sp) + ld s0,112(sp) + addi sp,sp,128 + ret + main: + addi sp,sp,-208 + sd ra,200(sp) + sd s0,192(sp) + addi s0,sp,208 + lui a0,%hi(fib_acc) + addi a0,a0,%lo(fib_acc) + li a5,4 + li a4,1 + li a3,0 + li a2,3 + li a1,3 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + li a3,4 + li a2,1 + li a1,1 + call part_app + sd a0,-48(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-48(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,200(sp) + ld s0,192(sp) + addi sp,sp,208 + ret + + $ dune exec riscv64_instr_test < manytests/typed/004manyargs.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + wrap: + addi sp,sp,-112 + sd ra,96(sp) + sd s0,88(sp) + addi s0,sp,112 + sd a0,-104(s0) + li t0,1 + li t1,1 + beq t0,t1,.tag_anf_op_1 + ld a0,-104(s0) + li a2,0 + li a1,0 + call part_app + j .tag_anf_op_1_t + .tag_anf_op_1: + sd a0,-24(s0) + ld a0,-104(s0) + li a2,0 + li a1,0 + call part_app + .tag_anf_op_1_t: + sd a0,-32(s0) + mv a0,a0 + ld ra,96(sp) + ld s0,88(sp) + addi sp,sp,112 + ret + a: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + lui a0,%hi(a) + addi a0,a0,%lo(a) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + b: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + lui a0,%hi(b) + addi a0,a0,%lo(b) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + c: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + lui a0,%hi(c) + addi a0,a0,%lo(c) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + test3: + addi sp,sp,-336 + sd ra,320(sp) + sd s0,312(sp) + addi s0,sp,336 + sd a2,-328(s0) + sd a1,-320(s0) + sd a0,-312(s0) + lui a0,%hi(a) + addi a0,a0,%lo(a) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(b) + addi a0,a0,%lo(b) + li a2,0 + li a1,1 + call part_app + sd a0,-48(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-48(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-64(s0) + lui a0,%hi(c) + addi a0,a0,%lo(c) + li a2,0 + li a1,1 + call part_app + sd a0,-72(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-72(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-80(s0) + ld a0,-80(s0) + li a2,0 + li a1,0 + call part_app + li a1,0 + mv a0,a1 + ld ra,320(sp) + ld s0,312(sp) + addi sp,sp,336 + ret + test10: + addi sp,sp,-480 + sd ra,464(sp) + sd s0,456(sp) + addi s0,sp,480 + sd a7,-472(s0) + sd a6,-464(s0) + sd a5,-456(s0) + sd a4,-448(s0) + sd a3,-440(s0) + sd a2,-432(s0) + sd a1,-424(s0) + sd a0,-416(s0) + lui a0,%hi(a) + addi a0,a0,%lo(a) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(b) + addi a0,a0,%lo(b) + li a2,0 + li a1,1 + call part_app + ld a1,-24(s0) + add a2,a1,a0 + sd a0,-32(s0) + sd a2,-40(s0) + lui a0,%hi(c) + addi a0,a0,%lo(c) + li a2,0 + li a1,1 + call part_app + ld a2,-40(s0) + add a1,a2,a0 + sd a0,-48(s0) + sd a1,-56(s0) + ld a0,-440(s0) + li a2,0 + li a1,0 + call part_app + ld a1,-56(s0) + add a2,a1,a0 + sd a0,-64(s0) + sd a2,-72(s0) + ld a0,-448(s0) + li a2,0 + li a1,0 + call part_app + ld a2,-72(s0) + add a1,a2,a0 + sd a0,-80(s0) + sd a1,-88(s0) + ld a0,-456(s0) + li a2,0 + li a1,0 + call part_app + ld a1,-88(s0) + add a2,a1,a0 + sd a0,-96(s0) + sd a2,-104(s0) + ld a0,-464(s0) + li a2,0 + li a1,0 + call part_app + ld a2,-104(s0) + add a1,a2,a0 + sd a0,-112(s0) + sd a1,-120(s0) + ld a0,-472(s0) + li a2,0 + li a1,0 + call part_app + ld a1,-120(s0) + add a2,a1,a0 + sd a0,-128(s0) + sd a2,-136(s0) + ld a0,0(s0) + li a2,0 + li a1,0 + call part_app + ld a2,-136(s0) + add a1,a2,a0 + sd a0,-144(s0) + sd a1,-152(s0) + ld a0,8(s0) + li a2,0 + li a1,0 + call part_app + ld a1,-152(s0) + add a2,a1,a0 + mv a0,a2 + ld ra,464(sp) + ld s0,456(sp) + addi sp,sp,480 + ret + rez: + addi sp,sp,-112 + sd ra,96(sp) + sd s0,88(sp) + addi s0,sp,112 + lui a0,%hi(test10) + addi a0,a0,%lo(test10) + li a2,0 + li a1,10 + call part_app + sd a0,-24(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + li t6,10000 + sd t6,0(sp) + li t6,100000 + sd t6,8(sp) + li t6,1000000 + sd t6,16(sp) + li t6,10000000 + sd t6,24(sp) + li t6,100000000 + sd t6,32(sp) + li t6,1000000000 + sd t6,40(sp) + li a7,1000 + li a6,100 + li a5,10 + li a4,1 + ld a3,-24(s0) + li a2,11 + li a1,1 + call part_app + mv a0,a0 + ld ra,96(sp) + ld s0,88(sp) + addi sp,sp,112 + ret + temp2: + addi sp,sp,-80 + sd ra,72(sp) + sd s0,64(sp) + addi s0,sp,80 + lui a0,%hi(test3) + addi a0,a0,%lo(test3) + li a2,0 + li a1,3 + call part_app + sd a0,-24(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + li a6,100 + li a5,10 + li a4,1 + ld a3,-24(s0) + li a2,4 + li a1,1 + call part_app + mv a0,a0 + ld ra,72(sp) + ld s0,64(sp) + addi sp,sp,80 + ret + main: + addi sp,sp,-336 + sd ra,320(sp) + sd s0,312(sp) + addi s0,sp,336 + lui a0,%hi(test10) + addi a0,a0,%lo(test10) + li a2,0 + li a1,10 + call part_app + sd a0,-24(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + li t6,10000 + sd t6,0(sp) + li t6,100000 + sd t6,8(sp) + li t6,1000000 + sd t6,16(sp) + li t6,10000000 + sd t6,24(sp) + li t6,100000000 + sd t6,32(sp) + li t6,1000000000 + sd t6,40(sp) + li a7,1000 + li a6,100 + li a5,10 + li a4,1 + ld a3,-24(s0) + li a2,11 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(rez) + addi a0,a0,%lo(rez) + li a2,0 + li a1,0 + call part_app + sd a0,-48(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-48(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-64(s0) + lui a0,%hi(test3) + addi a0,a0,%lo(test3) + li a2,0 + li a1,3 + call part_app + sd a0,-72(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + li a6,100 + li a5,10 + li a4,1 + ld a3,-72(s0) + li a2,4 + li a1,1 + call part_app + sd a0,-80(s0) + ld a0,-80(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,320(sp) + ld s0,312(sp) + addi sp,sp,336 + ret + + $ dune exec riscv64_instr_test < manytests/typed/005fix.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + fix: + addi sp,sp,-160 + sd ra,152(sp) + sd s0,144(sp) + addi s0,sp,160 + sd a1,-160(s0) + sd a0,-152(s0) + ld a0,-152(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(fix) + addi a0,a0,%lo(fix) + ld a3,-24(s0) + li a2,1 + li a1,2 + call part_app + sd a0,-32(s0) + ld a0,-160(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + ld a0,-152(s0) + ld a4,-40(s0) + ld a3,-32(s0) + li a2,2 + li a1,0 + call part_app + mv a0,a0 + ld ra,152(sp) + ld s0,144(sp) + addi sp,sp,160 + ret + fac: + addi sp,sp,-192 + sd ra,184(sp) + sd s0,176(sp) + addi s0,sp,192 + sd a1,-192(s0) + sd a0,-184(s0) + ld a0,-192(s0) + li a2,0 + li a1,0 + call part_app + li a1,1 + ble a1,a0,.tag_anf_op_6 + li t0,1 + sd a0,-24(s0) + mv a0,t0 + j .tag_anf_op_6_t + .tag_anf_op_6: + ld a0,-192(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-32(s0) + ld a0,-192(s0) + li a2,0 + li a1,0 + call part_app + li t0,1 + sub a1,a0,t0 + sd a0,-40(s0) + sd a1,-48(s0) + ld a0,-184(s0) + ld a3,-48(s0) + li a2,1 + li a1,0 + call part_app + ld a1,-32(s0) + mul t0,a1,a0 + sd a0,-56(s0) + mv a0,t0 + .tag_anf_op_6_t: + mv a0,a0 + ld ra,184(sp) + ld s0,176(sp) + addi sp,sp,192 + ret + main: + addi sp,sp,-144 + sd ra,136(sp) + sd s0,128(sp) + addi s0,sp,144 + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + li a2,0 + li a1,2 + call part_app + sd a0,-24(s0) + lui a0,%hi(fix) + addi a0,a0,%lo(fix) + li a4,6 + ld a3,-24(s0) + li a2,2 + li a1,2 + call part_app + sd a0,-32(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-40(s0) + ld a0,-40(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,136(sp) + ld s0,128(sp) + addi sp,sp,144 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + anon_1: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + sd a0,-32(s0) + li t0,2 + add t1,a0,t0 + mv a0,t1 + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + anon_2: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + sd a0,-32(s0) + li t0,10 + mul t1,a0,t0 + mv a0,t1 + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + foo: + addi sp,sp,-128 + sd ra,120(sp) + sd s0,112(sp) + addi s0,sp,128 + sd a0,-128(s0) + ld a0,-128(s0) + li a2,0 + li a1,0 + call part_app + beqz a0,.tag_if_bnch + sd a0,-24(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + li a2,0 + li a1,1 + call part_app + j .tag_if_bnch_t + .tag_if_bnch: + sd a0,-32(s0) + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + li a2,0 + li a1,1 + call part_app + .tag_if_bnch_t: + sd a0,-40(s0) + mv a0,a0 + ld ra,120(sp) + ld s0,112(sp) + addi sp,sp,128 + ret + foo: + addi sp,sp,-192 + sd ra,176(sp) + sd s0,168(sp) + addi s0,sp,192 + sd a0,-184(s0) + ld a0,-184(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + ld a4,-24(s0) + li a3,0 + li a2,2 + li a1,1 + call part_app + sd a0,-32(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + ld a4,-32(s0) + li a3,1 + li a2,2 + li a1,1 + call part_app + sd a0,-40(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + ld a4,-40(s0) + li a3,0 + li a2,2 + li a1,1 + call part_app + sd a0,-48(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + ld a4,-48(s0) + li a3,1 + li a2,2 + li a1,1 + call part_app + mv a0,a0 + ld ra,176(sp) + ld s0,168(sp) + addi sp,sp,192 + ret + main: + addi sp,sp,-112 + sd ra,104(sp) + sd s0,96(sp) + addi s0,sp,112 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,11 + li a2,1 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,104(sp) + ld s0,96(sp) + addi sp,sp,112 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial2.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + foo: + addi sp,sp,-448 + sd ra,432(sp) + sd s0,424(sp) + addi s0,sp,448 + sd a2,-440(s0) + sd a1,-432(s0) + sd a0,-424(s0) + ld a0,-424(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + ld a0,-432(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-48(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-48(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-64(s0) + ld a0,-440(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-72(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-72(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-80(s0) + ld a0,-80(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-88(s0) + ld a0,-424(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-96(s0) + ld a0,-432(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-104(s0) + ld a0,-440(s0) + li a2,0 + li a1,0 + call part_app + ld a1,-104(s0) + mul a2,a1,a0 + ld t0,-96(s0) + add t1,t0,a2 + mv a0,t1 + ld ra,432(sp) + ld s0,424(sp) + addi sp,sp,448 + ret + foo: + addi sp,sp,-48 + sd ra,40(sp) + sd s0,32(sp) + addi s0,sp,48 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,1 + li a2,1 + li a1,0 + call part_app + mv a0,a0 + ld ra,40(sp) + ld s0,32(sp) + addi sp,sp,48 + ret + foo: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a4,2 + ld a3,-24(s0) + li a2,2 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + foo: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a2,0 + li a1,1 + call part_app + sd a0,-24(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a4,3 + ld a3,-24(s0) + li a2,2 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + main: + addi sp,sp,-368 + sd ra,360(sp) + sd s0,352(sp) + addi s0,sp,368 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,1 + li a2,1 + li a1,3 + call part_app + sd a0,-24(s0) + ld a0,-24(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-32(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a2,0 + li a1,3 + call part_app + sd a0,-40(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a4,2 + ld a3,-40(s0) + li a2,2 + li a1,3 + call part_app + sd a0,-48(s0) + ld a0,-48(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-56(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a2,0 + li a1,3 + call part_app + sd a0,-64(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a4,3 + ld a3,-64(s0) + li a2,2 + li a1,3 + call part_app + sd a0,-72(s0) + ld a0,-72(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-80(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a2,0 + li a1,3 + call part_app + sd a0,-88(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-88(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-96(s0) + ld a0,-96(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,360(sp) + ld s0,352(sp) + addi sp,sp,368 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial3.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global _start + _start: + addi sp,sp,-24 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,24 + call init_part_apps + call main + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,24 + li a7,93 + ecall + anon_2: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-88(s0) + ld a0,-88(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + anon_1: + addi sp,sp,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a0,-152(s0) + ld a0,-152(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + li a2,0 + li a1,1 + call part_app + mv a0,a0 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + ret + foo: + addi sp,sp,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a0,-152(s0) + ld a0,-152(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-24(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-24(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a2,0 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + li a2,0 + li a1,1 + call part_app + mv a0,a0 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + ret + main: + addi sp,sp,-80 + sd ra,72(sp) + sd s0,64(sp) + addi s0,sp,80 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a5,9 + li a4,8 + li a3,4 + li a2,3 + li a1,1 + call part_app + sd a0,-24(s0) + ld a0,-24(s0) + li a2,0 + li a1,0 + call part_app + li t0,0 + mv a0,t0 + ld ra,72(sp) + ld s0,64(sp) + addi sp,sp,80 + ret + + $ dune exec riscv64_instr_test < manytests/typed/007order.ml + : end_of_input + + $ dune exec riscv64_instr_test < manytests/typed/008ascription.ml + : end_of_input + + $ dune exec riscv64_instr_test < manytests/typed/015tuples.ml + : end_of_input + + $ dune exec riscv64_instr_test < manytests/typed/016lists.ml + : end_of_input + diff --git a/slarnML/test/slarnML.ml b/slarnML/test/slarnML.ml new file mode 100644 index 000000000..e69de29bb