diff --git a/slarnML/.gitignore b/slarnML/.gitignore new file mode 100644 index 000000000..71ac47370 --- /dev/null +++ b/slarnML/.gitignore @@ -0,0 +1,10 @@ +.vscode +_build +_coverage +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..f2d08264a --- /dev/null +++ b/slarnML/.ocamlformat @@ -0,0 +1,2 @@ +version=0.26.2 +profile=janestreet \ 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..1f3c972e3 --- /dev/null +++ b/slarnML/lib/anf/anf_conv.ml @@ -0,0 +1,89 @@ +(** 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 (func, arg :: args) -> + anf_expr func (fun func_imm -> + 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 (func_imm, List.rev (imm :: lst)), expr_with_hole (AId name))) + args) + [] + imm_arg)) + | LApp (func, []) -> + anf_expr func (fun func_imm -> + let name = get_name "anf_app" in + ALet (name, AApp (func_imm, []), expr_with_hole (AId name))) + | LIn (id, e1, e2) -> + anf_expr e1 (fun limm -> + (* let name = "anf_" ^ get_name id in *) + ALet (id, CImmExpr 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..96c3a5492 --- /dev/null +++ b/slarnML/lib/anf/clos_conv.ml @@ -0,0 +1,170 @@ +(** Copyright 2024-2025, Ivan Shurenkov *) + +(** SPDX-License-Identifier: LGPL-2.1-or-later *) + +(* open Ast *) +open Cc_ast +open Res + +let default_fun = List.map (fun (id, _) -> id, id, 0, []) Call_define.default_func + +let remove_args id args prt_args = + if id = "()" then [] else List.filter (fun x -> not (List.mem x args)) prt_args +;; + +let get_new_name id cnt = if id = "()" then id else id ^ "_" ^ string_of_int cnt + +let rec closure_conversion ?(env = []) ?(prt_args = []) = function + | Ast.Id id -> + (match List.find_opt (fun (name, _, _, _) -> name = id) env with + | None -> + (* print_string ("Id " ^ id ^ " not found in env\n"); *) + CId id + | Some (_, new_name, _, args) -> + if List.length args > 0 + then CApp (CId new_name, List.map (fun arg -> CId arg) args) + else CId new_name) + | Ast.Const const -> CConst const + | Ast.Not e -> CNot (closure_conversion ~env ~prt_args e) + | Ast.Or (e1, e2) -> + COr (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.And (e1, e2) -> + CAnd (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Eq (e1, e2) -> + CEq (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Gt (e1, e2) -> + CGt (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Lt (e1, e2) -> + CLt (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Gte (e1, e2) -> + CGte (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Lte (e1, e2) -> + CLte (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Add (e1, e2) -> + CAdd (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Sub (e1, e2) -> + CSub (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Mul (e1, e2) -> + CMul (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.Div (e1, e2) -> + CDiv (closure_conversion ~env ~prt_args e1, closure_conversion ~env ~prt_args e2) + | Ast.If (cond, then_expr, else_expr) -> + CIf + ( closure_conversion ~env ~prt_args cond + , closure_conversion ~env ~prt_args then_expr + , closure_conversion ~env ~prt_args else_expr ) + | Ast.Let (decl, body) -> + let id, args, declared, pre_env = + match decl with + | Ast.Decl (id, args) -> + ( id + , args + , (fun id args -> Ast.Decl (id, remove_args id args prt_args @ args)) + , fun _ _ -> [] ) + | Ast.DeclRec (id, args) -> + ( id + , args + , (fun id args -> Ast.DeclRec (id, remove_args id args prt_args @ args)) + , fun new_name cnt -> [ id, new_name, cnt + 1, remove_args id args prt_args ] ) + in + let env_args = List.map (fun arg -> arg, arg, 0, []) args @ env in + (match List.find_opt (fun (name, _, _, _) -> name = id) env with + | None -> + CLet + ( declared id args + , closure_conversion + ~env:(pre_env id 0 @ env_args) + ~prt_args:(args @ prt_args) + body ) + | Some (_, old_name, cnt, _) -> + let new_name = get_new_name old_name cnt in + let body_converted = + closure_conversion + ~env:(pre_env new_name cnt @ env_args) + ~prt_args:(args @ prt_args) + body + in + CLet (declared new_name args, body_converted)) + | Ast.LetIn (decl, expr1, expr2) -> + let id, args, declared, pre_env = + match decl with + | Ast.Decl (id, args) -> + ( id + , args + , (fun id args -> Ast.Decl (id, remove_args id args prt_args @ args)) + , fun _ _ -> [] ) + | Ast.DeclRec (id, args) -> + ( id + , args + , (fun id args -> Ast.DeclRec (id, remove_args id args prt_args @ args)) + , fun new_name cnt -> [ id, new_name, cnt + 1, remove_args id args prt_args ] ) + in + let env_args = List.map (fun arg -> arg, arg, 0, []) args @ env in + (match List.find_opt (fun (name, _, _, _) -> name = id) env with + | None -> + let decl_converted = + closure_conversion + ~env:(pre_env id 0 @ env_args) + ~prt_args:(args @ prt_args) + expr1 + in + let expr2_converted = + closure_conversion + ~env:((id, id, 0, remove_args id args prt_args) :: env) + ~prt_args + expr2 + in + CLetIn (declared id args, decl_converted, expr2_converted) + | Some (_, old_name, cnt, _) -> + let new_name = get_new_name old_name cnt in + let decl_converted = + closure_conversion + ~env:(pre_env new_name cnt @ env_args) + ~prt_args:(args @ prt_args) + expr1 + in + let expr2_converted = + closure_conversion + ~env:((id, new_name, cnt + 2, remove_args id args prt_args) :: env) + ~prt_args + expr2 + in + CLetIn (declared new_name args, decl_converted, expr2_converted)) + | Ast.Fun (args, body) -> + let env_args = List.map (fun arg -> arg, arg, 0, []) args @ env in + let body_converted = + closure_conversion ~env:env_args ~prt_args:(args @ prt_args) body + in + CApp + ( CFun (remove_args "" args prt_args @ args, body_converted) + , List.map (fun arg -> CId arg) prt_args ) + | Ast.App (func, args) -> + let func_converted = closure_conversion ~env ~prt_args func in + let args_converted = List.map (closure_conversion ~env ~prt_args) args in + CApp (func_converted, args_converted) +;; + +let clos_conv ast = + List.fold_left + (fun cc_ast ast -> + cc_ast + >>= fun (cc_ast, funs) -> + let c_ast = closure_conversion ~env:funs ast in + let new_funs = + match c_ast with + | CLet (d, _) | CLetIn (d, _, _) -> + (match d with + | Ast.Decl (new_name, _) | Ast.DeclRec (new_name, _) -> + (match ast with + | Ast.Let (d, _) | Ast.LetIn (d, _, _) -> + (match d with + | Ast.Decl (old_name, _) | Ast.DeclRec (old_name, _) -> + (old_name, new_name, 0, []) :: funs) + | _ -> (new_name, new_name, 0, []) :: funs)) + | _ -> funs + in + Result (cc_ast @ [ c_ast ], new_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..ad7115a96 --- /dev/null +++ b/slarnML/lib/anf/lambda_lifting.ml @@ -0,0 +1,287 @@ +(** 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 _ = + if String.contains id '#' then String.sub id 0 (String.index id '#') else id +;; + +let find_name args fun_ids id = + map (fun (_, _, env, _) -> + (* print_endline ("find_name " ^ id ^ " " ^ String.concat ", " fun_ids); *) + match List.find_opt (fun (_, name, _) -> name = id) env with + | None -> if List.mem id fun_ids then Result (LApp (LId id, [])) else Result (LId id) + | Some (_, _, new_name) -> + if List.mem id fun_ids && not (List.mem new_name args) + then Result (LApp (LId new_name, [])) + else 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 = + map (fun (ast, prog, env, num) -> + let new_name = get_name name stack in + Result (ast, prog, (lvl, name, new_name) :: env, num)) +;; + +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 get_num = map (fun (_, _, _, num) -> Result num) + +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 fun_ids g_args stack lvl res = + let lifting_bin_op f e1 e2 = + res + |> lifting e1 fun_ids g_args stack lvl + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + r1 |> lifting e2 fun_ids g_args 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 args = get_args d @ g_args 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 + let funs = if List.length args = 0 then fun_ids else id :: fun_ids in + res + |> f1 + |> update_env_fun id stack lvl + |> lifting e1 funs args (id :: stack) (lvl + 1) + |> f2 + in + match cc_ast with + | CId id -> + res |> find_name g_args fun_ids id >>= fun ast -> update_ast (fun _ -> Result ast) res + | CConst c -> update_ast (fun _ -> Result (LConst c)) res + | CNot e -> res |> lifting e fun_ids g_args 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 fun_ids g_args stack lvl + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + r1 + |> lifting e2 fun_ids g_args stack lvl + |> fun r2 -> + r2 + |> get_ast + >>= fun a2 -> + r2 + |> lifting e3 fun_ids g_args 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 + let e2_funs = if List.length (get_args d) = 0 then fun_ids else id :: fun_ids in + res + |> init_func d e1 + |> fun r1 -> + r1 + |> get_ast + >>= fun a1 -> + (if List.length (get_args d) = 0 + then r1 + else r1 |> insert_let (get_fun_let (get_decl d) a1)) + |> lifting e2 e2_funs g_args stack lvl + |> update_ast (fun a2 -> + if List.length (get_args d) = 0 then Result (LIn (id, a1, a2)) else Result 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 fun_ids (args @ g_args) (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 (LApp (LId new_name, []))) + | CApp (e, args) -> + List.fold_left + (fun r e -> + r + >>= fun (r, lst) -> + Result r + |> lifting e fun_ids g_args 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.rev args in + Result r + |> lifting e fun_ids g_args 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 (LId a, args)) + | _ -> Error "Apply on not correct expr") +;; + +let rec drop n lst = + match n, lst with + | 0, _ -> lst + | _, [] -> [] + | _, _ :: tail -> drop (n - 1) tail +;; + +let take n lst = + let rec helper n lst acc = + match n, lst with + | 0, _ -> acc + | _, [] -> acc + | _, hd :: tail -> helper (n - 1) tail (hd :: acc) + in + List.rev (helper n lst []) +;; + +let rec unwrap_app args_cnt expr = + match expr with + | LApp (e_id, args) -> + (match e_id with + | LId id when Option.is_some (List.find_opt (fun (name, _) -> name = id) args_cnt) -> + (match List.find_opt (fun (name, _) -> name = id) args_cnt with + | None -> expr + | Some (_, arg_cnt) -> + (* print_string (id^" "^(string_of_int arg_cnt)^"\n"); *) + let other_args = + List.map (fun arg -> unwrap_app args_cnt arg) (drop arg_cnt args) + in + (match other_args with + | [] -> LApp (LId id, List.map (fun arg -> unwrap_app args_cnt arg) args) + | _ -> + let applied_args = + List.map (fun arg -> unwrap_app args_cnt arg) (take arg_cnt args) + in + List.fold_left + (fun app arg -> LApp (app, [ arg ])) + (LApp (LId id, applied_args)) + other_args)) + | _ -> + (match args with + | [] -> expr + | [ arg ] -> LApp (unwrap_app args_cnt e_id, [ unwrap_app args_cnt arg ]) + | fst :: args -> + List.fold_left + (fun app arg -> LApp (app, [ unwrap_app args_cnt arg ])) + (LApp (unwrap_app args_cnt e_id, [ unwrap_app args_cnt fst ])) + args)) + | LId _ | LConst _ -> expr + | LNot e -> LNot (unwrap_app args_cnt e) + | LOr (e1, e2) -> LOr (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LAnd (e1, e2) -> LAnd (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LEq (e1, e2) -> LEq (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LGt (e1, e2) -> LGt (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LLt (e1, e2) -> LLt (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LGte (e1, e2) -> LGte (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LLte (e1, e2) -> LLte (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LAdd (e1, e2) -> LAdd (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LSub (e1, e2) -> LSub (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LMul (e1, e2) -> LMul (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LDiv (e1, e2) -> LDiv (unwrap_app args_cnt e1, unwrap_app args_cnt e2) + | LIf (e1, e2, e3) -> + LIf (unwrap_app args_cnt e1, unwrap_app args_cnt e2, unwrap_app args_cnt e3) + | LIn (id, e1, e2) -> LIn (id, unwrap_app args_cnt e1, unwrap_app args_cnt e2) +;; + +let default_res num = Result (LId "Error", [], [], num) + +let lambda_lifting cc_ast = + List.fold_left + (fun prev_res ast -> + prev_res + >>= fun (anon_num, ll_ast) -> + let funs = + List.map + (fun e -> + match e with + | LFun (id, _, _) -> id) + ll_ast + in + lifting ast funs [] [] 0 (default_res anon_num) + |> fun res -> + res + |> get_num + >>= fun num -> res |> get_prog >>= fun p -> Result (num, ll_ast @ List.rev p)) + (Result (0, [])) + cc_ast + >>= fun (_, ast) -> + Result ast + >>= fun g_ast -> + Result + ((fun (e, _) -> e) + (List.fold_left + (fun (acc, acc_cnt) ast -> + match ast with + | LFun (id, args, e) -> + ( acc @ [ LFun (id, args, unwrap_app ((id, List.length args) :: acc_cnt) e) ] + , (id, List.length args) :: acc_cnt )) + ([], []) + g_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..0cbf0568e --- /dev/null +++ b/slarnML/lib/anf/ll_ast.ml @@ -0,0 +1,28 @@ +(** 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 l_expr * 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 *) +[@@deriving show { with_path = false }] + +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..6f7ec6a2a --- /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 ppx_deriving) ; llvm) + (preprocess + (pps ppx_deriving.show 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..10d246779 --- /dev/null +++ b/slarnML/lib/inferencer/typedtree.ml @@ -0,0 +1,33 @@ +(** 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 +[@@deriving show { with_path = false }] + +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 +[@@deriving show { with_path = false }] + +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..8fd3af65f --- /dev/null +++ b/slarnML/lib/parser/parser.ml @@ -0,0 +1,708 @@ +(** 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 unit = skip_empty *> (parens @@ (string "" *> return "()")) +let arguments = tuple (identifier <|> unit) <|> many (identifier <|> unit) +let arguments1 = tuple (identifier <|> unit) <|> many1 (identifier <|> unit) + +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..32e3f787c --- /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 "" [ "let "; 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..6edfdf52f --- /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..cde37b20b --- /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..3d4534134 --- /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 "" [ "("; pp_ll_expr 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 "" [ "let "; 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..6f94056eb --- /dev/null +++ b/slarnML/lib/riscv64/call_define.ml @@ -0,0 +1,6 @@ +open Riscv_ast + +let exit = 93 +let default_func = [ "print_int", 1; "print_char", 1 ] +let init_part_apps = Call (Id "init_part_apps") +let part_app = Call (Id "part_app") diff --git a/slarnML/lib/riscv64/part_app.c b/slarnML/lib/riscv64/part_app.c new file mode 100644 index 000000000..e780719ac --- /dev/null +++ b/slarnML/lib/riscv64/part_app.c @@ -0,0 +1,300 @@ +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include + +#define MAX_APPS 100 +#define MAX_ARGS 16 + +struct Func { + uint8_t argscnt; + uint8_t cnt; + void *ptr; + int64_t *argsfun; + ffi_cif *cif; + ffi_type **arg_types; + void **arg_values; +}; + +struct Func func_init(void *ptr, uint8_t cnt) { + struct Func new; + new.ptr = ptr; + new.argscnt = cnt; + new.cnt = 0; + + new.argsfun = malloc(sizeof(int64_t) * cnt); + if (!new.argsfun) { + fprintf(stderr, "Memory allocation failed for arguments!\n"); + exit(1); + } + + new.cif = malloc(sizeof(ffi_cif)); + if (!new.cif) { + fprintf(stderr, "Memory allocation failed for FFI CIF!\n"); + free(new.argsfun); + exit(1); + } + + new.arg_types = malloc(sizeof(ffi_type*) * (cnt + 1)); // +1 for return type + if (!new.arg_types) { + fprintf(stderr, "Memory allocation failed for argument types!\n"); + free(new.argsfun); + free(new.cif); + exit(1); + } + + new.arg_values = malloc(sizeof(void*) * cnt); + if (!new.arg_values) { + fprintf(stderr, "Memory allocation failed for argument values!\n"); + free(new.argsfun); + free(new.cif); + free(new.arg_types); + exit(1); + } + + for (int i = 0; i < cnt; i++) { + new.arg_types[i] = &ffi_type_sint64; + } + new.arg_types[cnt] = NULL; + + ffi_status status = ffi_prep_cif(new.cif, FFI_DEFAULT_ABI, cnt, &ffi_type_sint64, new.arg_types); + if (status != FFI_OK) { + fprintf(stderr, "Failed to prepare FFI call interface: %d\n", status); + free(new.argsfun); + free(new.cif); + free(new.arg_types); + free(new.arg_values); + exit(1); + } + + return new; +} + +struct Func copy_func(const struct Func *original) { + struct Func copy; + + copy.argscnt = original->argscnt; + copy.cnt = original->cnt; + + copy.ptr = original->ptr; + + copy.argsfun = malloc(sizeof(int64_t) * original->argscnt); + if (!copy.argsfun) { + fprintf(stderr, "Memory allocation failed for argsfun!\n"); + } + memcpy(copy.argsfun, original->argsfun, sizeof(int64_t) * original->argscnt); + + copy.cif = malloc(sizeof(ffi_cif)); + if (!copy.cif) { + fprintf(stderr, "Memory allocation failed for cif!\n"); + free(copy.argsfun); + exit(1); + } + memcpy(copy.cif, original->cif, sizeof(ffi_cif)); + + copy.arg_types = malloc(sizeof(ffi_type*) * (original->argscnt + 1)); + if (!copy.arg_types) { + fprintf(stderr, "Memory allocation failed for arg_types!\n"); + free(copy.argsfun); + free(copy.cif); + exit(1); + } + for (int i = 0; i < original->argscnt; i++) { + copy.arg_types[i] = original->arg_types[i]; + } + copy.arg_types[original->argscnt] = NULL; + + copy.arg_values = malloc(sizeof(void*) * original->argscnt); + if (!copy.arg_values) { + fprintf(stderr, "Memory allocation failed for arg_values!\n"); + free(copy.argsfun); + free(copy.cif); + free(copy.arg_types); + exit(1); + } + memcpy(copy.arg_values, original->arg_values, sizeof(void*) * original->argscnt); + + return copy; +} + +void func_free(struct Func *f) { + if (f) { + free(f->argsfun); + free(f->cif); + free(f->arg_types); + free(f->arg_values); + } +} + +struct Func *part_apps; +uint8_t *used_apps; +uint16_t last_app = 0; + +int64_t app_n(struct Func *f) { + if (f == NULL || f->ptr == NULL) { + fprintf(stderr, "Error: NULL pointer in app_n function\n"); + return -1; + } + + for (int i = 0; i < f->argscnt; i++) { + f->arg_values[i] = &f->argsfun[i]; + } + + int64_t result; + ffi_call(f->cif, FFI_FN(f->ptr), &result, f->arg_values); + + return result; +} + +int64_t app(struct Func *f, uint8_t cnt, int64_t *args) { + // fprintf(stdout, "Warning: %p(%ld) [%d %d]", f->ptr, (int64_t)f, f->argscnt, f->cnt); + // if (cnt > 0) { + // fprintf(stdout, " -> %ld\n", args[0]); + // } else { + // fprintf(stdout, "\n"); + // } + + if (f == NULL || args == NULL) { + fprintf(stderr, "Error: NULL pointer in app function\n"); + return -1; + } + + uint8_t f_cnt = f->cnt; + uint8_t new_cnt = f_cnt + cnt; + + for (int i = f_cnt; i < new_cnt && i < f->argscnt; i++) { + f->argsfun[i] = args[i - f_cnt]; + } + + f->cnt = (new_cnt < f->argscnt) ? new_cnt : f->argscnt; + + if (f->cnt >= f->argscnt) { + int64_t ret = app_n(f); + + if (new_cnt > f->argscnt) { + // fprintf(stdout, "Warning: overflow args\n"); + int64_t new_args[MAX_ARGS]; + for (int i = 0; i < new_cnt - f->argscnt && i < MAX_ARGS; i++) { + new_args[i] = args[i + (f->argscnt - f_cnt)]; + } + + struct Func *new_f = &part_apps[last_app]; + *new_f = func_init(f->ptr, f->argscnt); + last_app = (last_app + 1) % MAX_APPS; + + return app(new_f, new_cnt - f->argscnt, new_args); + } + + return ret; + } + + return (int64_t)f; +} + +int64_t part_app(void *f_ptr, int argcnt, int appcnt, ...) { + int64_t args[MAX_ARGS]; + va_list argptr; + va_start(argptr, appcnt); + + for (int i = 0; i < appcnt && i < MAX_ARGS; i++) { + args[i] = va_arg(argptr, int64_t); + } + va_end(argptr); + + if (f_ptr == NULL) { + fprintf(stderr, "Error: NULL function pointer\n"); + return -1; + } + int app_idx = 0; + + if ((int64_t)&part_apps[0] <= (int64_t)f_ptr && (int64_t)f_ptr <= (int64_t)&part_apps[MAX_APPS-1]) { + // part_apps[last_app] = copy_func(f_ptr); + // used_apps[last_app] = 1; + // app_idx = last_app; + app_idx = ((int64_t)f_ptr - (int64_t)&part_apps[0]) / sizeof(struct Func); + } else { + part_apps[last_app] = func_init(f_ptr, argcnt); + used_apps[last_app] = 1; + app_idx = last_app; + } + + last_app = (last_app + 1) % MAX_APPS; + + int64_t ret = app(&part_apps[app_idx], appcnt, args); + // fprintf(stdout, "Result: %ld\n", ret); + return ret; +} + +void init_part_apps() { + part_apps = malloc(sizeof(struct Func) * MAX_APPS); + if (!part_apps) { + fprintf(stderr, "Failed to allocate memory for part_apps\n"); + exit(1); + } + used_apps = malloc(sizeof(uint8_t) * MAX_APPS); + if (!used_apps) { + fprintf(stderr, "Failed to allocate memory for used_apps\n"); + exit(1); + } + + for (int i = 0; i < MAX_APPS; i++) { + part_apps[i].ptr = NULL; + part_apps[i].argsfun = NULL; + part_apps[i].argscnt = 0; + part_apps[i].cnt = 0; + part_apps[i].cif = NULL; + part_apps[i].arg_types = NULL; + part_apps[i].arg_values = NULL; + used_apps[i] = 0; + } +} + +void cleanup_part_apps() { + if (part_apps) { + for (int i = 0; i < MAX_APPS; i++) { + if (used_apps[i]) { + func_free(&part_apps[i]); + } + } + free(part_apps); + free(used_apps); + } +} + +#include +void print_int2(int number) { + fprintf(stdout, "%d", number); +} + + +// 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); +// } + +// #include + +// int not_main() { +// init_part_apps(); +// int64_t a = part_app(notmain, 0, 0); +// int64_t m = part_app(many_arg, 14, 0); +// int64_t m2 = part_app(m, 14, 1, 0); +// int64_t m3 = part_app(m2, 14, 6, 1, 2, 3, 4, 5, 6); +// int64_t m4 = part_app(m3, 0, 7, 7, 8, 9, 10, 11, 12, 13); +// printf("%d %d %d %d %d\n", a, m, m2, m3, m4); +// cleanup_part_apps(); +// return 0; +// } diff --git a/slarnML/lib/riscv64/print.S b/slarnML/lib/riscv64/print.S new file mode 100644 index 000000000..af2dcee19 --- /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 # make the syscall + +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..f04c4b0a2 --- /dev/null +++ b/slarnML/lib/riscv64/riscv.ml @@ -0,0 +1,685 @@ +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) -> + (* print_endline ("get_fun " ^ name ^ " " ^ (String.concat ", " (List.map (fun (f_name, cnt) -> f_name^"("^string_of_int cnt^")") funs))); *) + Result (List.find_opt (fun (f_name, _) -> f_name = name) funs)) +;; + +let get_funs = map (fun (_, _, _, _, _, funs) -> Result 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 replace_fun name args_cnt = + map (fun (offset, regs, offsets, free, conds, funs) -> + Result + ( offset + , regs + , offsets + , free + , conds + , (name, args_cnt) :: List.filter (fun (f_name, _) -> f_name <> name) 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 tag = + if tag = "main" + then tag ^ "2" + else String.map (fun c -> if c = '#' || c = '$' then '_' else c) tag +;; + +let get_unique_tag id env = + let rec find_unique base counter = + let candidate = if counter = 0 then base else base ^ "_" ^ string_of_int counter in + if List.exists (fun (f_name, _) -> f_name = candidate) env + then find_unique base (counter + 1) + else candidate + in + if id = "main" then "main" else find_unique id 0 +;; + +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, r1, r2, tag)) i1 i2 + | ALte (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Ble, r1, r2, tag)) i1 i2 + | AGt (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Bgt, r1, r2, tag)) i1 i2 + | ALt (i1, i2) -> cond_op (fun r1 r2 -> Bnch (Blt, r1, r2, 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 e2 + >>= 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 e1 + >>= 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 = 16 * ((offset_full + 15) / 16) in + res + |> get_funs + >>= fun funs -> + let unique_id = get_unique_tag id funs in + let args_cnt = List.length args in + let res = res |> add_fun unique_id args_cnt in + res + |> save_args (-offset_align) 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 unique_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 + ] + , [ unique_id, args_cnt ] )) +;; + +let head = + [ Attribute "unaligned_access, 0" + ; Attribute "stack_align, 16" + ; Global "main" + ; Tag "main" + ; Mathi (Add, Sp, Sp, ImmInt (-32)) + ; Sd (Ra, ImmInt 16, Sp) + ; Sd (S 0, ImmInt 8, Sp) + ; Sd (S 1, ImmInt 0, Sp) + ; Mathi (Add, S 0, Sp, ImmInt 32) + ; Call (Id "init_part_apps") + ; Call (Id "main2") + ; Sd (A 0, ImmInt 24, Sp) + ; Call (Id "cleanup_part_apps") + ; Ld (A 0, ImmInt 24, Sp) + ; Ld (Ra, ImmInt 16, Sp) + ; Ld (S 0, ImmInt 8, Sp) + ; Ld (S 1, ImmInt 0, Sp) + ; Mathi (Add, Sp, Sp, ImmInt 32) + ; Li (A 7, ImmInt exit) + ; Ecall + ] +;; + +let default_res = + Result + ( -32 + , [] + , [] + , [ 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_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..c37a71427 --- /dev/null +++ b/slarnML/lib/riscv64/riscv_ast.ml @@ -0,0 +1,72 @@ +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 (* ^ *) +[@@deriving show { with_path = false }] + +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..b55b2afdc --- /dev/null +++ b/slarnML/lib/test/anf_test.ml @@ -0,0 +1,513 @@ +(** 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 (CId "n", [ CSub (CId "n", CConst (CInt 1)) ]) + , CApp + ( CFun ([ "n"; "k"; "n"; "m" ], CMul (CId "k", CMul (CId "m", CId "n"))) + , [ CId "n"; CId "k"; CId "n" ] ) ) + , CApp + (CId "fack", [ CId "n"; CApp (CFun ([ "n"; "x" ], CId "x"), [ CId "n" ]) ]) + ) ) + ] +;; + +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", [ "c"; "d"; "a"; "e" ]) + , CMul (CId "a", CAdd (CId "c", CMul (CId "d", CId "e"))) + , CApp (CApp (CId "h", [ CId "c"; CId "d"; CId "a" ]), [ 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", [ "a"; "b"; "c" ]) + , CLetIn + ( Decl ("h", [ "c"; "a"; "b" ]) + , CApp + ( CFun + ( [ "c"; "a"; "b"; "x" ] + , CMul (CId "x", CApp (CId "a", [ CMul (CId "c", CId "b") ])) ) + , [ CId "c"; CId "a"; CId "b" ] ) + , CApp (CApp (CId "h", [ CId "c"; CId "a"; CId "b" ]), [ CId "a" ]) ) + , CApp (CApp (CId "g", [ CId "a"; CId "b" ]), [ 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"; "a"; "b"; "c" ]) + , CMul (CId "a", CDiv (CId "b", CId "c")) + , CApp + ( CApp (CId "h", [ CId "a"; CId "a" ]) + , [ CConst (CInt 2); CConst (CInt 3) ] ) ) + , 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", [ "a" ]) + , CApp (CFun ([ "a"; "x" ], CId "x"), [ CId "a" ]) + , CLetIn + ( Decl ("h", [ "a" ]) + , CApp (CFun ([ "a"; "x" ], CMul (CId "a", CId "x")), [ CId "a" ]) + , CAdd + ( CApp (CApp (CId "g", [ CId "a" ]), [ 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 show_gl_expr l_ast) + ; "\n---\n" + ; String.concat "\n" (List.map show_gl_expr expected) + ; "\n====\n" + ]; + false + | Error e -> + Printf.printf "%s: %s\n" n e; + false +;; + +let ll1 = + [ LFun ("anon_1", [ "n"; "k"; "n"; "m" ], LMul (LId "k", LMul (LId "m", LId "n"))) + ; LFun + ( "fack" + , [ "n"; "k" ] + , LIf + ( LLte (LId "n", LConst (CInt 1)) + , LApp (LId "n", [ LSub (LId "n", LConst (CInt 1)) ]) + , LApp (LId "anon_1", [ LId "n"; LId "k"; LId "n" ]) ) ) + ; LFun ("anon_2", [ "n"; "x" ], LId "x") + ; LFun ("fac", [ "n" ], LApp (LId "fack", [ LId "n"; LApp (LId "anon_2", [ LId "n" ]) ])) + ] +;; + +ll_ok "ll_1" (lambda_lifting cc1) ll1 + +let ll2 = + [ LFun + ( "h" + , [ "c"; "d"; "a"; "e" ] + , LMul (LId "a", LAdd (LId "c", LMul (LId "d", LId "e"))) ) + ; LFun + ( "g" + , [ "a"; "c"; "d" ] + , LApp (LId "h", [ LId "c"; LId "d"; LId "a"; LConst (CInt 4) ]) ) + ; LFun ("f", [ "a" ], LApp (LId "g", [ LId "a"; LConst (CInt 2); LConst (CInt 3) ])) + ] +;; + +ll_ok "ll_2" (lambda_lifting cc2) ll2 + +let ll3 = + [ LFun + ( "anon_1" + , [ "c"; "a"; "b"; "x" ] + , LMul (LId "x", LApp (LId "a", [ LMul (LId "c", LId "b") ])) ) + ; LFun ("h", [ "c"; "a"; "b" ], LApp (LId "anon_1", [ LId "c"; LId "a"; LId "b" ])) + ; LFun + ( "g" + , [ "a"; "b"; "c" ] + , LApp (LApp (LId "h", [ LId "c"; LId "a"; LId "b" ]), [ LId "a" ]) ) + ; LFun ("f", [ "a"; "b" ], LApp (LId "g", [ LId "a"; LId "b"; LConst (CInt 3) ])) + ] +;; + +ll_ok "ll_3" (lambda_lifting cc3) ll3 + +let ll4 = + [ LFun ("h", [ "a"; "a"; "b"; "c" ], LMul (LId "a", LDiv (LId "b", LId "c"))) + ; LFun + ( "g" + , [ "a"; "b" ] + , LApp (LId "h", [ LId "a"; LId "a"; LConst (CInt 2); LConst (CInt 3) ]) ) + ; LFun + ("f", [ "a" ], LApp (LId "g", [ LAdd (LConst (CInt 1), LConst (CInt 0)); LId "a" ])) + ] +;; + +ll_ok "ll_4" (lambda_lifting cc4) ll4 + +let ll5 = + [ LFun ("g", [ "a"; "b" ], LDiv (LId "a", LId "b")) + ; LFun ("h", [ "a"; "c" ], LMul (LId "a", LId "c")) + ; LFun + ( "f" + , [ "a" ] + , LAdd + ( LApp (LId "h", [ LId "a"; LConst (CInt 1) ]) + , LApp (LId "g", [ LId "a"; LConst (CInt 2) ]) ) ) + ] +;; + +ll_ok "ll_5" (lambda_lifting cc5) ll5 + +let ll6 = + [ LFun ("anon_1", [ "a"; "x" ], LId "x") + ; LFun ("g", [ "a" ], LApp (LId "anon_1", [ LId "a" ])) + ; LFun ("anon_2", [ "a"; "x" ], LMul (LId "a", LId "x")) + ; LFun ("h", [ "a" ], LApp (LId "anon_2", [ LId "a" ])) + ; LFun + ( "f" + , [ "a" ] + , LAdd + ( LApp (LApp (LId "g", [ LId "a" ]), [ LId "a" ]) + , LApp (LApp (LId "h", [ 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 show_afun l_ast) + ; "\n---\n" + ; String.concat "\n" (List.map show_afun expected) + ; "\n====\n" + ]; + false +;; + +let anf1 = + [ AFun + ( "anon_1" + , [ "n"; "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" + , [ "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", [ AId "n"; AId "k"; AId "n" ]) + , ACExpr (CImmExpr (AId "anf_app_7")) ) ) + , ACExpr (CImmExpr (AId "anf_if_4")) ) ) ) + ; AFun ("anon_2", [ "n"; "x" ], ACExpr (CImmExpr (AId "x"))) + ; AFun + ( "fac" + , [ "n" ] + , ALet + ( "anf_app_8" + , AApp (AId "anon_2", [ AId "n" ]) + , ALet + ( "anf_app_9" + , AApp (AId "fack", [ AId "n"; AId "anf_app_8" ]) + , ACExpr (CImmExpr (AId "anf_app_9")) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_1" ll1 anf1 + +let anf4 = + [ AFun + ( "h" + , [ "a"; "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" + , [ "a"; "b" ] + , ALet + ( "anf_app_3" + , AApp (AId "h", [ AId "a"; 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", [ AId "anf_op_4"; AId "a" ]) + , ACExpr (CImmExpr (AId "anf_app_5")) ) ) ) + ] +;; + +let%test _ = anf_ok "anf_4" ll4 anf4 + +let anf5 = + [ AFun + ( "g" + , [ "a"; "b" ] + , ALet ("anf_op_1", ADiv (AId "a", AId "b"), ACExpr (CImmExpr (AId "anf_op_1"))) ) + ; AFun + ( "h" + , [ "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", [ AId "a"; AInt 1 ]) + , ALet + ( "anf_app_4" + , AApp (AId "g", [ 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", [ "a"; "x" ], ACExpr (CImmExpr (AId "x"))) + ; AFun + ( "g" + , [ "a" ] + , ALet + ( "anf_app_1" + , AApp (AId "anon_1", [ AId "a" ]) + , ACExpr (CImmExpr (AId "anf_app_1")) ) ) + ; AFun + ( "anon_2" + , [ "a"; "x" ] + , ALet ("anf_op_2", AMul (AId "a", AId "x"), ACExpr (CImmExpr (AId "anf_op_2"))) ) + ; AFun + ( "h" + , [ "a" ] + , ALet + ( "anf_app_3" + , AApp (AId "anon_2", [ AId "a" ]) + , ACExpr (CImmExpr (AId "anf_app_3")) ) ) + ; AFun + ( "f" + , [ "a" ] + , ALet + ( "anf_app_4" + , AApp (AId "g", [ AId "a" ]) + , ALet + ( "anf_app_5" + , AApp (AId "anf_app_4", [ AId "a" ]) + , ALet + ( "anf_app_6" + , AApp (AId "h", [ AId "a" ]) + , ALet + ( "anf_app_7" + , AApp (AId "anf_app_6", [ AId "a" ]) + , ALet + ( "anf_op_8" + , AAdd (AId "anf_app_5", AId "anf_app_7") + , ACExpr (CImmExpr (AId "anf_op_8")) ) ) ) ) ) ) + ] +;; + +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..500349214 --- /dev/null +++ b/slarnML/test/anf_conv_test.t @@ -0,0 +1,751 @@ + $ dune exec anf_conv_test << EOF + > let fac n = + > let rec fack n k = if (n<=1) + > then n (n-1) + > else (fun m -> k * m*n) + > in fack n (fun x -> x) + > ;; + > EOF + let anon_1 n k n m= + let anf_op_1=(k*m) + in + let anf_op_2=(anf_op_1*n) + in + anf_op_2 + + let fack n k= + let anf_op_3=(n<=1) + in + let anf_if_4=if (anf_op_3) + then ( + let anf_op_5=(n-1) + in + let anf_app_6=(n anf_op_5) + in + anf_app_6 + ) else ( + let anf_app_7=(anon_1 n k n) + in + anf_app_7) + in + anf_if_4 + + let anon_2 n x= + x + + let fac n= + let anf_app_8=(anon_2 n) + in + let anf_app_9=(fack n anf_app_8) + in + anf_app_9 + $ 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 + let h c d a e= + let anf_op_1=(d*e) + in + let anf_op_2=(c+anf_op_1) + in + let anf_op_3=(a*anf_op_2) + in + anf_op_3 + + let g a c d= + let anf_app_4=(h c d a 4) + in + anf_app_4 + + let f a= + let anf_app_5=(g a 2 3) + in + anf_app_5 + $ dune exec anf_conv_test << EOF + > let f a b = + > let g c = + > let h = (fun x -> x*(a (c*b))) in + > h a in + > g 3 + > ;; + > EOF + let anon_1 c a b x= + let anf_op_1=(c*b) + in + let anf_app_2=(a anf_op_1) + in + let anf_op_3=(x*anf_app_2) + in + anf_op_3 + + let h c a b= + let anf_app_4=(anon_1 c a b) + in + anf_app_4 + + let g a b c= + let anf_app_5=(h c a b) + in + let anf_app_6=(anf_app_5 a) + in + anf_app_6 + + let f a b= + let anf_app_7=(g a b 3) + in + anf_app_7 + $ dune exec anf_conv_test << EOF + > let f a = + > let g a b= + > let h b c= a*(b/c) in + > h 2 3 in + > g (1+0) a + > ;; + > EOF + let h a a b c= + let anf_op_1=(b/c) + in + let anf_op_2=(a*anf_op_1) + in + anf_op_2 + + let g a b= + let anf_app_3=(h a a 2 3) + in + anf_app_3 + + let f a= + let anf_op_4=(1+0) + in + let anf_app_5=(g anf_op_4 a) + in + anf_app_5 + $ dune exec anf_conv_test << EOF + > let f a = + > let g b = a / b in + > let h c = (a * c) in + > ((h 1) + (g 2)) + > ;; + > EOF + let g a b= + let anf_op_1=(a/b) + in + anf_op_1 + + let h a c= + let anf_op_2=(a*c) + in + anf_op_2 + + let f a= + let anf_app_3=(h a 1) + in + let anf_app_4=(g a 2) + in + let anf_op_5=(anf_app_3+anf_app_4) + in + anf_op_5 + $ dune exec anf_conv_test << EOF + > let f a = + > let g = (fun x -> x) in + > let h = (fun x -> a * x) in + > ((g a) + (h a)) + > ;; + > EOF + let anon_1 a x= + x + + let g a= + let anf_app_1=(anon_1 a) + in + anf_app_1 + + let anon_2 a x= + let anf_op_2=(a*x) + in + anf_op_2 + + let h a= + let anf_app_3=(anon_2 a) + in + anf_app_3 + + let f a= + let anf_app_4=(g a) + in + let anf_app_5=(anf_app_4 a) + in + let anf_app_6=(h a) + in + let anf_app_7=(anf_app_6 a) + in + let anf_op_8=(anf_app_5+anf_app_7) + in + anf_op_8 + $ 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 + let anon_1 n f n x= + let anf_app_1=(f n) + in + let anf_op_2=(x*anf_app_1) + in + anf_op_2 + + let fack n f= + let anf_op_3=(n<=1) + in + let anf_if_4=if (anf_op_3) + then ( + let anf_app_5=(f 1) + in + anf_app_5 + ) else ( + let anf_op_6=(n-1) + in + let anf_app_7=(anon_1 n f n) + in + let anf_app_8=(fack anf_op_6 anf_app_7) + in + anf_app_8) + in + anf_if_4 + + let anon_2 n x= + x + + let fac n= + let anf_app_9=(anon_2 n) + in + let anf_app_10=(fack n anf_app_9) + in + anf_app_10 + $ 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 + let 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 + + let fac n= + let anf_app_6=(fack n) + in + anf_app_6 + $ 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 + let h c d a e= + let anf_op_1=(d*e) + in + let anf_op_2=(c+anf_op_1) + in + let anf_op_3=(a*anf_op_2) + in + anf_op_3 + + let g a c d= + let anf_app_4=(h c d a 4) + in + anf_app_4 + + let f a= + let anf_app_5=(g a 2 3) + in + anf_app_5 + $ dune exec anf_conv_test < manytests/do_not_type/001.ml + let recfac 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 + $ dune exec anf_conv_test < manytests/do_not_type/002if.ml + let 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 + let anon_2 x f= + let anf_app_1=(x x) + in + let anf_app_2=(anf_app_1 f) + in + anf_app_2 + + let anon_1 f x= + let anf_app_3=(anon_2 x f) + in + let anf_app_4=(f anf_app_3) + in + anf_app_4 + + let fix f= + let anf_app_5=(anon_1 f) + in + anf_app_5 + + let anon_4 x f= + let anf_app_6=(x x) + in + let anf_app_7=(anf_app_6 f) + in + anf_app_7 + + let anon_3 x= + let anf_app_8=(anon_4 x) + in + let anf_app_9=(f anf_app_8) + in + anf_app_9 + $ dune exec anf_conv_test < manytests/typed/001fac.ml + let 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 + + let main = + let anf_app_6=(fac 4) + in + let anf_app_7=(print_int anf_app_6) + in + let ()=anf_app_7 + in + 0 + $ dune exec anf_conv_test < manytests/typed/002fac.ml + let anon_1 n k p= + let anf_op_1=(p*n) + in + let anf_app_2=(k anf_op_1) + in + anf_app_2 + + let 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=(anon_1 n k) + in + let anf_app_8=(fac_cps anf_op_6 anf_app_7) + in + anf_app_8) + in + anf_if_4 + + let anon_2 print_int= + print_int + + let main = + let anf_app_9=(anon_2 ) + in + let anf_app_10=(fac_cps 4 anf_app_9) + in + let anf_app_11=(print_int anf_app_10) + in + let ()=anf_app_11 + in + 0 + $ dune exec anf_conv_test < manytests/typed/003fib.ml + let n1 a b n= + let anf_op_1=(n-1) + in + anf_op_1 + + let ab a b n= + let anf_op_2=(a+b) + in + anf_op_2 + + let 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_app_5=(ab a b n) + in + let anf_app_6=(n1 a b n) + in + let anf_app_7=(fib_acc b anf_app_5 anf_app_6) + in + anf_app_7) + in + anf_if_4 + + let fib n= + let anf_op_8=(n<2) + in + let anf_if_9=if (anf_op_8) + then ( + n + ) else ( + let anf_op_10=(n-1) + in + let anf_op_11=(n-2) + in + let anf_app_12=(fib anf_op_11) + in + let anf_op_13=(anf_op_10+anf_app_12) + in + let anf_app_14=(fib anf_op_13) + in + anf_app_14) + in + anf_if_9 + + let main = + let anf_app_15=(fib_acc 0 1 4) + in + let anf_app_16=(print_int anf_app_15) + in + let ()=anf_app_16 + in + let anf_app_17=(fib 4) + in + let anf_app_18=(print_int anf_app_17) + in + let ()=anf_app_18 + in + 0 + $ dune exec anf_conv_test < manytests/typed/004manyargs.ml + let wrap f= + let anf_op_1=(1=1) + in + let anf_if_2=if (anf_op_1) + then ( + f + ) else ( + f) + in + anf_if_2 + + let a_0 a b c= + let anf_app_3=(print_int a) + in + anf_app_3 + + let b_0 a b c= + let anf_app_4=(print_int b) + in + anf_app_4 + + let c_0 a b c= + let anf_app_5=(print_int c) + in + anf_app_5 + + let test3 a b c= + 0 + + let test10 a b c d e f g h i j= + let anf_op_6=(a+b) + in + let anf_op_7=(anf_op_6+c) + in + let anf_op_8=(anf_op_7+d) + in + let anf_op_9=(anf_op_8+e) + in + let anf_op_10=(anf_op_9+f) + in + let anf_op_11=(anf_op_10+g) + in + let anf_op_12=(anf_op_11+h) + in + let anf_op_13=(anf_op_12+i) + in + let anf_op_14=(anf_op_13+j) + in + anf_op_14 + + let main = + let anf_app_15=(test10 ) + in + let anf_app_16=(wrap anf_app_15) + in + let anf_app_17=(anf_app_16 1) + in + let anf_app_18=(anf_app_17 10) + in + let anf_app_19=(anf_app_18 100) + in + let anf_app_20=(anf_app_19 1000) + in + let anf_app_21=(anf_app_20 10000) + in + let anf_app_22=(anf_app_21 100000) + in + let anf_app_23=(anf_app_22 1000000) + in + let anf_app_24=(anf_app_23 10000000) + in + let anf_app_25=(anf_app_24 100000000) + in + let anf_app_26=(anf_app_25 1000000000) + in + let rez=anf_app_26 + in + let anf_app_27=(print_int rez) + in + let ()=anf_app_27 + in + let anf_app_28=(test3 ) + in + let anf_app_29=(wrap anf_app_28) + in + let anf_app_30=(anf_app_29 1) + in + let anf_app_31=(anf_app_30 10) + in + let anf_app_32=(anf_app_31 100) + in + let temp2=anf_app_32 + in + 0 + $ dune exec anf_conv_test < manytests/typed/005fix.ml + let fix f x= + let anf_app_1=(fix f) + in + let anf_app_2=(f anf_app_1) + in + let anf_app_3=(anf_app_2 x) + in + anf_app_3 + + let fac self n= + let anf_op_4=(n<=1) + in + let anf_if_5=if (anf_op_4) + then ( + 1 + ) else ( + let anf_op_6=(n-1) + in + let anf_app_7=(self anf_op_6) + in + let anf_op_8=(n*anf_app_7) + in + anf_op_8) + in + anf_if_5 + + let main = + let anf_app_9=(fac ) + in + let anf_app_10=(fix anf_app_9 6) + in + let anf_app_11=(print_int anf_app_10) + in + let ()=anf_app_11 + in + 0 + $ dune exec anf_conv_test < manytests/typed/006partial.ml + let anon_1 b foo= + let anf_op_1=(foo+2) + in + anf_op_1 + + let anon_2 b foo= + let anf_op_2=(foo*10) + in + anf_op_2 + + let foo b= + let anf_if_3=if (b) + then ( + let anf_app_4=(anon_1 b) + in + anf_app_4 + ) else ( + let anf_app_5=(anon_2 b) + in + anf_app_5) + in + anf_if_3 + + let foo_0 x= + let anf_app_6=(foo true) + in + let anf_app_7=(foo false) + in + let anf_app_8=(foo true) + in + let anf_app_9=(foo false) + in + let anf_app_10=(anf_app_9 x) + in + let anf_app_11=(anf_app_8 anf_app_10) + in + let anf_app_12=(anf_app_7 anf_app_11) + in + let anf_app_13=(anf_app_6 anf_app_12) + in + anf_app_13 + + let main = + let anf_app_14=(foo_0 11) + in + let anf_app_15=(print_int anf_app_14) + in + let ()=anf_app_15 + in + 0 + $ dune exec anf_conv_test < manytests/typed/006partial2.ml + let foo a b c= + let anf_app_1=(print_int a) + in + let ()=anf_app_1 + in + let anf_app_2=(print_int b) + in + let ()=anf_app_2 + in + let anf_app_3=(print_int c) + in + let ()=anf_app_3 + in + let anf_op_4=(b*c) + in + let anf_op_5=(a+anf_op_4) + in + anf_op_5 + + let main = + let anf_app_6=(foo 1) + in + let foo_0=anf_app_6 + in + let anf_app_7=(foo_0 2) + in + let foo_0_2=anf_app_7 + in + let anf_app_8=(foo_0_2 3) + in + let foo_0_2_4=anf_app_8 + in + let anf_app_9=(print_int foo_0_2_4) + in + let ()=anf_app_9 + in + 0 + $ dune exec anf_conv_test < manytests/typed/006partial3.ml + let anon_2 b a c= + let anf_app_1=(print_int c) + in + anf_app_1 + + let anon_1 a b= + let anf_app_2=(print_int b) + in + let ()=anf_app_2 + in + let anf_app_3=(anon_2 b a) + in + anf_app_3 + + let foo a= + let anf_app_4=(print_int a) + in + let ()=anf_app_4 + in + let anf_app_5=(anon_1 a) + in + anf_app_5 + + let main = + let anf_app_6=(foo 4) + in + let anf_app_7=(anf_app_6 8) + in + let anf_app_8=(anf_app_7 9) + in + let ()=anf_app_8 + in + 0 + $ 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 + let h c d a e= + let anf_op_1=(d*e) + in + let anf_op_2=(c+anf_op_1) + in + let anf_op_3=(a*anf_op_2) + in + anf_op_3 + + let g a c d= + let anf_app_4=(h c d a 4) + in + anf_app_4 + + let f a= + let anf_app_5=(g a 2 3) + in + anf_app_5 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..6e2492bc5 --- /dev/null +++ b/slarnML/test/clos_conv_test.t @@ -0,0 +1,125 @@ + $ dune exec clos_conv_test << EOF + > let fac n = + > let rec fack n k = if (n<=1) + > then n (n-1) + > else (fun m -> k * m*n) + > in fack n (fun x -> x) + > ;; + > EOF + let fac n=(let rec fack n k=(if ((n<=1)) then ((n (n-1))) else (((fun n k n m->((k*m)*n)) n k n))) in ((fack n ((fun n x->x) 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 c d a e=((a*(c+(d*e)))) in (((h c d a) 4))) in (((g a) 2 3))) + $ dune exec clos_conv_test << EOF + > let f a b = + > let g c = + > let h = (fun x -> x*(a (c*b))) in + > h a in + > g 3 + > ;; + > EOF + let f a b=(let g a b c=(let h c a b=(((fun c a b x->(x*(a (c*b)))) c a b)) in (((h c a b) a))) in (((g a b) 3))) + $ dune exec clos_conv_test << EOF + > let f a = + > let g a b= + > let h b c= a*(b/c) in + > h 2 3 in + > g (1+0) a + > ;; + > EOF + let f a=(let g a b=(let h a a b c=((a*(b/c))) in (((h a a) 2 3))) in ((g (1+0) a))) + $ dune exec clos_conv_test << EOF + > let f a = + > let g b = a / b in + > let h c = (a * c) in + > ((h 1) + (g 2)) + > ;; + > EOF + let f a=(let g a b=((a/b)) in (let h a c=((a*c)) in ((((h a) 1)+((g a) 2))))) + $ dune exec clos_conv_test << EOF + > let f a = + > let g = (fun x -> x) in + > let h = (fun x -> a * x) in + > ((g a) + (h a)) + > ;; + > EOF + let f a=(let g a=(((fun a x->x) a)) in (let h a=(((fun a x->(a*x)) a)) in ((((g a) a)+((h a) a))))) + $ 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 n x->(x*(f n))) n f n)))) in ((fack n ((fun n x->x) n)))) + $ 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 d = a * (c + d * e) in + > (h 4) + > in + > (g 2 3) + > EOF + let f a=(let g a c d=(let h c a e d=((a*(c+(d*e)))) in (((h c a) 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/do_not_type/003occurs.ml + let fix f=(((fun f x->(f ((fun x f->(x x f)) x f))) f)) + ((fun x->(f ((fun x f->(x x f)) x))) ) + $ 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 a b n=((n-1)) in (let ab a b n=((a+b)) in ((fib_acc b (ab a b n) (n1 a b n)))))) + 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_0 a b c=((print_int a)) in (let b_0 a b c=((print_int b)) in (let c_0 a b 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 b foo->(foo+2)) b)) else (((fun b foo->(foo*10)) b))) + let foo_0 x=((foo true (foo false (foo true (foo false x))))) + let main=(let ()=((print_int (foo_0 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_0=((foo 1)) in (let foo_0_2=((foo_0 2)) in (let foo_0_2_4=((foo_0_2 3)) in (let ()=((print_int foo_0_2_4)) in (0))))) + $ dune exec clos_conv_test < manytests/typed/006partial3.ml + let foo a=(let ()=((print_int a)) in (((fun a b->let ()=((print_int b)) in (((fun b a c->(print_int c)) b a))) a))) + let main=(let ()=((foo 4 8 9)) in (0)) + $ 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 c d a e=((a*(c+(d*e)))) in (((h c d a) 4))) in (((g a) 2 3))) diff --git a/slarnML/test/dune b/slarnML/test/dune new file mode 100644 index 000000000..816bd0ee8 --- /dev/null +++ b/slarnML/test/dune @@ -0,0 +1,157 @@ +(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 + print.S + part_app.c + ../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..f57b2be7d 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..e4c7b9884 --- /dev/null +++ b/slarnML/test/lambda_lifting_test.t @@ -0,0 +1,158 @@ + $ dune exec lambda_lifting_test << EOF + > let fac n = + > let rec fack n k = if (n<=1) + > then n (n-1) + > else (fun m -> k * m*n) + > in fack n (fun x -> x) + > ;; + > EOF + let anon_1 n k n m =(((k*m)*n)) + let fack n k =(if ((n<=1)) then ((n (n-1))) else ((anon_1 n k n))) + let anon_2 n x =(x) + let fac n =((fack n (anon_2 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 + let h c d a e =((a*(c+(d*e)))) + let g a c d =((h c d a 4)) + let f a =((g a 2 3)) + $ dune exec lambda_lifting_test << EOF + > let f a b = + > let g c = + > let h = (fun x -> x*(a (c*b))) in + > h a in + > g 3 + > ;; + > EOF + let anon_1 c a b x =((x*(a (c*b)))) + let h c a b =((anon_1 c a b)) + let g a b c =(((h c a b) a)) + let f a b =((g a b 3)) + $ dune exec lambda_lifting_test << EOF + > let f a = + > let g a b= + > let h b c= a*(b/c) in + > h 2 3 in + > g (1+0) a + > ;; + > EOF + let h a a b c =((a*(b/c))) + let g a b =((h a a 2 3)) + let f a =((g (1+0) a)) + $ dune exec lambda_lifting_test << EOF + > let f a = + > let g b = a / b in + > let h c = (a * c) in + > ((h 1) + (g 2)) + > ;; + > EOF + let g a b =((a/b)) + let h a c =((a*c)) + let f a =(((h a 1)+(g a 2))) + $ dune exec lambda_lifting_test << EOF + > let f a = + > let g = (fun x -> x) in + > let h = (fun x -> a * x) in + > ((g a) + (h a)) + > ;; + > EOF + let anon_1 a x =(x) + let g a =((anon_1 a)) + let anon_2 a x =((a*x)) + let h a =((anon_2 a)) + let f a =((((g a) a)+((h a) a))) + $ 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 + let anon_1 n f n x =((x*(f n))) + let fack n f =(if ((n<=1)) then ((f 1)) else ((fack (n-1) (anon_1 n f n)))) + let anon_2 n x =(x) + let fac n =((fack n (anon_2 n))) + $ 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 + let fack n =(if ((n<1)) then (n) else ((n*(fack (n-1))))) + let fac n =((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 + let h c d a e =((a*(c+(d*e)))) + let g a c d =((h c d a 4)) + let f a =((g a 2 3)) + $ dune exec lambda_lifting_test < manytests/do_not_type/001.ml + let recfac n =(if ((n<=1)) then (1) else ((n*(fac (n-1))))) + $ dune exec lambda_lifting_test < manytests/do_not_type/002if.ml + let main =(if (true) then (1) else (false)) + $ dune exec lambda_lifting_test < manytests/do_not_type/003occurs.ml + let anon_2 x f =(((x x) f)) + let anon_1 f x =((f (anon_2 x f))) + let fix f =((anon_1 f)) + let anon_4 x f =(((x x) f)) + let anon_3 x =((f (anon_4 x))) + $ dune exec lambda_lifting_test < manytests/typed/001fac.ml + let fac n =(if ((n<=1)) then (1) else ((n*(fac (n-1))))) + let main =(let () = ((print_int (fac 4)) in 0)) + $ dune exec lambda_lifting_test < manytests/typed/002fac.ml + let anon_1 n k p =((k (p*n))) + let fac_cps n k =(if ((n=1)) then ((k 1)) else ((fac_cps (n-1) (anon_1 n k)))) + let anon_2 print_int =(print_int) + let main =(let () = ((print_int (fac_cps 4 (anon_2 ))) in 0)) + $ dune exec lambda_lifting_test < manytests/typed/003fib.ml + let n1 a b n =((n-1)) + let ab a b n =((a+b)) + let fib_acc a b n =(if ((n=1)) then (b) else ((fib_acc b (ab a b n) (n1 a b n)))) + let 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 lambda_lifting_test < manytests/typed/004manyargs.ml + let wrap f =(if ((1=1)) then (f) else (f)) + let a_0 a b c =((print_int a)) + let b_0 a b c =((print_int b)) + let c_0 a b c =((print_int c)) + let test3 a b c =(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 lambda_lifting_test < manytests/typed/005fix.ml + let 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 lambda_lifting_test < manytests/typed/006partial.ml + let anon_1 b foo =((foo+2)) + let anon_2 b foo =((foo*10)) + let foo b =(if (b) then ((anon_1 b)) else ((anon_2 b))) + let foo_0 x =(((foo true) ((foo false) ((foo true) ((foo false) x))))) + let main =(let () = ((print_int (foo_0 11)) in 0)) + $ dune exec lambda_lifting_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_0 = ((foo 1) in let foo_0_2 = ((foo_0 2) in let foo_0_2_4 = ((foo_0_2 3) in let () = ((print_int foo_0_2_4) in 0))))) + $ dune exec lambda_lifting_test < manytests/typed/006partial3.ml + let anon_2 b a c =((print_int c)) + let anon_1 a b =(let () = ((print_int b) in (anon_2 b a))) + let foo a =(let () = ((print_int a) in (anon_1 a))) + let main =(let () = ((((foo 4) 8) 9) in 0)) + $ 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 + let h c d a e =((a*(c+(d*e)))) + let g a c d =((h c d a 4)) + let f a =((g a 2 3)) 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..9627fdbf2 --- /dev/null +++ b/slarnML/test/parser_tests.t @@ -0,0 +1,137 @@ + $ 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 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 << 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 c d=(let h e=((a*(c+(d*e)))) in ((h 4))) in ((g 2 3))) + $ dune exec parser_test < manytests/typed/007order.ml + let _start () () a () b _c () d __=(let ()=((print_int (a+b))) in (let ()=((print_int __)) in ((((a*b)/_c)+d)))) + let main=((print_int (_start (print_int 1) (print_int 2) 3 (print_int 4) 100 1000 (print_int (-1)) 10000 (-555555)))) diff --git a/slarnML/test/part_app.c b/slarnML/test/part_app.c new file mode 120000 index 000000000..7e186af3a --- /dev/null +++ b/slarnML/test/part_app.c @@ -0,0 +1 @@ +../lib/riscv64/part_app.c \ No newline at end of file diff --git a/slarnML/test/print.S b/slarnML/test/print.S new file mode 120000 index 000000000..e1f0ae463 --- /dev/null +++ b/slarnML/test/print.S @@ -0,0 +1 @@ +../lib/riscv64/print.S \ No newline at end of file diff --git a/slarnML/test/riscv64_instr_test.ml b/slarnML/test/riscv64_instr_test.ml new file mode 100644 index 000000000..b7591dc5c --- /dev/null +++ b/slarnML/test/riscv64_instr_test.ml @@ -0,0 +1,22 @@ +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) + ^ "\n") + | 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..2d3e7e7c3 --- /dev/null +++ b/slarnML/test/riscv64_instr_test.t @@ -0,0 +1,1604 @@ + $ 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 + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + h: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a3,-80(s0) + sd a2,-72(s0) + sd a1,-64(s0) + sd a0,-56(s0) + mul t0,a1,a3 + add t1,a0,t0 + mul t2,a2,t1 + mv a0,t2 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + g: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(s0) + lui a0,%hi(h) + addi a0,a0,%lo(h) + li a6,4 + ld a5,-64(s0) + ld a4,-80(s0) + ld a3,-72(s0) + li a2,4 + li a1,4 + call part_app + mv a0,a0 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + f: + addi sp,sp,-64 + sd ra,48(sp) + sd s0,40(sp) + addi s0,sp,64 + sd a0,-64(s0) + lui a0,%hi(g) + addi a0,a0,%lo(g) + li a5,3 + li a4,2 + ld a3,-64(s0) + li a2,3 + li a1,3 + call part_app + mv a0,a0 + ld ra,48(sp) + ld s0,40(sp) + addi sp,sp,64 + ret + $ 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 + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + anon_1: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a3,-96(s0) + sd a2,-88(s0) + sd a1,-80(s0) + ld a0,-80(s0) + ld a3,-88(s0) + li a2,1 + li a1,0 + call part_app + ld a1,-96(s0) + mul a2,a1,a0 + mv a0,a2 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + fack: + addi sp,sp,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a1,-160(s0) + sd a0,-152(s0) + li t0,1 + ble a0,t0,.tag_anf_op_3 + li t1,1 + sub t2,a0,t1 + sd t2,-32(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + mv a5,a3 + ld a4,-160(s0) + ld a3,-152(s0) + li a2,3 + li a1,4 + call part_app + sd a0,-40(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a4,-40(s0) + ld a3,-32(s0) + li a2,2 + li a1,2 + call part_app + j .tag_anf_op_3_t + .tag_anf_op_3: + sd a0,-48(s0) + ld a0,-160(s0) + li a3,1 + li a2,1 + li a1,0 + call part_app + .tag_anf_op_3_t: + sd a0,-56(s0) + mv a0,a0 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + ret + anon_2: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + sd a1,-32(s0) + sd a0,-24(s0) + mv a0,a1 + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + fac: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-96(s0) + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + ld a3,-96(s0) + li a2,1 + li a1,2 + call part_app + sd a0,-32(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a4,-32(s0) + ld a3,-96(s0) + li a2,2 + li a1,2 + call part_app + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + $ dune exec riscv64_instr_test << EOF + > let f a = + > let g = (fun x -> x) in + > let h = (fun x -> a * x) in + > ((g a) + (h a)) + > ;; + > EOF + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + anon_1: + addi sp,sp,-32 + sd ra,24(sp) + sd s0,16(sp) + addi s0,sp,32 + sd a1,-32(s0) + sd a0,-24(s0) + mv a0,a1 + ld ra,24(sp) + ld s0,16(sp) + addi sp,sp,32 + ret + g: + addi sp,sp,-64 + sd ra,48(sp) + sd s0,40(sp) + addi s0,sp,64 + sd a0,-64(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + ld a3,-64(s0) + li a2,1 + li a1,2 + call part_app + mv a0,a0 + ld ra,48(sp) + ld s0,40(sp) + addi sp,sp,64 + ret + anon_2: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a1,-48(s0) + sd a0,-40(s0) + mul t0,a0,a1 + mv a0,t0 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + h: + addi sp,sp,-64 + sd ra,48(sp) + sd s0,40(sp) + addi s0,sp,64 + sd a0,-64(s0) + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + ld a3,-64(s0) + li a2,1 + li a1,2 + call part_app + mv a0,a0 + ld ra,48(sp) + ld s0,40(sp) + addi sp,sp,64 + ret + f: + addi sp,sp,-160 + sd ra,152(sp) + sd s0,144(sp) + addi s0,sp,160 + sd a0,-160(s0) + lui a0,%hi(g) + addi a0,a0,%lo(g) + ld a3,-160(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + ld a3,-160(s0) + li a2,1 + li a1,0 + call part_app + sd a0,-40(s0) + lui a0,%hi(h) + addi a0,a0,%lo(h) + ld a3,-160(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-48(s0) + ld a0,-48(s0) + ld a3,-160(s0) + li a2,1 + li a1,0 + call part_app + ld t0,-40(s0) + add t1,t0,a0 + mv a0,t1 + ld ra,152(sp) + ld s0,144(sp) + addi sp,sp,160 + ret + $ 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 main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + fack: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-96(s0) + li t0,1 + blt a0,t0,.tag_anf_op_1 + li t1,1 + sub t2,a0,t1 + sd t2,-32(s0) + lui a0,%hi(fack) + addi a0,a0,%lo(fack) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + ld t2,-96(s0) + mul t1,t2,a0 + sd a0,-40(s0) + mv a0,t1 + j .tag_anf_op_1_t + .tag_anf_op_1: + mv a0,t2 + .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,-64 + sd ra,48(sp) + sd s0,40(sp) + addi s0,sp,64 + 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,48(sp) + ld s0,40(sp) + addi sp,sp,64 + ret + + $ dune exec riscv64_instr_test < manytests/do_not_type/002if.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + main2: + 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/typed/001fac.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + fac: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + sd a0,-96(s0) + li t0,1 + ble a0,t0,.tag_anf_op_1 + li t1,1 + sub t2,a0,t1 + sd t2,-32(s0) + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + ld t2,-96(s0) + mul t1,t2,a0 + sd a0,-40(s0) + mv a0,t1 + j .tag_anf_op_1_t + .tag_anf_op_1: + li a0,1 + .tag_anf_op_1_t: + mv a0,a0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + main2: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + li a3,4 + li a2,1 + li a1,1 + 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) + li t0,0 + mv a0,t0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + + $ dune exec riscv64_instr_test < manytests/typed/002fac.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + 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,-32(s0) + ld a0,-72(s0) + ld a3,-32(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,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a1,-160(s0) + sd a0,-152(s0) + li t0,1 + beq a0,t0,.tag_anf_op_3 + li t1,1 + sub t2,a0,t1 + sd t2,-32(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + ld a4,-160(s0) + ld a3,-152(s0) + li a2,2 + li a1,3 + call part_app + sd a0,-40(s0) + lui a0,%hi(fac_cps) + addi a0,a0,%lo(fac_cps) + ld a4,-40(s0) + ld a3,-32(s0) + li a2,2 + li a1,2 + call part_app + j .tag_anf_op_3_t + .tag_anf_op_3: + sd a0,-48(s0) + ld a0,-160(s0) + li a3,1 + li a2,1 + li a1,0 + call part_app + .tag_anf_op_3_t: + sd a0,-56(s0) + mv a0,a0 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + ret + anon_2: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + addi s0,sp,32 + sd a0,-32(s0) + mv a0,a0 + ld ra,16(sp) + ld s0,8(sp) + addi sp,sp,32 + ret + main2: + addi sp,sp,-128 + sd ra,112(sp) + sd s0,104(sp) + addi s0,sp,128 + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + li a2,0 + li a1,1 + call part_app + sd a0,-32(s0) + lui a0,%hi(fac_cps) + addi a0,a0,%lo(fac_cps) + ld a4,-32(s0) + li a3,4 + li a2,2 + li a1,2 + call part_app + sd a0,-40(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-40(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-48(s0) + li t0,0 + mv a0,t0 + ld ra,112(sp) + ld s0,104(sp) + addi sp,sp,128 + ret + + $ dune exec riscv64_instr_test < manytests/typed/003fib.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + n1: + addi sp,sp,-48 + sd ra,40(sp) + sd s0,32(sp) + addi s0,sp,48 + sd a2,-48(s0) + sd a1,-40(s0) + sd a0,-32(s0) + li t0,1 + sub t1,a2,t0 + mv a0,t1 + ld ra,40(sp) + ld s0,32(sp) + addi sp,sp,48 + ret + ab: + addi sp,sp,-48 + sd ra,40(sp) + sd s0,32(sp) + addi s0,sp,48 + sd a2,-48(s0) + sd a1,-40(s0) + sd a0,-32(s0) + add t0,a0,a1 + mv a0,t0 + ld ra,40(sp) + ld s0,32(sp) + addi sp,sp,48 + ret + fib_acc: + addi sp,sp,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a2,-160(s0) + sd a1,-152(s0) + sd a0,-144(s0) + li t0,1 + beq a2,t0,.tag_anf_op_3 + lui a0,%hi(ab) + addi a0,a0,%lo(ab) + ld a5,-160(s0) + ld a4,-152(s0) + ld a3,-144(s0) + li a2,3 + li a1,3 + call part_app + sd a0,-32(s0) + lui a0,%hi(n1) + addi a0,a0,%lo(n1) + ld a5,-160(s0) + ld a4,-152(s0) + ld a3,-144(s0) + li a2,3 + li a1,3 + call part_app + sd a0,-40(s0) + lui a0,%hi(fib_acc) + addi a0,a0,%lo(fib_acc) + ld a5,-40(s0) + ld a4,-32(s0) + ld a3,-152(s0) + li a2,3 + li a1,3 + call part_app + j .tag_anf_op_3_t + .tag_anf_op_3: + ld t0,-152(s0) + sd a0,-48(s0) + mv a0,t0 + .tag_anf_op_3_t: + mv a0,a0 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + 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 a0,t0,.tag_anf_op_8 + li t1,1 + sub t2,a0,t1 + li t3,2 + sub t4,a0,t3 + sd t2,-32(s0) + sd t4,-40(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + ld a3,-40(s0) + li a2,1 + li a1,1 + call part_app + ld t4,-32(s0) + add t3,t4,a0 + sd a0,-48(s0) + sd t3,-56(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + ld a3,-56(s0) + li a2,1 + li a1,1 + call part_app + j .tag_anf_op_8_t + .tag_anf_op_8: + ld t3,-128(s0) + sd a0,-64(s0) + mv a0,t3 + .tag_anf_op_8_t: + mv a0,a0 + ld ra,120(sp) + ld s0,112(sp) + addi sp,sp,128 + ret + main2: + addi sp,sp,-160 + sd ra,152(sp) + sd s0,144(sp) + addi s0,sp,160 + 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,-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) + sd a0,-48(s0) + lui a0,%hi(fib) + addi a0,a0,%lo(fib) + li a3,4 + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-56(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-64(s0) + li t0,0 + mv a0,t0 + ld ra,152(sp) + ld s0,144(sp) + addi sp,sp,160 + ret + + $ dune exec riscv64_instr_test < manytests/typed/004manyargs.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + wrap: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a0,-48(s0) + li t0,1 + li t1,1 + beq t0,t1,.tag_anf_op_1 + j .tag_anf_op_1_t + .tag_anf_op_1: + .tag_anf_op_1_t: + mv a0,a0 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + a_0: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-64(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + b_0: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(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 + mv a0,a0 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + c_0: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-80(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + test3: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a2,-48(s0) + sd a1,-40(s0) + sd a0,-32(s0) + li t0,0 + mv a0,t0 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + test10: + addi sp,sp,-160 + sd ra,144(sp) + sd s0,136(sp) + addi s0,sp,160 + sd a7,-160(s0) + sd a6,-152(s0) + sd a5,-144(s0) + sd a4,-136(s0) + sd a3,-128(s0) + sd a2,-120(s0) + sd a1,-112(s0) + sd a0,-104(s0) + add t0,a0,a1 + add t1,t0,a2 + add t2,t1,a3 + add t3,t2,a4 + add t4,t3,a5 + add t5,t4,a6 + add t6,t5,a7 + ld a7,0(s0) + add a6,t6,a7 + ld a5,8(s0) + add a4,a6,a5 + mv a0,a4 + ld ra,144(sp) + ld s0,136(sp) + addi sp,sp,160 + ret + main2: + addi sp,sp,-624 + sd ra,608(sp) + sd s0,600(sp) + addi s0,sp,624 + lui a0,%hi(test10) + addi a0,a0,%lo(test10) + li a2,0 + li a1,10 + call part_app + sd a0,-32(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + ld a3,-32(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-40(s0) + ld a0,-40(s0) + li a3,1 + li a2,1 + li a1,0 + call part_app + sd a0,-48(s0) + ld a0,-48(s0) + li a3,10 + li a2,1 + li a1,0 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + li a3,100 + li a2,1 + li a1,0 + call part_app + sd a0,-64(s0) + ld a0,-64(s0) + li a3,1000 + li a2,1 + li a1,0 + call part_app + sd a0,-72(s0) + ld a0,-72(s0) + li a3,10000 + li a2,1 + li a1,0 + call part_app + sd a0,-80(s0) + ld a0,-80(s0) + li a3,100000 + li a2,1 + li a1,0 + call part_app + sd a0,-88(s0) + ld a0,-88(s0) + li a3,1000000 + li a2,1 + li a1,0 + call part_app + sd a0,-96(s0) + ld a0,-96(s0) + li a3,10000000 + li a2,1 + li a1,0 + call part_app + sd a0,-104(s0) + ld a0,-104(s0) + li a3,100000000 + li a2,1 + li a1,0 + call part_app + sd a0,-112(s0) + ld a0,-112(s0) + li a3,1000000000 + li a2,1 + li a1,0 + call part_app + sd a0,-120(s0) + sd a0,-128(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-128(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-136(s0) + sd a0,-144(s0) + lui a0,%hi(test3) + addi a0,a0,%lo(test3) + li a2,0 + li a1,3 + call part_app + sd a0,-152(s0) + lui a0,%hi(wrap) + addi a0,a0,%lo(wrap) + ld a3,-152(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-160(s0) + ld a0,-160(s0) + li a3,1 + li a2,1 + li a1,0 + call part_app + sd a0,-168(s0) + ld a0,-168(s0) + li a3,10 + li a2,1 + li a1,0 + call part_app + sd a0,-176(s0) + ld a0,-176(s0) + li a3,100 + li a2,1 + li a1,0 + call part_app + sd a0,-184(s0) + li t0,0 + mv a0,t0 + ld ra,608(sp) + ld s0,600(sp) + addi sp,sp,624 + ret + + $ dune exec riscv64_instr_test < manytests/typed/005fix.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + fix: + addi sp,sp,-128 + sd ra,120(sp) + sd s0,112(sp) + addi s0,sp,128 + sd a1,-128(s0) + sd a0,-120(s0) + lui a0,%hi(fix) + addi a0,a0,%lo(fix) + ld a3,-120(s0) + li a2,1 + li a1,2 + call part_app + sd a0,-32(s0) + ld a0,-120(s0) + ld a3,-32(s0) + li a2,1 + li a1,0 + call part_app + sd a0,-40(s0) + ld a0,-40(s0) + ld a3,-128(s0) + li a2,1 + li a1,0 + call part_app + mv a0,a0 + ld ra,120(sp) + ld s0,112(sp) + addi sp,sp,128 + ret + fac: + addi sp,sp,-96 + sd ra,88(sp) + sd s0,80(sp) + addi s0,sp,96 + sd a1,-96(s0) + sd a0,-88(s0) + li t0,1 + ble a1,t0,.tag_anf_op_4 + li t1,1 + sub t2,a1,t1 + sd t2,-32(s0) + ld a0,-88(s0) + ld a3,-32(s0) + li a2,1 + li a1,0 + call part_app + ld t2,-96(s0) + mul t1,t2,a0 + sd a0,-40(s0) + mv a0,t1 + j .tag_anf_op_4_t + .tag_anf_op_4: + li a0,1 + .tag_anf_op_4_t: + mv a0,a0 + ld ra,88(sp) + ld s0,80(sp) + addi sp,sp,96 + ret + main2: + addi sp,sp,-128 + sd ra,112(sp) + sd s0,104(sp) + addi s0,sp,128 + lui a0,%hi(fac) + addi a0,a0,%lo(fac) + li a2,0 + li a1,2 + call part_app + sd a0,-32(s0) + lui a0,%hi(fix) + addi a0,a0,%lo(fix) + li a4,6 + ld a3,-32(s0) + li a2,2 + li a1,2 + call part_app + sd a0,-40(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-40(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-48(s0) + li t0,0 + mv a0,t0 + ld ra,112(sp) + ld s0,104(sp) + addi sp,sp,128 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + anon_1: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a1,-48(s0) + sd a0,-40(s0) + li t0,2 + add t1,a1,t0 + mv a0,t1 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + anon_2: + addi sp,sp,-48 + sd ra,32(sp) + sd s0,24(sp) + addi s0,sp,48 + sd a1,-48(s0) + sd a0,-40(s0) + li t0,10 + mul t1,a1,t0 + mv a0,t1 + ld ra,32(sp) + ld s0,24(sp) + addi sp,sp,48 + ret + foo: + addi sp,sp,-96 + sd ra,88(sp) + sd s0,80(sp) + addi s0,sp,96 + sd a0,-96(s0) + beqz a0,.tag_if_bnch + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + ld a3,-96(s0) + li a2,1 + li a1,2 + 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) + ld a3,-96(s0) + li a2,1 + li a1,2 + call part_app + .tag_if_bnch_t: + sd a0,-40(s0) + mv a0,a0 + ld ra,88(sp) + ld s0,80(sp) + addi sp,sp,96 + ret + foo_0: + addi sp,sp,-288 + sd ra,272(sp) + sd s0,264(sp) + addi s0,sp,288 + sd a0,-288(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,1 + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,0 + li a2,1 + li a1,1 + call part_app + sd a0,-40(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,1 + li a2,1 + li a1,1 + call part_app + sd a0,-48(s0) + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,0 + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a0,-56(s0) + ld a3,-288(s0) + li a2,1 + li a1,0 + call part_app + sd a0,-64(s0) + ld a0,-48(s0) + ld a3,-64(s0) + li a2,1 + li a1,0 + call part_app + sd a0,-72(s0) + ld a0,-40(s0) + ld a3,-72(s0) + li a2,1 + li a1,0 + call part_app + sd a0,-80(s0) + ld a0,-32(s0) + ld a3,-80(s0) + li a2,1 + li a1,0 + call part_app + mv a0,a0 + ld ra,272(sp) + ld s0,264(sp) + addi sp,sp,288 + ret + main2: + addi sp,sp,-96 + sd ra,80(sp) + sd s0,72(sp) + addi s0,sp,96 + lui a0,%hi(foo_0) + addi a0,a0,%lo(foo_0) + li a3,11 + li a2,1 + li a1,1 + 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) + li t0,0 + mv a0,t0 + ld ra,80(sp) + ld s0,72(sp) + addi sp,sp,96 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial2.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + foo: + addi sp,sp,-176 + sd ra,168(sp) + sd s0,160(sp) + addi s0,sp,176 + sd a2,-176(s0) + sd a1,-168(s0) + sd a0,-160(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-160(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + sd a0,-40(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-168(s0) + 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,-176(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-56(s0) + ld a1,-168(s0) + ld a2,-176(s0) + mul t0,a1,a2 + ld t1,-160(s0) + add t2,t1,t0 + mv a0,t2 + ld ra,168(sp) + ld s0,160(sp) + addi sp,sp,176 + ret + main2: + addi sp,sp,-176 + sd ra,168(sp) + sd s0,160(sp) + addi s0,sp,176 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,1 + li a2,1 + li a1,3 + call part_app + sd a0,-32(s0) + sd a0,-40(s0) + ld a0,-40(s0) + li a3,2 + li a2,1 + li a1,0 + call part_app + sd a0,-48(s0) + sd a0,-56(s0) + ld a0,-56(s0) + li a3,3 + li a2,1 + li a1,0 + call part_app + sd a0,-64(s0) + 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) + li t0,0 + mv a0,t0 + ld ra,168(sp) + ld s0,160(sp) + addi sp,sp,176 + ret + + $ dune exec riscv64_instr_test < manytests/typed/006partial3.ml + .attribute unaligned_access, 0 + .attribute stack_align, 16 + .global main + main: + addi sp,sp,-32 + sd ra,16(sp) + sd s0,8(sp) + sd s1,0(sp) + addi s0,sp,32 + call init_part_apps + call main2 + sd a0,24(sp) + call cleanup_part_apps + ld a0,24(sp) + ld ra,16(sp) + ld s0,8(sp) + ld s1,0(sp) + addi sp,sp,32 + li a7,93 + ecall + anon_2: + addi sp,sp,-80 + sd ra,64(sp) + sd s0,56(sp) + addi s0,sp,80 + sd a2,-80(s0) + sd a1,-72(s0) + sd a0,-64(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-80(s0) + li a2,1 + li a1,1 + call part_app + mv a0,a0 + ld ra,64(sp) + ld s0,56(sp) + addi sp,sp,80 + ret + anon_1: + addi sp,sp,-112 + sd ra,96(sp) + sd s0,88(sp) + addi s0,sp,112 + sd a1,-112(s0) + sd a0,-104(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-112(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + sd a0,-40(s0) + lui a0,%hi(anon_2) + addi a0,a0,%lo(anon_2) + ld a4,-104(s0) + ld a3,-112(s0) + li a2,2 + li a1,3 + call part_app + mv a0,a0 + ld ra,96(sp) + ld s0,88(sp) + addi sp,sp,112 + ret + foo: + addi sp,sp,-96 + sd ra,88(sp) + sd s0,80(sp) + addi s0,sp,96 + sd a0,-96(s0) + lui a0,%hi(print_int) + addi a0,a0,%lo(print_int) + ld a3,-96(s0) + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + sd a0,-40(s0) + lui a0,%hi(anon_1) + addi a0,a0,%lo(anon_1) + ld a3,-96(s0) + li a2,1 + li a1,2 + call part_app + mv a0,a0 + ld ra,88(sp) + ld s0,80(sp) + addi sp,sp,96 + ret + main2: + addi sp,sp,-128 + sd ra,112(sp) + sd s0,104(sp) + addi s0,sp,128 + lui a0,%hi(foo) + addi a0,a0,%lo(foo) + li a3,4 + li a2,1 + li a1,1 + call part_app + sd a0,-32(s0) + ld a0,-32(s0) + li a3,8 + li a2,1 + li a1,0 + call part_app + sd a0,-40(s0) + ld a0,-40(s0) + li a3,9 + li a2,1 + li a1,0 + call part_app + sd a0,-48(s0) + li t0,0 + mv a0,t0 + ld ra,112(sp) + ld s0,104(sp) + addi sp,sp,128 + ret + diff --git a/slarnML/test/slarnML.ml b/slarnML/test/slarnML.ml new file mode 100644 index 000000000..e69de29bb