diff --git a/clang/hvm.c b/clang/hvm.c index ebf54fe1..b4eb31d6 100644 --- a/clang/hvm.c +++ b/clang/hvm.c @@ -4,6 +4,7 @@ #include #include #include +#include #include #include #include @@ -226,6 +227,15 @@ static u64 STEPS_ITRS_LIM = 0; static u64 STEPS_ROOT_LOC = 0; static str STEPS_LAST_ITR = NULL; +// Program args (tokens after bare `--` in CLI). +static int PRIM_ARGC = 0; +static char **PRIM_ARGV = NULL; + +fn void prim_set_argv(int argc, char **argv) { + PRIM_ARGC = argc; + PRIM_ARGV = argv; +} + // Nick Alphabet // ============= @@ -358,10 +368,28 @@ static int PARSE_FORK_SIDE = -1; // -1 = off, 0 = left branch (DP0), 1 = #include "print/name.c" #include "print/utf8.c" #include "prim/register.c" +#include "prim/string.c" #include "prim/fn/log.c" #include "prim/fn/log_go_0.c" #include "prim/fn/log_go_1.c" #include "prim/fn/log_go_2.c" +#include "prim/fn/panic.c" +#include "prim/fn/argv.c" +#include "prim/fn/env.c" +#include "prim/fn/cwd.c" +#include "prim/fn/chdir.c" +#include "prim/fn/rand.c" +#include "prim/fn/uuid.c" +#include "prim/fn/uid.c" +#include "prim/fn/process/_.c" +#include "prim/fn/stream/_.c" +#include "prim/fn/http/_.c" +#include "prim/fn/tcp/_.c" +#include "prim/fn/read_bytes.c" +#include "prim/fn/write_bytes.c" +#include "prim/fn/read_file.c" +#include "prim/fn/write_file.c" +#include "prim/fn/timer/_.c" #include "prim/init.c" #include "print/term.c" diff --git a/clang/main.c b/clang/main.c index b1aae50b..840c96bb 100644 --- a/clang/main.c +++ b/clang/main.c @@ -36,6 +36,8 @@ typedef struct { u32 ffi_loads_len; RuntimeFfiLoad ffi_loads[RUNTIME_FFI_MAX]; char *file; + int prog_argc; + char **prog_argv; } CliOpts; // Returns the executable basename for help text. @@ -154,11 +156,17 @@ fn CliOpts parse_opts(int argc, char **argv) { .to_c = 0, .output = NULL, .ffi_loads_len = 0, - .file = NULL + .file = NULL, + .prog_argc = 0, + .prog_argv = NULL }; for (int i = 1; i < argc; i++) { - if (strcmp(argv[i], "-h") == 0 || strcmp(argv[i], "--help") == 0) { + if (strcmp(argv[i], "--") == 0) { + opts.prog_argc = argc - (i + 1); + opts.prog_argv = &argv[i + 1]; + break; + } else if (strcmp(argv[i], "-h") == 0 || strcmp(argv[i], "--help") == 0) { opts.help = 1; } else if (strcmp(argv[i], "-v") == 0 || strcmp(argv[i], "--version") == 0) { opts.version = 1; @@ -330,6 +338,7 @@ int main(int argc, char **argv) { threads = 1; } runtime_init(threads, opts.debug, opts.silent, opts.step_by_step); + prim_set_argv(opts.prog_argc, opts.prog_argv); // Load FFI libraries before parsing (needed for arity checks and overrides). int suppress_build_warnings = opts.as_c || opts.to_c || opts.output != NULL; diff --git a/clang/nick/names.c b/clang/nick/names.c index a9aba370..2ac26fa8 100644 --- a/clang/nick/names.c +++ b/clang/nick/names.c @@ -6,6 +6,10 @@ static u32 SYM_SUC = 0; static u32 SYM_NIL = 0; static u32 SYM_CON = 0; static u32 SYM_CHR = 0; +static u32 SYM_U8 = 0; +static u32 SYM_BYT = 0; +static u32 SYM_OK = 0; +static u32 SYM_ERR = 0; fn void symbols_init(void) { SYM_ZER = table_find("ZER", 3); @@ -13,4 +17,8 @@ fn void symbols_init(void) { SYM_NIL = table_find("NIL", 3); SYM_CON = table_find("CON", 3); SYM_CHR = table_find("CHR", 3); + SYM_U8 = table_find("U8", 2); + SYM_BYT = table_find("BYT", 3); + SYM_OK = table_find("OK", 2); + SYM_ERR = table_find("ERR", 3); } diff --git a/clang/prim/fn/argv.c b/clang/prim/fn/argv.c new file mode 100644 index 00000000..0edd7af4 --- /dev/null +++ b/clang/prim/fn/argv.c @@ -0,0 +1,33 @@ +// %argv(dummy) +// ------------ +// List with CLI args passed after bare `--`. +fn Term prim_fn_argv(Term *args) { + (void)args[0]; + + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term out = nil; + Term cur = nil; + u8 has_node = 0; + + for (int i = 0; i < PRIM_ARGC; i++) { + const char *arg = PRIM_ARGV[i]; + + Term str = term_string_from_utf8(arg); + Term h_t[2] = {str, nil}; + Term node = term_new_ctr(SYM_CON, 2, h_t); + + if (!has_node) { + out = node; + has_node = 1; + } else { + heap_set(term_val(cur) + 1, node); + } + cur = node; + } + + return out; +} + +fn void prim_argv_init(void) { + prim_register("argv", 4, 1, prim_fn_argv); +} diff --git a/clang/prim/fn/chdir.c b/clang/prim/fn/chdir.c new file mode 100644 index 00000000..4ef9c023 --- /dev/null +++ b/clang/prim/fn/chdir.c @@ -0,0 +1,284 @@ +#include + +fn Term chdir_go_path(Term *args); +fn Term chdir_go_chr(Term *args); +fn Term chdir_go_num(Term *args); + +// %chdir(path) +// ------------ +// %chdir_go_path(λx.x, path) +fn Term prim_fn_chdir(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[2] = {acc, args[0]}; + Term t = term_new_pri(table_find("chdir_go_path", 13), 2, args0); + return wnf(t); +} + +// %chdir_go_path(acc, list) +// ------------------------- +// Walk list shape with lifting over ERA/INC/SUP. +fn Term chdir_go_path(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %chdir_go_path(acc, &{}) + // ----------------------- chdir-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %chdir_go_path(acc, ↑x) + // ----------------------- chdir-go-path-inc + // ↑(%chdir(acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next = term_new_pri(table_find("chdir", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %chdir_go_path(acc, &L{x,y}) + // ---------------------------- chdir-go-path-sup + // &L{%chdir(acc0(x)), %chdir(acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term t0 = term_new_pri(table_find("chdir", 5), 1, &app0); + Term t1 = term_new_pri(table_find("chdir", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %chdir_go_path(acc, #Nil) + // ------------------------- chdir-go-path-nil + // %chdir_go_io(acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term path = term_new_app(acc, nil); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("chdir_go_io", 11), 1, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %chdir_go_path(acc, #Con{h,t}) + // ------------------------------ chdir-go-path-con + // %chdir_go_chr(acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[3] = {acc, head, tail}; + Term t = term_new_pri(table_find("chdir_go_chr", 12), 3, args0); + return wnf(t); + } + // %chdir_go_path(acc, x) + // ---------------------- chdir-go-path-fallback + // fallthrough default + } + default: { + // %chdir_go_path(acc, x) + // ---------------------- chdir-go-path-default + // %chdir_go_io(acc(x)) + Term path = term_new_app(acc, list_wnf); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("chdir_go_io", 11), 1, io_args); + return wnf(io); + } + } +} + +// %chdir_go_chr(acc, head, tail) +// ------------------------------ +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term chdir_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %chdir_go_chr(acc, &{}, t) + // -------------------------- chdir-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %chdir_go_chr(acc, ↑x, t) + // ------------------------- chdir-go-chr-inc + // ↑(%chdir(acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("chdir", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %chdir_go_chr(acc, &L{x,y}, t) + // ------------------------------ chdir-go-chr-sup + // &L{%chdir(acc0(#Con{x, t0})), %chdir(acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("chdir", 5), 1, &app0); + Term t1 = term_new_pri(table_find("chdir", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %chdir_go_chr(acc, #Chr{c}, t) + // ------------------------------ chdir-go-chr-chr + // %chdir_go_num(acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[3] = {acc, code, tail}; + Term t = term_new_pri(table_find("chdir_go_num", 12), 3, args0); + return wnf(t); + } + // %chdir_go_chr(acc, h, t) + // ------------------------- chdir-go-chr-fallback + // fallthrough default + } + default: { + // %chdir_go_chr(acc, h, t) + // ------------------------- chdir-go-chr-default + // %chdir_go_io(acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("chdir_go_io", 11), 1, io_args); + return wnf(io); + } + } +} + +// %chdir_go_num(acc, code, tail) +// ------------------------------ +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term chdir_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %chdir_go_num(acc, &{}, t) + // -------------------------- chdir-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %chdir_go_num(acc, ↑x, t) + // ------------------------- chdir-go-num-inc + // ↑(%chdir(acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("chdir", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %chdir_go_num(acc, &L{x,y}, t) + // ------------------------------ chdir-go-num-sup + // &L{%chdir(acc0(#Con{#Chr{x}, t0})), %chdir(acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("chdir", 5), 1, &app0); + Term t1 = term_new_pri(table_find("chdir", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %chdir_go_num(acc, n, t) + // ------------------------ chdir-go-num-num + // %chdir_go_path(λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[2] = {acc_next, tail}; + Term t = term_new_pri(table_find("chdir_go_path", 13), 2, args0); + return wnf(t); + } + default: { + // %chdir_go_num(acc, c, t) + // ------------------------ chdir-go-num-default + // %chdir_go_io(acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("chdir_go_io", 11), 1, io_args); + return wnf(io); + } + } +} + +// %chdir_go_io(path) +// ------------------ +// #OK{#NIL} | #ERR{String} +fn Term prim_fn_chdir_go_io(Term *args) { + int MAX_PATH = 1024; + char path[MAX_PATH]; // UTF-8 bytes + const char *CHDIR_ERR_FMT = "ERROR(chdir): failed to change directory to '%s': %s (errno=%d)"; + + // Decode HVM path string (#CHR list) into `path` as UTF-8 bytes. + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("chdir", "path", MAX_PATH, path_err); + } + + if (chdir(path) != 0) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(CHDIR_ERR_FMT, path, strerror(err), err) }); + } + + Term Nil = term_new_ctr(SYM_NIL, 0, 0); + return term_new_ctr(SYM_OK, 1, &Nil); +} + +fn void prim_chdir_init(void) { + prim_register("chdir", 5, 1, prim_fn_chdir); + prim_register("chdir_go_path", 13, 2, chdir_go_path); + prim_register("chdir_go_chr", 12, 3, chdir_go_chr); + prim_register("chdir_go_num", 12, 3, chdir_go_num); + prim_register("chdir_go_io", 11, 1, prim_fn_chdir_go_io); +} diff --git a/clang/prim/fn/cwd.c b/clang/prim/fn/cwd.c new file mode 100644 index 00000000..3e265306 --- /dev/null +++ b/clang/prim/fn/cwd.c @@ -0,0 +1,24 @@ +#include + +// %cwd(dummy) +// ----------- +// #OK{String} | #ERR{String} +fn Term prim_fn_cwd(Term *args) { + (void)args[0]; + + int MAX_CWD = 4096; + char cwd[MAX_CWD]; // UTF-8 bytes + const char *GETCWD_ERR_FMT = "ERROR(cwd): failed to get current directory: %s (errno=%d)"; + + if (getcwd(cwd, MAX_CWD) == NULL) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(GETCWD_ERR_FMT, strerror(err), err) }); + } + + Term out = term_string_from_utf8(cwd); + return term_new_ctr(SYM_OK, 1, &out); +} + +fn void prim_cwd_init(void) { + prim_register("cwd", 3, 1, prim_fn_cwd); +} diff --git a/clang/prim/fn/env.c b/clang/prim/fn/env.c new file mode 100644 index 00000000..99fcfd45 --- /dev/null +++ b/clang/prim/fn/env.c @@ -0,0 +1,282 @@ +fn Term env_go_name(Term *args); +fn Term env_go_chr(Term *args); +fn Term env_go_num(Term *args); + +// %env(name) +// ---------- +// %env_go_name(λx.x, name) +fn Term prim_fn_env(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[2] = {acc, args[0]}; + Term t = term_new_pri(table_find("env_go_name", 11), 2, args0); + return wnf(t); +} + +// %env_go_name(acc, list) +// ----------------------- +// Walk list shape with lifting over ERA/INC/SUP. +fn Term env_go_name(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %env_go_name(acc, &{}) + // ---------------------- env-go-name-era + // &{} + return term_new_era(); + } + case INC: { + // %env_go_name(acc, ↑x) + // --------------------- env-go-name-inc + // ↑(%env(acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next = term_new_pri(table_find("env", 3), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %env_go_name(acc, &L{x,y}) + // -------------------------- env-go-name-sup + // &L{%env(acc0(x)), %env(acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term t0 = term_new_pri(table_find("env", 3), 1, &app0); + Term t1 = term_new_pri(table_find("env", 3), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %env_go_name(acc, #Nil) + // ----------------------- env-go-name-nil + // %env_go_io(acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term name = term_new_app(acc, nil); + Term io_args[1] = {name}; + Term io = term_new_pri(table_find("env_go_io", 9), 1, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %env_go_name(acc, #Con{h,t}) + // ---------------------------- env-go-name-con + // %env_go_chr(acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[3] = {acc, head, tail}; + Term t = term_new_pri(table_find("env_go_chr", 10), 3, args0); + return wnf(t); + } + // %env_go_name(acc, x) + // --------------------- env-go-name-fallback + // fallthrough default + } + default: { + // %env_go_name(acc, x) + // --------------------- env-go-name-default + // %env_go_io(acc(x)) + Term name = term_new_app(acc, list_wnf); + Term io_args[1] = {name}; + Term io = term_new_pri(table_find("env_go_io", 9), 1, io_args); + return wnf(io); + } + } +} + +// %env_go_chr(acc, head, tail) +// ---------------------------- +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term env_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %env_go_chr(acc, &{}, t) + // ------------------------ env-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %env_go_chr(acc, ↑x, t) + // ----------------------- env-go-chr-inc + // ↑(%env(acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("env", 3), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %env_go_chr(acc, &L{x,y}, t) + // ---------------------------- env-go-chr-sup + // &L{%env(acc0(#Con{x, t0})), %env(acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("env", 3), 1, &app0); + Term t1 = term_new_pri(table_find("env", 3), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %env_go_chr(acc, #Chr{c}, t) + // ---------------------------- env-go-chr-chr + // %env_go_num(acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[3] = {acc, code, tail}; + Term t = term_new_pri(table_find("env_go_num", 10), 3, args0); + return wnf(t); + } + // %env_go_chr(acc, h, t) + // ----------------------- env-go-chr-fallback + // fallthrough default + } + default: { + // %env_go_chr(acc, h, t) + // ----------------------- env-go-chr-default + // %env_go_io(acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term name = term_new_app(acc, con); + Term io_args[1] = {name}; + Term io = term_new_pri(table_find("env_go_io", 9), 1, io_args); + return wnf(io); + } + } +} + +// %env_go_num(acc, code, tail) +// ---------------------------- +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term env_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %env_go_num(acc, &{}, t) + // ------------------------ env-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %env_go_num(acc, ↑x, t) + // ----------------------- env-go-num-inc + // ↑(%env(acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("env", 3), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %env_go_num(acc, &L{x,y}, t) + // ---------------------------- env-go-num-sup + // &L{%env(acc0(#Con{#Chr{x}, t0})), %env(acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("env", 3), 1, &app0); + Term t1 = term_new_pri(table_find("env", 3), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %env_go_num(acc, n, t) + // ----------------------- env-go-num-num + // %env_go_name(λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[2] = {acc_next, tail}; + Term t = term_new_pri(table_find("env_go_name", 11), 2, args0); + return wnf(t); + } + default: { + // %env_go_num(acc, c, t) + // ----------------------- env-go-num-default + // %env_go_io(acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term name = term_new_app(acc, con); + Term io_args[1] = {name}; + Term io = term_new_pri(table_find("env_go_io", 9), 1, io_args); + return wnf(io); + } + } +} + +// %env_go_io(name) +// ---------------- +// #OK{String} | #ERR{String} +fn Term prim_fn_env_go_io(Term *args) { + int MAX_NAME = 1024; + char name[MAX_NAME]; // UTF-8 bytes + const char *NOT_FOUND_FMT = "ERROR(env): variable '%s' not found"; + + // Decode HVM env name string (#CHR list) into `name` as UTF-8 bytes. + HStrErr name_err; + if (!term_string_to_utf8_cstr(args[0], name, MAX_NAME, NULL, &name_err)) { + return term_string_from_hstrerr("env", "name", MAX_NAME, name_err); + } + + const char *value = getenv(name); + if (value == NULL) { + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(NOT_FOUND_FMT, name) }); + } + + Term out = term_string_from_utf8(value); + return term_new_ctr(SYM_OK, 1, &out); +} + +fn void prim_env_init(void) { + prim_register("env", 3, 1, prim_fn_env); + prim_register("env_go_name", 11, 2, env_go_name); + prim_register("env_go_chr", 10, 3, env_go_chr); + prim_register("env_go_num", 10, 3, env_go_num); + prim_register("env_go_io", 9, 1, prim_fn_env_go_io); +} diff --git a/clang/prim/fn/http/_.c b/clang/prim/fn/http/_.c new file mode 100644 index 00000000..073fe740 --- /dev/null +++ b/clang/prim/fn/http/_.c @@ -0,0 +1,1512 @@ +#include +#include +#include +#include + +#define HTTP_CAP (1u << 18) +#define HTTP_ARG_CAP 512 +#define HTTP_STR_CAP 8192 +#define HTTP_HEADER_CAP 4096 +#define HTTP_REASON_MSG_CAP 1024 +#define HTTP_BODY_HARD_CAP (1u << 24) +#define HTTP_DEFAULT_BODY_CAP (1u << 20) + +#define HTTP_ERR_BAD_ARG 1 +#define HTTP_ERR_BAD_HANDLE 2 +#define HTTP_ERR_STALE 3 +#define HTTP_ERR_FULL 4 +#define HTTP_ERR_IO 5 + +typedef struct { + char method[16]; + char url[HTTP_STR_CAP]; + char **headers; + u32 headers_len; + u32 headers_cap; + u8 body_kind; + char *body_text; + u8 *body_bytes; + u32 body_size; + u32 body_cap; + u32 timeout_ms; + u32 connect_timeout_ms; + u8 follow_redirects; + u32 max_redirects; + u8 verify_tls; + u32 max_body_bytes; +} HttpReq; + +typedef struct { + u32 expected_seq; + pid_t pid; + u8 finished; + u8 canceled; + u8 signaled; + u8 parsed; + u32 code; + u32 max_body_bytes; + Term outcome; + + char *tmp_dir; + char *hdr_path; + char *body_path; + char *meta_path; + char *err_path; + char *req_path; +} HttpSlot; + +typedef struct { + char *name; + char *value; +} HttpHdrPair; + +static HttpSlot HTTP_SLOTS[HTTP_CAP]; +static u32 HTTP_NEXT_ID = 1; +static pthread_mutex_t HTTP_LOCK = PTHREAD_MUTEX_INITIALIZER; + +// Core async/result constructors +static u32 HTTP_NAM_HTTP = 0; +static u32 HTTP_NAM_PEND = 0; +static u32 HTTP_NAM_RDY = 0; +static u32 HTTP_NAM_RESP = 0; +static u32 HTTP_NAM_HDR = 0; +static u32 HTTP_NAM_FAIL = 0; +static u32 HTTP_NAM_CANCELED = 0; + +// Fail reason constructors +static u32 HTTP_NAM_TIMEOUT = 0; +static u32 HTTP_NAM_DNS = 0; +static u32 HTTP_NAM_CONNECT = 0; +static u32 HTTP_NAM_TLS = 0; +static u32 HTTP_NAM_PROTOCOL = 0; +static u32 HTTP_NAM_CURL_EXIT = 0; +static u32 HTTP_NAM_CURL_SIGNAL = 0; +static u32 HTTP_NAM_PARSE = 0; +static u32 HTTP_NAM_BODY_TOO_LARGE = 0; +static u32 HTTP_NAM_IO = 0; + +// Request constructors +static u32 HTTP_NAM_REQ = 0; +static u32 HTTP_NAM_GET = 0; +static u32 HTTP_NAM_POST = 0; +static u32 HTTP_NAM_PUT = 0; +static u32 HTTP_NAM_PATCH = 0; +static u32 HTTP_NAM_DELETE = 0; +static u32 HTTP_NAM_HEAD = 0; +static u32 HTTP_NAM_OPTIONS = 0; +static u32 HTTP_NAM_NOBODY = 0; +static u32 HTTP_NAM_BODY_TEXT = 0; +static u32 HTTP_NAM_BODY_BYTES = 0; +static u32 HTTP_NAM_OPTS = 0; +static u32 HTTP_NAM_T = 0; +static u32 HTTP_NAM_F = 0; + +#define HTTP_BODY_NONE 0 +#define HTTP_BODY_TEXT 1 +#define HTTP_BODY_BYTES 2 + +fn Term wnf(Term term); + +fn Term http_new_err(const char *prim, u32 code, const char *msg) { + Term txt = term_string_printf("ERROR(%s): E%u %s", prim, code, msg); + return term_new_ctr(SYM_ERR, 1, &txt); +} + +fn Term http_new_ok(Term val) { + return term_new_ctr(SYM_OK, 1, &val); +} + +fn Term http_new_http(u32 id, u32 seq) { + Term args[2] = {term_new_num(id), term_new_num(seq)}; + return term_new_ctr(HTTP_NAM_HTTP, 2, args); +} + +fn Term http_new_pend(u32 id, u32 seq) { + Term http = http_new_http(id, seq); + return term_new_ctr(HTTP_NAM_PEND, 1, &http); +} + +fn Term http_new_rdy(u32 id, u32 seq, Term outcome) { + Term http = http_new_http(id, seq); + Term args[2] = {http, outcome}; + return term_new_ctr(HTTP_NAM_RDY, 2, args); +} + +fn Term http_new_reason0(u32 nam) { + return term_new_ctr(nam, 0, NULL); +} + +fn Term http_new_reason1(u32 nam, u32 val) { + Term arg = term_new_num(val); + return term_new_ctr(nam, 1, &arg); +} + +fn Term http_new_fail(Term reason, Term msg) { + Term args[2] = {reason, msg}; + return term_new_ctr(HTTP_NAM_FAIL, 2, args); +} + +fn Term http_new_canceled(void) { + return term_new_ctr(HTTP_NAM_CANCELED, 0, NULL); +} + +fn Term http_new_hdr(Term name, Term value) { + Term args[2] = {name, value}; + return term_new_ctr(HTTP_NAM_HDR, 2, args); +} + +fn Term http_new_resp(u32 status, Term headers, Term body) { + Term args[3] = {term_new_num(status), headers, body}; + return term_new_ctr(HTTP_NAM_RESP, 3, args); +} + +fn u8 http_parse_num(Term term, u32 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case NUM: { + *out = term_val(val); + return 1; + } + default: { + return 0; + } + } +} + +fn u8 http_parse_bool(Term term, u8 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C00: { + u32 ext = term_ext(val); + if (ext == HTTP_NAM_T) { + *out = 1; + return 1; + } + if (ext == HTTP_NAM_F) { + *out = 0; + return 1; + } + return 0; + } + default: { + return 0; + } + } +} + +fn u8 http_parse_handle(Term term, u32 *id, u32 *seq) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C02: { + if (term_ext(val) != HTTP_NAM_HTTP) { + return 0; + } + + u32 loc = term_val(val); + Term id_tm = heap_read(loc + 0); + Term seq_tm = heap_read(loc + 1); + + if (!http_parse_num(id_tm, id)) { + return 0; + } + if (!http_parse_num(seq_tm, seq)) { + return 0; + } + return 1; + } + default: { + return 0; + } + } +} + +fn u8 http_is_valid_id(u32 id) { + pthread_mutex_lock(&HTTP_LOCK); + + if (id == 0 || id >= HTTP_NEXT_ID || id >= HTTP_CAP) { + pthread_mutex_unlock(&HTTP_LOCK); + return 0; + } + + pthread_mutex_unlock(&HTTP_LOCK); + return 1; +} + +fn void http_set_finished(u32 id, u8 signaled, u32 code) { + pthread_mutex_lock(&HTTP_LOCK); + + if (id != 0 && id < HTTP_NEXT_ID && id < HTTP_CAP) { + HttpSlot *slot = &HTTP_SLOTS[id]; + slot->finished = 1; + slot->signaled = signaled; + slot->code = code; + } + + pthread_mutex_unlock(&HTTP_LOCK); +} + +fn void http_set_canceled(u32 id) { + pthread_mutex_lock(&HTTP_LOCK); + + if (id != 0 && id < HTTP_NEXT_ID && id < HTTP_CAP) { + HTTP_SLOTS[id].canceled = 1; + } + + pthread_mutex_unlock(&HTTP_LOCK); +} + +fn void http_status_from_wait(int status, u8 *signaled, u32 *code) { + if (WIFEXITED(status)) { + *signaled = 0; + *code = (u32)WEXITSTATUS(status); + return; + } + + if (WIFSIGNALED(status)) { + *signaled = 1; + *code = (u32)WTERMSIG(status); + return; + } + + *signaled = 0; + *code = 255; +} + +fn char *http_strdup(const char *str) { + size_t len = strlen(str); + char *out = malloc(len + 1); + if (!out) { + return NULL; + } + + memcpy(out, str, len); + out[len] = '\0'; + return out; +} + +fn char *http_join_path(const char *dir, const char *name) { + size_t dlen = strlen(dir); + size_t nlen = strlen(name); + char *out = malloc(dlen + 1 + nlen + 1); + if (!out) { + return NULL; + } + + memcpy(out, dir, dlen); + out[dlen] = '/'; + memcpy(out + dlen + 1, name, nlen); + out[dlen + 1 + nlen] = '\0'; + return out; +} + +fn void http_paths_free( + char **tmp_dir, + char **hdr_path, + char **body_path, + char **meta_path, + char **err_path, + char **req_path +) { + if (*hdr_path) { + unlink(*hdr_path); + free(*hdr_path); + *hdr_path = NULL; + } + if (*body_path) { + unlink(*body_path); + free(*body_path); + *body_path = NULL; + } + if (*meta_path) { + unlink(*meta_path); + free(*meta_path); + *meta_path = NULL; + } + if (*err_path) { + unlink(*err_path); + free(*err_path); + *err_path = NULL; + } + if (*req_path) { + unlink(*req_path); + free(*req_path); + *req_path = NULL; + } + if (*tmp_dir) { + rmdir(*tmp_dir); + free(*tmp_dir); + *tmp_dir = NULL; + } +} + +fn void http_slot_cleanup(HttpSlot *slot) { + http_paths_free( + &slot->tmp_dir, + &slot->hdr_path, + &slot->body_path, + &slot->meta_path, + &slot->err_path, + &slot->req_path + ); +} + +fn u8 http_make_paths( + char **tmp_dir, + char **hdr_path, + char **body_path, + char **meta_path, + char **err_path, + char **req_path +) { + char tmpl[] = "/tmp/hvm4_http_XXXXXX"; + char *dir = http_strdup(tmpl); + if (!dir) { + return 0; + } + + if (!mkdtemp(dir)) { + free(dir); + return 0; + } + + char *hdr = http_join_path(dir, "headers.txt"); + char *bod = http_join_path(dir, "body.bin"); + char *met = http_join_path(dir, "meta.txt"); + char *err = http_join_path(dir, "err.txt"); + char *req = http_join_path(dir, "request.bin"); + if (!hdr || !bod || !met || !err || !req) { + http_paths_free(&dir, &hdr, &bod, &met, &err, &req); + return 0; + } + + *tmp_dir = dir; + *hdr_path = hdr; + *body_path = bod; + *meta_path = met; + *err_path = err; + *req_path = req; + return 1; +} + +fn u8 http_read_status_code(const char *meta_path, u32 *status) { + FILE *f = fopen(meta_path, "rb"); + if (!f) { + return 0; + } + + char buf[64]; + size_t got = fread(buf, 1, sizeof(buf) - 1, f); + fclose(f); + buf[got] = '\0'; + + char *p = buf; + while (*p && !isdigit((unsigned char)*p)) { + p++; + } + + if (!*p) { + return 0; + } + + long code = strtol(p, NULL, 10); + if (code < 0 || code > 9999) { + return 0; + } + + *status = (u32)code; + return 1; +} + +fn Term http_read_stderr_msg(const char *err_path, const char *fallback) { + FILE *f = fopen(err_path, "rb"); + if (!f) { + return term_string_from_utf8(fallback); + } + + char buf[HTTP_REASON_MSG_CAP]; + size_t got = fread(buf, 1, sizeof(buf) - 1, f); + fclose(f); + + while (got > 0 && (buf[got - 1] == '\n' || buf[got - 1] == '\r')) { + got--; + } + buf[got] = '\0'; + + if (got == 0) { + return term_string_from_utf8(fallback); + } + + return term_string_from_utf8(buf); +} + +fn u8 http_req_init(HttpReq *req) { + req->method[0] = '\0'; + req->url[0] = '\0'; + req->headers = NULL; + req->headers_len = 0; + req->headers_cap = 0; + req->body_kind = HTTP_BODY_NONE; + req->body_text = NULL; + req->body_bytes = NULL; + req->body_size = 0; + req->body_cap = 0; + req->timeout_ms = 0; + req->connect_timeout_ms = 0; + req->follow_redirects = 0; + req->max_redirects = 0; + req->verify_tls = 1; + req->max_body_bytes = HTTP_DEFAULT_BODY_CAP; + return 1; +} + +fn void http_req_free(HttpReq *req) { + if (req->headers) { + for (u32 i = 0; i < req->headers_len; ++i) { + free(req->headers[i]); + } + free(req->headers); + req->headers = NULL; + } + + if (req->body_text) { + free(req->body_text); + req->body_text = NULL; + } + + if (req->body_bytes) { + free(req->body_bytes); + req->body_bytes = NULL; + } + + req->headers_len = 0; + req->headers_cap = 0; + req->body_size = 0; + req->body_cap = 0; +} + +fn u8 http_req_push_header(HttpReq *req, char *line) { + if (req->headers_len == req->headers_cap) { + u32 next_cap = req->headers_cap == 0 ? 8 : req->headers_cap * 2; + char **next = realloc(req->headers, (size_t)next_cap * sizeof(char *)); + if (!next) { + return 0; + } + req->headers = next; + req->headers_cap = next_cap; + } + + req->headers[req->headers_len] = line; + req->headers_len = req->headers_len + 1; + return 1; +} + +fn u8 http_req_push_body_byte(HttpReq *req, u8 byte) { + u32 len = req->body_size; + + if (len >= HTTP_BODY_HARD_CAP) { + return 0; + } + + if (len == req->body_cap) { + u32 next_cap = req->body_cap == 0 ? 256 : req->body_cap * 2; + if (next_cap > HTTP_BODY_HARD_CAP) { + next_cap = HTTP_BODY_HARD_CAP; + } + if (next_cap == req->body_cap) { + return 0; + } + + u8 *next = realloc(req->body_bytes, (size_t)next_cap); + if (!next) { + return 0; + } + req->body_bytes = next; + req->body_cap = next_cap; + } + + req->body_bytes[len] = byte; + req->body_size = len + 1; + return 1; +} + +fn u8 http_parse_method(Term term, char out[16]) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C00: { + u32 ext = term_ext(val); + if (ext == HTTP_NAM_GET) { + strcpy(out, "GET"); + return 1; + } + if (ext == HTTP_NAM_POST) { + strcpy(out, "POST"); + return 1; + } + if (ext == HTTP_NAM_PUT) { + strcpy(out, "PUT"); + return 1; + } + if (ext == HTTP_NAM_PATCH) { + strcpy(out, "PATCH"); + return 1; + } + if (ext == HTTP_NAM_DELETE) { + strcpy(out, "DELETE"); + return 1; + } + if (ext == HTTP_NAM_HEAD) { + strcpy(out, "HEAD"); + return 1; + } + if (ext == HTTP_NAM_OPTIONS) { + strcpy(out, "OPTIONS"); + return 1; + } + return 0; + } + default: { + return 0; + } + } +} + +fn u8 http_parse_header_item(Term term, HttpReq *req, Term *err_out) { + Term val = wnf(term); + + if (term_tag(val) != C02 || term_ext(val) != HTTP_NAM_HDR) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `headers`; expected List<#Hdr{name,value}>"); + return 0; + } + + u32 loc = term_val(val); + Term name_tm = heap_read(loc + 0); + Term value_tm = heap_read(loc + 1); + + char name[HTTP_HEADER_CAP]; + char value[HTTP_HEADER_CAP]; + + HStrErr name_err; + if (!term_string_to_utf8_cstr(name_tm, name, HTTP_HEADER_CAP, NULL, &name_err)) { + *err_out = term_string_from_hstrerr("http_request", "header_name", HTTP_HEADER_CAP, name_err); + return 0; + } + + HStrErr value_err; + if (!term_string_to_utf8_cstr(value_tm, value, HTTP_HEADER_CAP, NULL, &value_err)) { + *err_out = term_string_from_hstrerr("http_request", "header_value", HTTP_HEADER_CAP, value_err); + return 0; + } + + size_t nlen = strlen(name); + size_t vlen = strlen(value); + char *line = malloc(nlen + 2 + vlen + 1); + if (!line) { + *err_out = http_new_err("http_request", HTTP_ERR_IO, "out of memory while building headers"); + return 0; + } + + memcpy(line, name, nlen); + line[nlen + 0] = ':'; + line[nlen + 1] = ' '; + memcpy(line + nlen + 2, value, vlen); + line[nlen + 2 + vlen] = '\0'; + + if (!http_req_push_header(req, line)) { + free(line); + *err_out = http_new_err("http_request", HTTP_ERR_IO, "out of memory while storing headers"); + return 0; + } + + return 1; +} + +fn u8 http_parse_headers(Term term, HttpReq *req, Term *err_out) { + Term cur = wnf(term); + + while (term_tag(cur) == C02 && term_ext(cur) == SYM_CON) { + u32 loc = term_val(cur); + Term head = heap_read(loc + 0); + Term tail = heap_read(loc + 1); + + if (!http_parse_header_item(head, req, err_out)) { + return 0; + } + + cur = wnf(tail); + } + + if (term_tag(cur) != C00 || term_ext(cur) != SYM_NIL) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `headers`; expected List<#Hdr{name,value}>"); + return 0; + } + + return 1; +} + +fn u8 http_parse_body_bytes_list(Term term, HttpReq *req, Term *err_out) { + Term cur = wnf(term); + + while (term_tag(cur) == C02 && term_ext(cur) == SYM_CON) { + u32 loc = term_val(cur); + Term head = wnf(heap_read(loc + 0)); + Term tail = heap_read(loc + 1); + + if (term_tag(head) != C01 || term_ext(head) != SYM_BYT) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected List<#BYT{n}>"); + return 0; + } + + Term num = wnf(heap_read(term_val(head))); + if (term_tag(num) != NUM) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected #BYT{NUM}"); + return 0; + } + + u32 val = term_val(num); + if (val > 255) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; byte must be in [0,255]"); + return 0; + } + + if (!http_req_push_body_byte(req, (u8)val)) { + *err_out = http_new_err("http_request", HTTP_ERR_IO, "out of memory while decoding body bytes"); + return 0; + } + + cur = wnf(tail); + } + + if (term_tag(cur) != C00 || term_ext(cur) != SYM_NIL) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected List<#BYT{n}>"); + return 0; + } + + return 1; +} + +fn u8 http_parse_body(Term term, HttpReq *req, Term *err_out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C00: { + if (term_ext(val) != HTTP_NAM_NOBODY) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected #NoBody|#BodyText|#BodyBytes"); + return 0; + } + req->body_kind = HTTP_BODY_NONE; + return 1; + } + case C01: { + u32 ext = term_ext(val); + u32 loc = term_val(val); + + if (ext == HTTP_NAM_BODY_TEXT) { + char *text = malloc(HTTP_BODY_HARD_CAP); + if (!text) { + *err_out = http_new_err("http_request", HTTP_ERR_IO, "out of memory while decoding body text"); + return 0; + } + + HStrErr text_err; + if (!term_string_to_utf8_cstr(heap_read(loc), text, HTTP_BODY_HARD_CAP, NULL, &text_err)) { + free(text); + *err_out = term_string_from_hstrerr("http_request", "body_text", HTTP_BODY_HARD_CAP, text_err); + return 0; + } + + req->body_text = text; + + req->body_kind = HTTP_BODY_TEXT; + req->body_size = (u32)strlen(req->body_text); + return 1; + } + + if (ext == HTTP_NAM_BODY_BYTES) { + if (!http_parse_body_bytes_list(heap_read(loc), req, err_out)) { + return 0; + } + req->body_kind = HTTP_BODY_BYTES; + return 1; + } + + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected #NoBody|#BodyText|#BodyBytes"); + return 0; + } + default: { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `body`; expected #NoBody|#BodyText|#BodyBytes"); + return 0; + } + } +} + +fn u8 http_parse_opts(Term term, HttpReq *req, Term *err_out) { + Term val = wnf(term); + + if (term_tag(val) != C06 || term_ext(val) != HTTP_NAM_OPTS) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts`; expected #Opts{timeout_ms,connect_timeout_ms,follow_redirects,max_redirects,verify_tls,max_body_bytes}"); + return 0; + } + + u32 loc = term_val(val); + + if (!http_parse_num(heap_read(loc + 0), &req->timeout_ms)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.timeout_ms`; expected NUM"); + return 0; + } + if (!http_parse_num(heap_read(loc + 1), &req->connect_timeout_ms)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.connect_timeout_ms`; expected NUM"); + return 0; + } + if (!http_parse_bool(heap_read(loc + 2), &req->follow_redirects)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.follow_redirects`; expected #T{}|#F{}"); + return 0; + } + if (!http_parse_num(heap_read(loc + 3), &req->max_redirects)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.max_redirects`; expected NUM"); + return 0; + } + if (!http_parse_bool(heap_read(loc + 4), &req->verify_tls)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.verify_tls`; expected #T{}|#F{}"); + return 0; + } + if (!http_parse_num(heap_read(loc + 5), &req->max_body_bytes)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.max_body_bytes`; expected NUM"); + return 0; + } + + if (req->max_body_bytes == 0 || req->max_body_bytes > HTTP_BODY_HARD_CAP) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `opts.max_body_bytes`; must be in [1,HTTP_BODY_HARD_CAP]"); + return 0; + } + + return 1; +} + +fn u8 http_parse_request(Term req_tm, HttpReq *req, Term *err_out) { + Term val = wnf(req_tm); + + if (term_tag(val) != C05 || term_ext(val) != HTTP_NAM_REQ) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `req`; expected #Req{method,url,headers,body,opts}"); + return 0; + } + + u32 loc = term_val(val); + Term method = heap_read(loc + 0); + Term url = heap_read(loc + 1); + Term headers = heap_read(loc + 2); + Term body = heap_read(loc + 3); + Term opts = heap_read(loc + 4); + + if (!http_parse_method(method, req->method)) { + *err_out = http_new_err("http_request", HTTP_ERR_BAD_ARG, "invalid `req.method`; expected #Get|#Post|#Put|#Patch|#Delete|#Head|#Options"); + return 0; + } + + HStrErr url_err; + if (!term_string_to_utf8_cstr(url, req->url, HTTP_STR_CAP, NULL, &url_err)) { + *err_out = term_string_from_hstrerr("http_request", "url", HTTP_STR_CAP, url_err); + return 0; + } + + if (!http_parse_headers(headers, req, err_out)) { + return 0; + } + + if (!http_parse_body(body, req, err_out)) { + return 0; + } + + if (!http_parse_opts(opts, req, err_out)) { + return 0; + } + + return 1; +} + +fn u8 http_write_all(int fd, const u8 *buf, u32 len) { + u32 off = 0; + while (off < len) { + ssize_t wrote = write(fd, buf + off, (size_t)(len - off)); + if (wrote > 0) { + off = off + (u32)wrote; + continue; + } + if (wrote < 0 && errno == EINTR) { + continue; + } + return 0; + } + + return 1; +} + +fn u8 http_write_body_file(const char *path, const HttpReq *req) { + if (req->body_kind != HTTP_BODY_BYTES) { + return 1; + } + + int fd = open(path, O_WRONLY | O_CREAT | O_TRUNC, 0600); + if (fd < 0) { + return 0; + } + + u8 ok = http_write_all(fd, req->body_bytes, req->body_size); + int close_ret = close(fd); + if (!ok || close_ret < 0) { + return 0; + } + + return 1; +} + +fn int http_open_trunc_file(const char *path) { + while (1) { + int fd = open(path, O_WRONLY | O_CREAT | O_TRUNC, 0600); + if (fd >= 0) { + return fd; + } + if (errno == EINTR) { + continue; + } + return -1; + } +} + +fn int http_dup2_retry(int old_fd, int new_fd) { + while (1) { + if (dup2(old_fd, new_fd) >= 0) { + return 1; + } + if (errno == EINTR) { + continue; + } + return 0; + } +} + +fn u8 http_argv_push(char **argv, u32 *argc, char *arg) { + if (*argc >= HTTP_ARG_CAP - 1) { + return 0; + } + + argv[*argc] = arg; + *argc = *argc + 1; + return 1; +} + +fn void http_child_exec_request( + const HttpReq *req, + const char *hdr_path, + const char *body_path, + const char *meta_path, + const char *err_path, + const char *req_path +) { + int meta_fd = http_open_trunc_file(meta_path); + if (meta_fd < 0) { + _exit(127); + } + + int err_fd = http_open_trunc_file(err_path); + if (err_fd < 0) { + close(meta_fd); + _exit(127); + } + + if (!http_dup2_retry(meta_fd, STDOUT_FILENO)) { + close(meta_fd); + close(err_fd); + _exit(127); + } + + if (!http_dup2_retry(err_fd, STDERR_FILENO)) { + close(meta_fd); + close(err_fd); + _exit(127); + } + + close(meta_fd); + close(err_fd); + + char timeout_arg[64]; + char connect_timeout_arg[64]; + char max_redirs_arg[32]; + char data_path_arg[HTTP_STR_CAP + 16]; + + snprintf(timeout_arg, sizeof(timeout_arg), "%.3f", (double)req->timeout_ms / 1000.0); + snprintf(connect_timeout_arg, sizeof(connect_timeout_arg), "%.3f", (double)req->connect_timeout_ms / 1000.0); + snprintf(max_redirs_arg, sizeof(max_redirs_arg), "%u", req->max_redirects); + snprintf(data_path_arg, sizeof(data_path_arg), "@%s", req_path); + + char *argv[HTTP_ARG_CAP]; + u32 argc = 0; + + if (!http_argv_push(argv, &argc, "curl")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "-sS")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "-X")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, (char *)req->method)) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "-D")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, (char *)hdr_path)) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "-o")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, (char *)body_path)) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "-w")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "%{http_code}\n")) { + _exit(127); + } + + if (req->timeout_ms > 0) { + if (!http_argv_push(argv, &argc, "--max-time")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, timeout_arg)) { + _exit(127); + } + } + + if (req->connect_timeout_ms > 0) { + if (!http_argv_push(argv, &argc, "--connect-timeout")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, connect_timeout_arg)) { + _exit(127); + } + } + + if (req->follow_redirects) { + if (!http_argv_push(argv, &argc, "-L")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, "--max-redirs")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, max_redirs_arg)) { + _exit(127); + } + } + + if (!req->verify_tls) { + if (!http_argv_push(argv, &argc, "-k")) { + _exit(127); + } + } + + for (u32 i = 0; i < req->headers_len; ++i) { + if (!http_argv_push(argv, &argc, "-H")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, req->headers[i])) { + _exit(127); + } + } + + if (req->body_kind == HTTP_BODY_TEXT) { + if (!http_argv_push(argv, &argc, "--data-binary")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, req->body_text)) { + _exit(127); + } + } + + if (req->body_kind == HTTP_BODY_BYTES) { + if (!http_argv_push(argv, &argc, "--data-binary")) { + _exit(127); + } + if (!http_argv_push(argv, &argc, data_path_arg)) { + _exit(127); + } + } + + if (!http_argv_push(argv, &argc, (char *)req->url)) { + _exit(127); + } + + argv[argc] = NULL; + execvp("curl", argv); + _exit(127); +} + +fn Term http_reason_from_curl_exit(u32 code) { + switch (code) { + case 6: { + return http_new_reason0(HTTP_NAM_DNS); + } + case 7: { + return http_new_reason0(HTTP_NAM_CONNECT); + } + case 28: { + return http_new_reason0(HTTP_NAM_TIMEOUT); + } + + case 35: + case 51: + case 53: + case 54: + case 58: + case 59: + case 60: + case 64: + case 66: + case 77: + case 80: + case 82: + case 83: + case 90: + case 91: + case 95: + case 96: { + return http_new_reason0(HTTP_NAM_TLS); + } + + case 1: + case 3: + case 4: + case 5: + case 8: + case 9: + case 16: + case 22: + case 47: + case 52: + case 56: { + return http_new_reason0(HTTP_NAM_PROTOCOL); + } + + default: { + return http_new_reason1(HTTP_NAM_CURL_EXIT, code); + } + } +} + +fn int http_read_header_pairs(const char *hdr_path, HttpHdrPair **pairs_out, u32 *len_out, int *io_err_out) { + FILE *f = fopen(hdr_path, "rb"); + if (!f) { + *io_err_out = errno; + return 0; + } + + HttpHdrPair *pairs = NULL; + u32 len = 0; + u32 cap = 0; + char *line = NULL; + size_t line_cap = 0; + + while (1) { + ssize_t got = getline(&line, &line_cap, f); + if (got < 0) { + break; + } + + while (got > 0 && (line[got - 1] == '\n' || line[got - 1] == '\r')) { + line[got - 1] = '\0'; + got--; + } + + if (got == 0) { + continue; + } + + if (strncmp(line, "HTTP/", 5) == 0) { + for (u32 i = 0; i < len; ++i) { + free(pairs[i].name); + free(pairs[i].value); + } + len = 0; + continue; + } + + char *colon = strchr(line, ':'); + if (!colon) { + continue; + } + + *colon = '\0'; + char *name = line; + char *value = colon + 1; + + while (*value == ' ' || *value == '\t') { + value++; + } + + if (*name == '\0') { + continue; + } + + char *name_copy = http_strdup(name); + char *value_copy = http_strdup(value); + if (!name_copy || !value_copy) { + free(name_copy); + free(value_copy); + free(line); + for (u32 i = 0; i < len; ++i) { + free(pairs[i].name); + free(pairs[i].value); + } + free(pairs); + fclose(f); + *io_err_out = ENOMEM; + return 0; + } + + if (len == cap) { + u32 next_cap = cap == 0 ? 8 : cap * 2; + HttpHdrPair *next = realloc(pairs, (size_t)next_cap * sizeof(HttpHdrPair)); + if (!next) { + free(name_copy); + free(value_copy); + free(line); + for (u32 i = 0; i < len; ++i) { + free(pairs[i].name); + free(pairs[i].value); + } + free(pairs); + fclose(f); + *io_err_out = ENOMEM; + return 0; + } + pairs = next; + cap = next_cap; + } + + pairs[len].name = name_copy; + pairs[len].value = value_copy; + len = len + 1; + } + + free(line); + + if (ferror(f)) { + int err = errno; + for (u32 i = 0; i < len; ++i) { + free(pairs[i].name); + free(pairs[i].value); + } + free(pairs); + fclose(f); + *io_err_out = err; + return 0; + } + + fclose(f); + *pairs_out = pairs; + *len_out = len; + return 1; +} + +fn Term http_pairs_to_term(HttpHdrPair *pairs, u32 len) { + Term out = term_new_ctr(SYM_NIL, 0, NULL); + + for (u32 i = len; i > 0; --i) { + Term name = term_string_from_utf8(pairs[i - 1].name); + Term val = term_string_from_utf8(pairs[i - 1].value); + Term hdr = http_new_hdr(name, val); + Term args[2] = {hdr, out}; + out = term_new_ctr(SYM_CON, 2, args); + } + + return out; +} + +fn int http_read_body_bytes(const char *body_path, u32 cap, Term *body_out, int *io_err_out) { + FILE *f = fopen(body_path, "rb"); + if (!f) { + *io_err_out = errno; + return -1; + } + + Term nil = term_new_ctr(SYM_NIL, 0, NULL); + u8 byte = 0; + int first = fgetc(f); + if (first == EOF) { + if (ferror(f)) { + int err = errno; + fclose(f); + *io_err_out = err; + return -1; + } + fclose(f); + *body_out = nil; + return 1; + } + + byte = (u8)first; + u32 count = 1; + + Term byt_num[1] = {term_new_num(byte)}; + Term node[2] = {term_new_ctr(SYM_BYT, 1, byt_num), nil}; + Term out = term_new_ctr(SYM_CON, 2, node); + Term curr = out; + + while (1) { + int got = fgetc(f); + if (got == EOF) { + break; + } + + count = count + 1; + if (count > cap) { + fclose(f); + return 0; + } + + byt_num[0] = term_new_num((u8)got); + node[0] = term_new_ctr(SYM_BYT, 1, byt_num); + heap_set(term_val(curr) + 1, term_new_ctr(SYM_CON, 2, node)); + curr = heap_read(term_val(curr) + 1); + } + + if (ferror(f)) { + int err = errno; + fclose(f); + *io_err_out = err; + return -1; + } + + fclose(f); + *body_out = out; + return 1; +} + +fn Term http_build_outcome( + u8 canceled, + u8 signaled, + u32 code, + u32 max_body_bytes, + const char *hdr_path, + const char *meta_path, + const char *body_path, + const char *err_path +) { + if (canceled) { + return http_new_canceled(); + } + + if (signaled) { + Term rsn = http_new_reason1(HTTP_NAM_CURL_SIGNAL, code); + Term msg = term_string_printf("curl terminated by signal %u", code); + return http_new_fail(rsn, msg); + } + + if (code != 0) { + Term rsn = http_reason_from_curl_exit(code); + Term msg = http_read_stderr_msg(err_path, "curl request failed"); + return http_new_fail(rsn, msg); + } + + u32 status = 0; + if (!http_read_status_code(meta_path, &status)) { + Term rsn = http_new_reason0(HTTP_NAM_PARSE); + Term msg = term_string_printf("failed to parse HTTP status from '%s'", meta_path); + return http_new_fail(rsn, msg); + } + + HttpHdrPair *pairs = NULL; + u32 pair_n = 0; + int hdr_io_err = 0; + if (!http_read_header_pairs(hdr_path, &pairs, &pair_n, &hdr_io_err)) { + Term rsn = http_new_reason1(HTTP_NAM_IO, (u32)hdr_io_err); + Term msg = term_string_printf( + "failed to read response headers '%s': %s (errno=%d)", + hdr_path, + strerror(hdr_io_err), + hdr_io_err + ); + return http_new_fail(rsn, msg); + } + + Term headers = http_pairs_to_term(pairs, pair_n); + + for (u32 i = 0; i < pair_n; ++i) { + free(pairs[i].name); + free(pairs[i].value); + } + free(pairs); + + Term body = term_new_era(); + int body_io_err = 0; + int body_ret = http_read_body_bytes(body_path, max_body_bytes, &body, &body_io_err); + if (body_ret == 0) { + Term rsn = http_new_reason1(HTTP_NAM_BODY_TOO_LARGE, max_body_bytes); + Term msg = term_string_printf("response body too large (limit=%u bytes)", max_body_bytes); + return http_new_fail(rsn, msg); + } + if (body_ret < 0) { + Term rsn = http_new_reason1(HTTP_NAM_IO, (u32)body_io_err); + Term msg = term_string_printf( + "failed to read response body '%s': %s (errno=%d)", + body_path, + strerror(body_io_err), + body_io_err + ); + return http_new_fail(rsn, msg); + } + + return http_new_resp(status, headers, body); +} + +fn void http_set_outcome(u32 id, Term outcome) { + pthread_mutex_lock(&HTTP_LOCK); + + if (id != 0 && id < HTTP_NEXT_ID && id < HTTP_CAP) { + HttpSlot *slot = &HTTP_SLOTS[id]; + slot->outcome = outcome; + slot->parsed = 1; + http_slot_cleanup(slot); + } + + pthread_mutex_unlock(&HTTP_LOCK); +} + +fn pid_t http_waitpid_retry(pid_t pid, int *status, int opts) { + while (1) { + pid_t got = waitpid(pid, status, opts); + if (got >= 0) { + return got; + } + if (errno == EINTR) { + continue; + } + return -1; + } +} + +fn Term http_parse_and_store_outcome( + u32 id, + u8 canceled, + u8 signaled, + u32 code, + u32 max_body_bytes, + const char *hdr_path, + const char *meta_path, + const char *body_path, + const char *err_path +) { + Term outcome = http_build_outcome( + canceled, + signaled, + code, + max_body_bytes, + hdr_path, + meta_path, + body_path, + err_path + ); + + http_set_outcome(id, outcome); + return outcome; +} + +fn u8 http_claim( + u32 id, + u32 seq, + pid_t *pid, + u8 *finished, + u8 *parsed, + u8 *canceled, + u8 *signaled, + u32 *code, + u32 *max_body_bytes, + Term *outcome, + char **hdr_path, + char **meta_path, + char **body_path, + char **err_path +) { + pthread_mutex_lock(&HTTP_LOCK); + + if (id == 0 || id >= HTTP_NEXT_ID || id >= HTTP_CAP) { + pthread_mutex_unlock(&HTTP_LOCK); + return 0; + } + + HttpSlot *slot = &HTTP_SLOTS[id]; + if (slot->expected_seq != seq) { + pthread_mutex_unlock(&HTTP_LOCK); + return 0; + } + + slot->expected_seq = seq + 1; + *pid = slot->pid; + *finished = slot->finished; + *parsed = slot->parsed; + *canceled = slot->canceled; + *signaled = slot->signaled; + *code = slot->code; + *max_body_bytes = slot->max_body_bytes; + *outcome = slot->outcome; + *hdr_path = slot->hdr_path; + *meta_path = slot->meta_path; + *body_path = slot->body_path; + *err_path = slot->err_path; + + pthread_mutex_unlock(&HTTP_LOCK); + return 1; +} + +#include "request.c" +#include "poll.c" +#include "wait.c" +#include "cancel.c" + +fn void prim_http_init(void) { + HTTP_NAM_HTTP = table_find("Http", 4); + HTTP_NAM_PEND = table_find("Pend", 4); + HTTP_NAM_RDY = table_find("Rdy", 3); + HTTP_NAM_RESP = table_find("Resp", 4); + HTTP_NAM_HDR = table_find("Hdr", 3); + HTTP_NAM_FAIL = table_find("HttpFail", 8); + HTTP_NAM_CANCELED = table_find("Canceled", 8); + + HTTP_NAM_TIMEOUT = table_find("HttpTimeout", 11); + HTTP_NAM_DNS = table_find("HttpDns", 7); + HTTP_NAM_CONNECT = table_find("Connect", 7); + HTTP_NAM_TLS = table_find("Tls", 3); + HTTP_NAM_PROTOCOL = table_find("HttpProtocol", 12); + HTTP_NAM_CURL_EXIT = table_find("CurlExit", 8); + HTTP_NAM_CURL_SIGNAL = table_find("CurlSignal", 10); + HTTP_NAM_PARSE = table_find("Parse", 5); + HTTP_NAM_BODY_TOO_LARGE = table_find("BodyTooLarge", 12); + HTTP_NAM_IO = table_find("Io", 2); + + HTTP_NAM_REQ = table_find("Req", 3); + HTTP_NAM_GET = table_find("Get", 3); + HTTP_NAM_POST = table_find("Post", 4); + HTTP_NAM_PUT = table_find("Put", 3); + HTTP_NAM_PATCH = table_find("Patch", 5); + HTTP_NAM_DELETE = table_find("Delete", 6); + HTTP_NAM_HEAD = table_find("Head", 4); + HTTP_NAM_OPTIONS = table_find("Options", 7); + HTTP_NAM_NOBODY = table_find("NoBody", 6); + HTTP_NAM_BODY_TEXT = table_find("BodyText", 8); + HTTP_NAM_BODY_BYTES = table_find("BodyBytes", 9); + HTTP_NAM_OPTS = table_find("Opts", 4); + HTTP_NAM_T = table_find("T", 1); + HTTP_NAM_F = table_find("F", 1); + + prim_http_request_init(); + prim_http_poll_init(); + prim_http_wait_init(); + prim_http_cancel_init(); +} diff --git a/clang/prim/fn/http/cancel.c b/clang/prim/fn/http/cancel.c new file mode 100644 index 00000000..e82bdea6 --- /dev/null +++ b/clang/prim/fn/http/cancel.c @@ -0,0 +1,141 @@ +// %http_cancel(http) +// ------------------ +// %http_cancel_go_http(http) +fn Term prim_fn_http_cancel(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("http_cancel_go_http", 19), 1, args0); + return wnf(t); +} + +// %http_cancel_go_http(http) +// -------------------------- +// Lift `http` over ERA/INC/SUP; default forwards to io stage. +fn Term http_cancel_go_http(Term *args) { + Term http_wnf = wnf(args[0]); + + switch (term_tag(http_wnf)) { + case ERA: { + // %http_cancel_go_http(&{}) + // ------------------------- http-cancel-go-http-era + // &{} + return term_new_era(); + } + case INC: { + // %http_cancel_go_http(↑x) + // ------------------------ http-cancel-go-http-inc + // ↑(%http_cancel(x)) + u32 inc_loc = term_val(http_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("http_cancel", 11), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %http_cancel_go_http(&L{x,y}) + // ----------------------------- http-cancel-go-http-sup + // &L{%http_cancel(x), %http_cancel(y)} + u32 lab = term_ext(http_wnf); + u32 sup_loc = term_val(http_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("http_cancel", 11), 1, &x); + Term t1 = term_new_pri(table_find("http_cancel", 11), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %http_cancel_go_http(http) + // -------------------------- http-cancel-go-http-default + // %http_cancel_go_io(http) + Term args0[1] = {http_wnf}; + Term t = term_new_pri(table_find("http_cancel_go_io", 17), 1, args0); + return wnf(t); + } + } +} + +// %http_cancel_go_io(http) +// ------------------------ +// #OK{#Pend{#Http{id,seq+1}}|#Rdy{#Http{id,seq+1},outcome}} | #ERR{String} +fn Term prim_fn_http_cancel_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!http_parse_handle(args[0], &id, &seq)) { + return http_new_err("http_cancel", HTTP_ERR_BAD_HANDLE, "invalid `http`; expected #Http{id,seq}"); + } + + if (!http_is_valid_id(id)) { + return http_new_err("http_cancel", HTTP_ERR_BAD_HANDLE, "unknown http id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 parsed = 0; + u8 canceled = 0; + u8 signaled = 0; + u32 code = 0; + u32 max_body_bytes = 0; + Term outcome = term_new_era(); + char *hdr = NULL; + char *meta = NULL; + char *body = NULL; + char *err = NULL; + if (!http_claim( + id, + seq, + &pid, + &finished, + &parsed, + &canceled, + &signaled, + &code, + &max_body_bytes, + &outcome, + &hdr, + &meta, + &body, + &err + )) { + return http_new_err("http_cancel", HTTP_ERR_STALE, "stale http handle"); + } + + if (parsed) { + return http_new_ok(http_new_rdy(id, seq + 1, outcome)); + } + + if (finished) { + Term done = http_parse_and_store_outcome(id, canceled, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); + } + + http_set_canceled(id); + + if (kill(pid, SIGTERM) < 0 && errno != ESRCH) { + return http_new_err("http_cancel", HTTP_ERR_IO, strerror(errno)); + } + + int status = 0; + pid_t got = http_waitpid_retry(pid, &status, WNOHANG); + if (got < 0) { + if (errno == ECHILD) { + Term done = http_parse_and_store_outcome(id, 1, 0, 0, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); + } + return http_new_err("http_cancel", HTTP_ERR_IO, strerror(errno)); + } + + if (got == 0) { + return http_new_ok(http_new_pend(id, seq + 1)); + } + + http_status_from_wait(status, &signaled, &code); + http_set_finished(id, signaled, code); + + Term done = http_parse_and_store_outcome(id, 1, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); +} + +fn void prim_http_cancel_init(void) { + prim_register("http_cancel", 11, 1, prim_fn_http_cancel); + prim_register("http_cancel_go_http", 19, 1, http_cancel_go_http); + prim_register("http_cancel_go_io", 17, 1, prim_fn_http_cancel_go_io); +} diff --git a/clang/prim/fn/http/poll.c b/clang/prim/fn/http/poll.c new file mode 100644 index 00000000..32e8fd13 --- /dev/null +++ b/clang/prim/fn/http/poll.c @@ -0,0 +1,131 @@ +// %http_poll(http) +// ---------------- +// %http_poll_go_http(http) +fn Term prim_fn_http_poll(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("http_poll_go_http", 17), 1, args0); + return wnf(t); +} + +// %http_poll_go_http(http) +// ------------------------ +// Lift `http` over ERA/INC/SUP; default forwards to io stage. +fn Term http_poll_go_http(Term *args) { + Term http_wnf = wnf(args[0]); + + switch (term_tag(http_wnf)) { + case ERA: { + // %http_poll_go_http(&{}) + // ----------------------- http-poll-go-http-era + // &{} + return term_new_era(); + } + case INC: { + // %http_poll_go_http(↑x) + // ---------------------- http-poll-go-http-inc + // ↑(%http_poll(x)) + u32 inc_loc = term_val(http_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("http_poll", 9), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %http_poll_go_http(&L{x,y}) + // --------------------------- http-poll-go-http-sup + // &L{%http_poll(x), %http_poll(y)} + u32 lab = term_ext(http_wnf); + u32 sup_loc = term_val(http_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("http_poll", 9), 1, &x); + Term t1 = term_new_pri(table_find("http_poll", 9), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %http_poll_go_http(http) + // ------------------------ http-poll-go-http-default + // %http_poll_go_io(http) + Term args0[1] = {http_wnf}; + Term t = term_new_pri(table_find("http_poll_go_io", 15), 1, args0); + return wnf(t); + } + } +} + +// %http_poll_go_io(http) +// ---------------------- +// #OK{#Pend{#Http{id,seq+1}}|#Rdy{#Http{id,seq+1},outcome}} | #ERR{String} +fn Term prim_fn_http_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!http_parse_handle(args[0], &id, &seq)) { + return http_new_err("http_poll", HTTP_ERR_BAD_HANDLE, "invalid `http`; expected #Http{id,seq}"); + } + + if (!http_is_valid_id(id)) { + return http_new_err("http_poll", HTTP_ERR_BAD_HANDLE, "unknown http id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 parsed = 0; + u8 canceled = 0; + u8 signaled = 0; + u32 code = 0; + u32 max_body_bytes = 0; + Term outcome = term_new_era(); + char *hdr = NULL; + char *meta = NULL; + char *body = NULL; + char *err = NULL; + if (!http_claim( + id, + seq, + &pid, + &finished, + &parsed, + &canceled, + &signaled, + &code, + &max_body_bytes, + &outcome, + &hdr, + &meta, + &body, + &err + )) { + return http_new_err("http_poll", HTTP_ERR_STALE, "stale http handle"); + } + + if (parsed) { + return http_new_ok(http_new_rdy(id, seq + 1, outcome)); + } + + if (finished) { + Term done = http_parse_and_store_outcome(id, canceled, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); + } + + int status = 0; + pid_t got = http_waitpid_retry(pid, &status, WNOHANG); + if (got < 0) { + return http_new_err("http_poll", HTTP_ERR_IO, strerror(errno)); + } + + if (got == 0) { + return http_new_ok(http_new_pend(id, seq + 1)); + } + + http_status_from_wait(status, &signaled, &code); + http_set_finished(id, signaled, code); + + Term done = http_parse_and_store_outcome(id, canceled, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); +} + +fn void prim_http_poll_init(void) { + prim_register("http_poll", 9, 1, prim_fn_http_poll); + prim_register("http_poll_go_http", 17, 1, http_poll_go_http); + prim_register("http_poll_go_io", 15, 1, prim_fn_http_poll_go_io); +} diff --git a/clang/prim/fn/http/request.c b/clang/prim/fn/http/request.c new file mode 100644 index 00000000..f252b122 --- /dev/null +++ b/clang/prim/fn/http/request.c @@ -0,0 +1,152 @@ +// %http_request(req) +// ------------------ +// %http_request_go_req(req) +fn Term prim_fn_http_request(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("http_request_go_req", 19), 1, args0); + return wnf(t); +} + +// %http_request_go_req(req) +// ------------------------- +// Lift `req` over ERA/INC/SUP; default forwards to io stage. +fn Term http_request_go_req(Term *args) { + Term req_wnf = wnf(args[0]); + + switch (term_tag(req_wnf)) { + case ERA: { + // %http_request_go_req(&{}) + // ------------------------- http-request-go-req-era + // &{} + return term_new_era(); + } + case INC: { + // %http_request_go_req(↑x) + // ------------------------ http-request-go-req-inc + // ↑(%http_request(x)) + u32 inc_loc = term_val(req_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("http_request", 12), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %http_request_go_req(&L{x,y}) + // ----------------------------- http-request-go-req-sup + // &L{%http_request(x), %http_request(y)} + u32 lab = term_ext(req_wnf); + u32 sup_loc = term_val(req_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("http_request", 12), 1, &x); + Term t1 = term_new_pri(table_find("http_request", 12), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %http_request_go_req(req) + // ------------------------- http-request-go-req-default + // %http_request_go_io(req) + Term args0[1] = {req_wnf}; + Term t = term_new_pri(table_find("http_request_go_io", 18), 1, args0); + return wnf(t); + } + } +} + +// %http_request_go_io(req) +// ------------------------ +// #OK{#Http{id,0}} | #ERR{String} +fn Term prim_fn_http_request_go_io(Term *args) { + HttpReq req; + http_req_init(&req); + + Term parse_err = term_new_era(); + if (!http_parse_request(args[0], &req, &parse_err)) { + http_req_free(&req); + return parse_err; + } + + char *tmp_dir = NULL; + char *hdr_path = NULL; + char *body_path = NULL; + char *meta_path = NULL; + char *err_path = NULL; + char *req_path = NULL; + + if (!http_make_paths(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path)) { + http_req_free(&req); + return http_new_err("http_request", HTTP_ERR_IO, "failed to allocate temporary files"); + } + + if (!http_write_body_file(req_path, &req)) { + int err = errno; + http_req_free(&req); + http_paths_free(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path); + return http_new_err("http_request", HTTP_ERR_IO, strerror(err)); + } + + pid_t pid = fork(); + if (pid < 0) { + int err = errno; + http_req_free(&req); + http_paths_free(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path); + return http_new_err("http_request", HTTP_ERR_IO, strerror(err)); + } + + if (pid == 0) { + http_child_exec_request(&req, hdr_path, body_path, meta_path, err_path, req_path); + } + + u32 max_body_bytes = req.max_body_bytes; + http_req_free(&req); + + pthread_mutex_lock(&HTTP_LOCK); + + u32 id = HTTP_NEXT_ID; + if (id >= HTTP_CAP) { + pthread_mutex_unlock(&HTTP_LOCK); + + if (kill(pid, SIGKILL) < 0 && errno != ESRCH) { + http_paths_free(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path); + return http_new_err("http_request", HTTP_ERR_IO, strerror(errno)); + } + + int status = 0; + pid_t got = http_waitpid_retry(pid, &status, 0); + if (got < 0 && errno != ECHILD) { + http_paths_free(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path); + return http_new_err("http_request", HTTP_ERR_IO, strerror(errno)); + } + + http_paths_free(&tmp_dir, &hdr_path, &body_path, &meta_path, &err_path, &req_path); + return http_new_err("http_request", HTTP_ERR_FULL, "http table is full"); + } + + HTTP_NEXT_ID = id + 1; + + HttpSlot *slot = &HTTP_SLOTS[id]; + slot->expected_seq = 0; + slot->pid = pid; + slot->finished = 0; + slot->canceled = 0; + slot->signaled = 0; + slot->parsed = 0; + slot->code = 0; + slot->max_body_bytes = max_body_bytes; + slot->outcome = term_new_era(); + slot->tmp_dir = tmp_dir; + slot->hdr_path = hdr_path; + slot->body_path = body_path; + slot->meta_path = meta_path; + slot->err_path = err_path; + slot->req_path = req_path; + + pthread_mutex_unlock(&HTTP_LOCK); + return http_new_ok(http_new_http(id, 0)); +} + +fn void prim_http_request_init(void) { + prim_register("http_request", 12, 1, prim_fn_http_request); + prim_register("http_request_go_req", 19, 1, http_request_go_req); + prim_register("http_request_go_io", 18, 1, prim_fn_http_request_go_io); +} diff --git a/clang/prim/fn/http/wait.c b/clang/prim/fn/http/wait.c new file mode 100644 index 00000000..e6bbbdff --- /dev/null +++ b/clang/prim/fn/http/wait.c @@ -0,0 +1,127 @@ +// %http_wait(http) +// ---------------- +// %http_wait_go_http(http) +fn Term prim_fn_http_wait(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("http_wait_go_http", 17), 1, args0); + return wnf(t); +} + +// %http_wait_go_http(http) +// ------------------------ +// Lift `http` over ERA/INC/SUP; default forwards to io stage. +fn Term http_wait_go_http(Term *args) { + Term http_wnf = wnf(args[0]); + + switch (term_tag(http_wnf)) { + case ERA: { + // %http_wait_go_http(&{}) + // ----------------------- http-wait-go-http-era + // &{} + return term_new_era(); + } + case INC: { + // %http_wait_go_http(↑x) + // ---------------------- http-wait-go-http-inc + // ↑(%http_wait(x)) + u32 inc_loc = term_val(http_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("http_wait", 9), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %http_wait_go_http(&L{x,y}) + // --------------------------- http-wait-go-http-sup + // &L{%http_wait(x), %http_wait(y)} + u32 lab = term_ext(http_wnf); + u32 sup_loc = term_val(http_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("http_wait", 9), 1, &x); + Term t1 = term_new_pri(table_find("http_wait", 9), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %http_wait_go_http(http) + // ------------------------ http-wait-go-http-default + // %http_wait_go_io(http) + Term args0[1] = {http_wnf}; + Term t = term_new_pri(table_find("http_wait_go_io", 15), 1, args0); + return wnf(t); + } + } +} + +// %http_wait_go_io(http) +// ---------------------- +// #OK{#Rdy{#Http{id,seq+1},outcome}} | #ERR{String} +fn Term prim_fn_http_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!http_parse_handle(args[0], &id, &seq)) { + return http_new_err("http_wait", HTTP_ERR_BAD_HANDLE, "invalid `http`; expected #Http{id,seq}"); + } + + if (!http_is_valid_id(id)) { + return http_new_err("http_wait", HTTP_ERR_BAD_HANDLE, "unknown http id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 parsed = 0; + u8 canceled = 0; + u8 signaled = 0; + u32 code = 0; + u32 max_body_bytes = 0; + Term outcome = term_new_era(); + char *hdr = NULL; + char *meta = NULL; + char *body = NULL; + char *err = NULL; + if (!http_claim( + id, + seq, + &pid, + &finished, + &parsed, + &canceled, + &signaled, + &code, + &max_body_bytes, + &outcome, + &hdr, + &meta, + &body, + &err + )) { + return http_new_err("http_wait", HTTP_ERR_STALE, "stale http handle"); + } + + if (parsed) { + return http_new_ok(http_new_rdy(id, seq + 1, outcome)); + } + + if (finished) { + Term done = http_parse_and_store_outcome(id, canceled, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); + } + + int status = 0; + pid_t got = http_waitpid_retry(pid, &status, 0); + if (got < 0) { + return http_new_err("http_wait", HTTP_ERR_IO, strerror(errno)); + } + + http_status_from_wait(status, &signaled, &code); + http_set_finished(id, signaled, code); + + Term done = http_parse_and_store_outcome(id, canceled, signaled, code, max_body_bytes, hdr, meta, body, err); + return http_new_ok(http_new_rdy(id, seq + 1, done)); +} + +fn void prim_http_wait_init(void) { + prim_register("http_wait", 9, 1, prim_fn_http_wait); + prim_register("http_wait_go_http", 17, 1, http_wait_go_http); + prim_register("http_wait_go_io", 15, 1, prim_fn_http_wait_go_io); +} diff --git a/clang/prim/fn/log.c b/clang/prim/fn/log.c index c3b28e8e..67291b12 100644 --- a/clang/prim/fn/log.c +++ b/clang/prim/fn/log.c @@ -5,7 +5,7 @@ fn Term prim_fn_log_go_2(Term *args); // %log(s) // ---------------- log -// %log_go_0([], s) +// %log_go_0(λx.x, s) fn Term prim_fn_log(Term *args) { u64 loc = heap_alloc(1); Term var = term_new_var(loc); diff --git a/clang/prim/fn/log_go_1.c b/clang/prim/fn/log_go_1.c index eed8f065..ea6afe34 100644 --- a/clang/prim/fn/log_go_1.c +++ b/clang/prim/fn/log_go_1.c @@ -16,11 +16,10 @@ fn Term prim_fn_log_go_1(Term *args) { case INC: { // %log_go_1(acc, ↑x, t) // --------------------- log-go-1-inc - // ↑(%log(acc(#Con{#Chr{x}, t}))) + // ↑(%log(acc(#Con{x, t}))) u64 inc_loc = term_val(head_wnf); Term inner = heap_read(inc_loc); - Term chr = term_new_ctr(SYM_CHR, 1, &inner); - Term con_args[2] = {chr, tail}; + Term con_args[2] = {inner, tail}; Term con = term_new_ctr(SYM_CON, 2, con_args); Term app = term_new_app(acc, con); Term log = term_new_pri(table_find("log", 3), 1, &app); @@ -30,17 +29,15 @@ fn Term prim_fn_log_go_1(Term *args) { case SUP: { // %log_go_1(acc, &L{x,y}, t) // -------------------------- log-go-1-sup - // &L{%log(acc0(#Con{#Chr{x}, t0})), %log(acc1(#Con{#Chr{y}, t1}))} + // &L{%log(acc0(#Con{x, t0})), %log(acc1(#Con{y, t1}))} u32 lab = term_ext(head_wnf); u64 sup_loc = term_val(head_wnf); Term x = heap_read(sup_loc + 0); Term y = heap_read(sup_loc + 1); Copy A = term_clone(lab, acc); Copy T = term_clone(lab, tail); - Term chr0 = term_new_ctr(SYM_CHR, 1, &x); - Term chr1 = term_new_ctr(SYM_CHR, 1, &y); - Term con0_args[2] = {chr0, T.k0}; - Term con1_args[2] = {chr1, T.k1}; + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; Term con0 = term_new_ctr(SYM_CON, 2, con0_args); Term con1 = term_new_ctr(SYM_CON, 2, con1_args); Term app0 = term_new_app(A.k0, con0); diff --git a/clang/prim/fn/panic.c b/clang/prim/fn/panic.c new file mode 100644 index 00000000..f613a8d9 --- /dev/null +++ b/clang/prim/fn/panic.c @@ -0,0 +1,269 @@ +fn Term prim_fn_log(Term *args); +fn Term panic_go_msg(Term *args); +fn Term panic_go_chr(Term *args); +fn Term panic_go_num(Term *args); + +// %panic_go_abort(s) +// ------------------ +// !t = %log(s); abort +fn Term prim_fn_panic_go_abort(Term *args) { + (void)prim_fn_log(args); + exit(1); + return term_new_era(); +} + +// %panic(s) +// --------- +// %panic_go_msg(λx.x, s) +fn Term prim_fn_panic(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[2] = {acc, args[0]}; + Term t = term_new_pri(table_find("panic_go_msg", 12), 2, args0); + return wnf(t); +} + +// %panic_go_msg(acc, list) +// ------------------------ +// Walk list shape with lifting over ERA/INC/SUP. +fn Term panic_go_msg(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %panic_go_msg(acc, &{}) + // ----------------------- panic-go-msg-era + // &{} + return term_new_era(); + } + case INC: { + // %panic_go_msg(acc, ↑x) + // ---------------------- panic-go-msg-inc + // ↑(%panic(acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next = term_new_pri(table_find("panic", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %panic_go_msg(acc, &L{x,y}) + // --------------------------- panic-go-msg-sup + // &L{%panic(acc0(x)), %panic(acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term t0 = term_new_pri(table_find("panic", 5), 1, &app0); + Term t1 = term_new_pri(table_find("panic", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %panic_go_msg(acc, #Nil) + // ------------------------ panic-go-msg-nil + // %panic_go_abort(acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term str = term_new_app(acc, nil); + Term args0[1] = {str}; + Term t = term_new_pri(table_find("panic_go_abort", 14), 1, args0); + return wnf(t); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %panic_go_msg(acc, #Con{h,t}) + // ----------------------------- panic-go-msg-con + // %panic_go_chr(acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[3] = {acc, head, tail}; + Term t = term_new_pri(table_find("panic_go_chr", 12), 3, args0); + return wnf(t); + } + // %panic_go_msg(acc, x) + // ---------------------- panic-go-msg-fallback + // fallthrough default + } + default: { + // %panic_go_msg(acc, x) + // ---------------------- panic-go-msg-default + // %panic_go_abort(acc(x)) + Term str = term_new_app(acc, list_wnf); + Term args0[1] = {str}; + Term t = term_new_pri(table_find("panic_go_abort", 14), 1, args0); + return wnf(t); + } + } +} + +// %panic_go_chr(acc, head, tail) +// ------------------------------ +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term panic_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %panic_go_chr(acc, &{}, t) + // -------------------------- panic-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %panic_go_chr(acc, ↑x, t) + // ------------------------- panic-go-chr-inc + // ↑(%panic(acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("panic", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %panic_go_chr(acc, &L{x,y}, t) + // ------------------------------ panic-go-chr-sup + // &L{%panic(acc0(#Con{x, t0})), %panic(acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("panic", 5), 1, &app0); + Term t1 = term_new_pri(table_find("panic", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %panic_go_chr(acc, #Chr{c}, t) + // ------------------------------ panic-go-chr-chr + // %panic_go_num(acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[3] = {acc, code, tail}; + Term t = term_new_pri(table_find("panic_go_num", 12), 3, args0); + return wnf(t); + } + // %panic_go_chr(acc, h, t) + // ------------------------- panic-go-chr-fallback + // fallthrough default + } + default: { + // %panic_go_chr(acc, h, t) + // ------------------------- panic-go-chr-default + // %panic_go_abort(acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term str = term_new_app(acc, con); + Term args0[1] = {str}; + Term t = term_new_pri(table_find("panic_go_abort", 14), 1, args0); + return wnf(t); + } + } +} + +// %panic_go_num(acc, code, tail) +// ------------------------------ +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term panic_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %panic_go_num(acc, &{}, t) + // -------------------------- panic-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %panic_go_num(acc, ↑x, t) + // ------------------------- panic-go-num-inc + // ↑(%panic(acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("panic", 5), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %panic_go_num(acc, &L{x,y}, t) + // ------------------------------ panic-go-num-sup + // &L{%panic(acc0(#Con{#Chr{x}, t0})), %panic(acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("panic", 5), 1, &app0); + Term t1 = term_new_pri(table_find("panic", 5), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %panic_go_num(acc, n, t) + // ------------------------- panic-go-num-num + // %panic_go_msg(λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[2] = {acc_next, tail}; + Term t = term_new_pri(table_find("panic_go_msg", 12), 2, args0); + return wnf(t); + } + default: { + // %panic_go_num(acc, c, t) + // ------------------------- panic-go-num-default + // %panic_go_abort(acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term str = term_new_app(acc, con); + Term args0[1] = {str}; + Term t = term_new_pri(table_find("panic_go_abort", 14), 1, args0); + return wnf(t); + } + } +} + +fn void prim_panic_init(void) { + prim_register("panic", 5, 1, prim_fn_panic); + prim_register("panic_go_msg", 12, 2, panic_go_msg); + prim_register("panic_go_chr", 12, 3, panic_go_chr); + prim_register("panic_go_num", 12, 3, panic_go_num); + prim_register("panic_go_abort", 14, 1, prim_fn_panic_go_abort); +} diff --git a/clang/prim/fn/process/_.c b/clang/prim/fn/process/_.c new file mode 100644 index 00000000..26f3631b --- /dev/null +++ b/clang/prim/fn/process/_.c @@ -0,0 +1,199 @@ +#include +#include +#include + +#define PROCESS_CAP (1u << 20) + +#define PROCESS_ERR_BAD_ARG 1 +#define PROCESS_ERR_BAD_HANDLE 2 +#define PROCESS_ERR_STALE 3 +#define PROCESS_ERR_FULL 4 +#define PROCESS_ERR_IO 5 + +typedef struct { + u32 expected_seq; + pid_t pid; + u8 finished; + u8 signaled; + u32 code; +} ProcessSlot; + +static ProcessSlot PROCESS_SLOTS[PROCESS_CAP]; +static u32 PROCESS_NEXT_ID = 1; +static pthread_mutex_t PROCESS_LOCK = PTHREAD_MUTEX_INITIALIZER; + +static u32 PROCESS_NAM_PROC = 0; +static u32 PROCESS_NAM_PEND = 0; +static u32 PROCESS_NAM_RDY = 0; +static u32 PROCESS_NAM_EXIT = 0; +static u32 PROCESS_NAM_SIG = 0; + +fn Term wnf(Term term); + +fn Term process_new_err(const char *prim, u32 code, const char *msg) { + Term txt = term_string_printf("ERROR(%s): E%u %s", prim, code, msg); + return term_new_ctr(SYM_ERR, 1, &txt); +} + +fn Term process_new_ok(Term val) { + return term_new_ctr(SYM_OK, 1, &val); +} + +fn Term process_new_proc(u32 id, u32 seq) { + Term args[2] = {term_new_num(id), term_new_num(seq)}; + return term_new_ctr(PROCESS_NAM_PROC, 2, args); +} + +fn Term process_new_pend(u32 id, u32 seq) { + Term proc = process_new_proc(id, seq); + return term_new_ctr(PROCESS_NAM_PEND, 1, &proc); +} + +fn Term process_new_exit(u32 code) { + Term arg = term_new_num(code); + return term_new_ctr(PROCESS_NAM_EXIT, 1, &arg); +} + +fn Term process_new_sig(u32 sig) { + Term arg = term_new_num(sig); + return term_new_ctr(PROCESS_NAM_SIG, 1, &arg); +} + +fn Term process_new_rdy(u32 id, u32 seq, u8 signaled, u32 code) { + Term proc = process_new_proc(id, seq); + Term st = signaled ? process_new_sig(code) : process_new_exit(code); + Term args[2] = {proc, st}; + return term_new_ctr(PROCESS_NAM_RDY, 2, args); +} + +fn u8 process_parse_num(Term term, u32 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case NUM: { + *out = term_val(val); + return 1; + } + default: { + return 0; + } + } +} + +fn u8 process_parse_handle(Term term, u32 *id, u32 *seq) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C02: { + if (term_ext(val) != PROCESS_NAM_PROC) { + return 0; + } + + u32 loc = term_val(val); + Term id_tm = heap_read(loc + 0); + Term seq_tm = heap_read(loc + 1); + + if (!process_parse_num(id_tm, id)) { + return 0; + } + if (!process_parse_num(seq_tm, seq)) { + return 0; + } + return 1; + } + default: { + return 0; + } + } +} + +fn u8 process_is_valid_id(u32 id) { + pthread_mutex_lock(&PROCESS_LOCK); + + if (id == 0 || id >= PROCESS_NEXT_ID || id >= PROCESS_CAP) { + pthread_mutex_unlock(&PROCESS_LOCK); + return 0; + } + + pthread_mutex_unlock(&PROCESS_LOCK); + return 1; +} + +fn void process_set_finished(u32 id, u8 signaled, u32 code) { + pthread_mutex_lock(&PROCESS_LOCK); + + if (id != 0 && id < PROCESS_NEXT_ID && id < PROCESS_CAP) { + ProcessSlot *slot = &PROCESS_SLOTS[id]; + slot->finished = 1; + slot->signaled = signaled; + slot->code = code; + } + + pthread_mutex_unlock(&PROCESS_LOCK); +} + +fn u8 process_claim( + u32 id, + u32 seq, + pid_t *pid, + u8 *finished, + u8 *signaled, + u32 *code +) { + pthread_mutex_lock(&PROCESS_LOCK); + + if (id == 0 || id >= PROCESS_NEXT_ID || id >= PROCESS_CAP) { + pthread_mutex_unlock(&PROCESS_LOCK); + return 0; + } + + ProcessSlot *slot = &PROCESS_SLOTS[id]; + if (slot->expected_seq != seq) { + pthread_mutex_unlock(&PROCESS_LOCK); + return 0; + } + + slot->expected_seq = seq + 1; + *pid = slot->pid; + *finished = slot->finished; + *signaled = slot->signaled; + *code = slot->code; + + pthread_mutex_unlock(&PROCESS_LOCK); + return 1; +} + +fn void process_status_from_wait(int status, u8 *signaled, u32 *code) { + if (WIFEXITED(status)) { + *signaled = 0; + *code = (u32)WEXITSTATUS(status); + return; + } + + if (WIFSIGNALED(status)) { + *signaled = 1; + *code = (u32)WTERMSIG(status); + return; + } + + *signaled = 0; + *code = 255; +} + +#include "spawn.c" +#include "poll.c" +#include "wait.c" +#include "kill.c" + +fn void prim_process_init(void) { + PROCESS_NAM_PROC = table_find("Proc", 4); + PROCESS_NAM_PEND = table_find("Pend", 4); + PROCESS_NAM_RDY = table_find("Rdy", 3); + PROCESS_NAM_EXIT = table_find("Exit", 4); + PROCESS_NAM_SIG = table_find("Sig", 3); + + prim_process_spawn_init(); + prim_process_poll_init(); + prim_process_wait_init(); + prim_process_kill_init(); +} diff --git a/clang/prim/fn/process/kill.c b/clang/prim/fn/process/kill.c new file mode 100644 index 00000000..d470f89f --- /dev/null +++ b/clang/prim/fn/process/kill.c @@ -0,0 +1,112 @@ +// %process_kill(proc) +// ------------------- +// %process_kill_go_proc(proc) +fn Term prim_fn_process_kill(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("process_kill_go_proc", 20), 1, args0); + return wnf(t); +} + +// %process_kill_go_proc(proc) +// --------------------------- +// Lift `proc` over ERA/INC/SUP; default forwards to io stage. +fn Term process_kill_go_proc(Term *args) { + Term proc_wnf = wnf(args[0]); + + switch (term_tag(proc_wnf)) { + case ERA: { + // %process_kill_go_proc(&{}) + // --------------------------- process-kill-go-proc-era + // &{} + return term_new_era(); + } + case INC: { + // %process_kill_go_proc(↑x) + // -------------------------- process-kill-go-proc-inc + // ↑(%process_kill(x)) + u32 inc_loc = term_val(proc_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("process_kill", 12), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %process_kill_go_proc(&L{x,y}) + // ------------------------------- process-kill-go-proc-sup + // &L{%process_kill(x), %process_kill(y)} + u32 lab = term_ext(proc_wnf); + u32 sup_loc = term_val(proc_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("process_kill", 12), 1, &x); + Term t1 = term_new_pri(table_find("process_kill", 12), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %process_kill_go_proc(proc) + // --------------------------- process-kill-go-proc-default + // %process_kill_go_io(proc) + Term args0[1] = {proc_wnf}; + Term t = term_new_pri(table_find("process_kill_go_io", 18), 1, args0); + return wnf(t); + } + } +} + +// %process_kill_go_io(proc) +// ------------------------- +// #OK{#Pend{#Proc{id,seq+1}}|#Rdy{#Proc{id,seq+1},#Exit{n}|#Sig{n}}} | #ERR{String} +fn Term prim_fn_process_kill_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!process_parse_handle(args[0], &id, &seq)) { + return process_new_err("process_kill", PROCESS_ERR_BAD_HANDLE, "invalid `proc`; expected #Proc{id,seq}"); + } + + if (!process_is_valid_id(id)) { + return process_new_err("process_kill", PROCESS_ERR_BAD_HANDLE, "unknown process id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 signaled = 0; + u32 code = 0; + if (!process_claim(id, seq, &pid, &finished, &signaled, &code)) { + return process_new_err("process_kill", PROCESS_ERR_STALE, "stale process handle"); + } + + if (finished) { + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); + } + + if (kill(pid, SIGTERM) < 0 && errno != ESRCH) { + return process_new_err("process_kill", PROCESS_ERR_IO, strerror(errno)); + } + + int status = 0; + pid_t got = 0; + while (1) { + got = waitpid(pid, &status, WNOHANG); + if (got >= 0) { + break; + } + if (errno == EINTR) { + continue; + } + return process_new_err("process_kill", PROCESS_ERR_IO, strerror(errno)); + } + + if (got == 0) { + return process_new_ok(process_new_pend(id, seq + 1)); + } + + process_status_from_wait(status, &signaled, &code); + process_set_finished(id, signaled, code); + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); +} + +fn void prim_process_kill_init(void) { + prim_register("process_kill", 12, 1, prim_fn_process_kill); + prim_register("process_kill_go_proc", 20, 1, process_kill_go_proc); + prim_register("process_kill_go_io", 18, 1, prim_fn_process_kill_go_io); +} diff --git a/clang/prim/fn/process/poll.c b/clang/prim/fn/process/poll.c new file mode 100644 index 00000000..03e70a35 --- /dev/null +++ b/clang/prim/fn/process/poll.c @@ -0,0 +1,108 @@ +// %process_poll(proc) +// ------------------- +// %process_poll_go_proc(proc) +fn Term prim_fn_process_poll(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("process_poll_go_proc", 20), 1, args0); + return wnf(t); +} + +// %process_poll_go_proc(proc) +// --------------------------- +// Lift `proc` over ERA/INC/SUP; default forwards to io stage. +fn Term process_poll_go_proc(Term *args) { + Term proc_wnf = wnf(args[0]); + + switch (term_tag(proc_wnf)) { + case ERA: { + // %process_poll_go_proc(&{}) + // --------------------------- process-poll-go-proc-era + // &{} + return term_new_era(); + } + case INC: { + // %process_poll_go_proc(↑x) + // -------------------------- process-poll-go-proc-inc + // ↑(%process_poll(x)) + u32 inc_loc = term_val(proc_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("process_poll", 12), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %process_poll_go_proc(&L{x,y}) + // ------------------------------- process-poll-go-proc-sup + // &L{%process_poll(x), %process_poll(y)} + u32 lab = term_ext(proc_wnf); + u32 sup_loc = term_val(proc_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("process_poll", 12), 1, &x); + Term t1 = term_new_pri(table_find("process_poll", 12), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %process_poll_go_proc(proc) + // --------------------------- process-poll-go-proc-default + // %process_poll_go_io(proc) + Term args0[1] = {proc_wnf}; + Term t = term_new_pri(table_find("process_poll_go_io", 18), 1, args0); + return wnf(t); + } + } +} + +// %process_poll_go_io(proc) +// ------------------------- +// #OK{#Pend{#Proc{id,seq+1}}|#Rdy{#Proc{id,seq+1},#Exit{n}|#Sig{n}}} | #ERR{String} +fn Term prim_fn_process_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!process_parse_handle(args[0], &id, &seq)) { + return process_new_err("process_poll", PROCESS_ERR_BAD_HANDLE, "invalid `proc`; expected #Proc{id,seq}"); + } + + if (!process_is_valid_id(id)) { + return process_new_err("process_poll", PROCESS_ERR_BAD_HANDLE, "unknown process id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 signaled = 0; + u32 code = 0; + if (!process_claim(id, seq, &pid, &finished, &signaled, &code)) { + return process_new_err("process_poll", PROCESS_ERR_STALE, "stale process handle"); + } + + if (finished) { + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); + } + + int status = 0; + pid_t got = 0; + while (1) { + got = waitpid(pid, &status, WNOHANG); + if (got >= 0) { + break; + } + if (errno == EINTR) { + continue; + } + return process_new_err("process_poll", PROCESS_ERR_IO, strerror(errno)); + } + + if (got == 0) { + return process_new_ok(process_new_pend(id, seq + 1)); + } + + process_status_from_wait(status, &signaled, &code); + process_set_finished(id, signaled, code); + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); +} + +fn void prim_process_poll_init(void) { + prim_register("process_poll", 12, 1, prim_fn_process_poll); + prim_register("process_poll_go_proc", 20, 1, process_poll_go_proc); + prim_register("process_poll_go_io", 18, 1, prim_fn_process_poll_go_io); +} diff --git a/clang/prim/fn/process/spawn.c b/clang/prim/fn/process/spawn.c new file mode 100644 index 00000000..5cf4b1d0 --- /dev/null +++ b/clang/prim/fn/process/spawn.c @@ -0,0 +1,103 @@ +// %process_spawn(cmd) +// ------------------- +// %process_spawn_go_cmd(cmd) +fn Term prim_fn_process_spawn(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("process_spawn_go_cmd", 20), 1, args0); + return wnf(t); +} + +// %process_spawn_go_cmd(cmd) +// -------------------------- +// Lift `cmd` over ERA/INC/SUP; default forwards to io stage. +fn Term process_spawn_go_cmd(Term *args) { + Term cmd_wnf = wnf(args[0]); + + switch (term_tag(cmd_wnf)) { + case ERA: { + // %process_spawn_go_cmd(&{}) + // -------------------------- process-spawn-go-cmd-era + // &{} + return term_new_era(); + } + case INC: { + // %process_spawn_go_cmd(↑x) + // ------------------------- process-spawn-go-cmd-inc + // ↑(%process_spawn(x)) + u32 inc_loc = term_val(cmd_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("process_spawn", 13), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %process_spawn_go_cmd(&L{x,y}) + // ------------------------------ process-spawn-go-cmd-sup + // &L{%process_spawn(x), %process_spawn(y)} + u32 lab = term_ext(cmd_wnf); + u32 sup_loc = term_val(cmd_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("process_spawn", 13), 1, &x); + Term t1 = term_new_pri(table_find("process_spawn", 13), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %process_spawn_go_cmd(cmd) + // -------------------------- process-spawn-go-cmd-default + // %process_spawn_go_io(cmd) + Term args0[1] = {cmd_wnf}; + Term t = term_new_pri(table_find("process_spawn_go_io", 19), 1, args0); + return wnf(t); + } + } +} + +// %process_spawn_go_io(cmd) +// ------------------------- +// #OK{#Proc{id,0}} | #ERR{String} +fn Term prim_fn_process_spawn_go_io(Term *args) { + int MAX_CMD = 4096; + char cmd[MAX_CMD]; + + HStrErr cmd_err; + if (!term_string_to_utf8_cstr(args[0], cmd, MAX_CMD, NULL, &cmd_err)) { + return term_string_from_hstrerr("process_spawn", "cmd", MAX_CMD, cmd_err); + } + + pid_t pid = fork(); + if (pid < 0) { + int err = errno; + return process_new_err("process_spawn", PROCESS_ERR_IO, strerror(err)); + } + + if (pid == 0) { + execl("/bin/sh", "sh", "-c", cmd, (char *)NULL); + _exit(127); + } + + pthread_mutex_lock(&PROCESS_LOCK); + + u32 id = PROCESS_NEXT_ID; + if (id >= PROCESS_CAP) { + pthread_mutex_unlock(&PROCESS_LOCK); + kill(pid, SIGKILL); + return process_new_err("process_spawn", PROCESS_ERR_FULL, "process table is full"); + } + + PROCESS_NEXT_ID = id + 1; + PROCESS_SLOTS[id].expected_seq = 0; + PROCESS_SLOTS[id].pid = pid; + PROCESS_SLOTS[id].finished = 0; + PROCESS_SLOTS[id].signaled = 0; + PROCESS_SLOTS[id].code = 0; + + pthread_mutex_unlock(&PROCESS_LOCK); + return process_new_ok(process_new_proc(id, 0)); +} + +fn void prim_process_spawn_init(void) { + prim_register("process_spawn", 13, 1, prim_fn_process_spawn); + prim_register("process_spawn_go_cmd", 20, 1, process_spawn_go_cmd); + prim_register("process_spawn_go_io", 19, 1, prim_fn_process_spawn_go_io); +} diff --git a/clang/prim/fn/process/wait.c b/clang/prim/fn/process/wait.c new file mode 100644 index 00000000..909c8e8b --- /dev/null +++ b/clang/prim/fn/process/wait.c @@ -0,0 +1,104 @@ +// %process_wait(proc) +// ------------------- +// %process_wait_go_proc(proc) +fn Term prim_fn_process_wait(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("process_wait_go_proc", 20), 1, args0); + return wnf(t); +} + +// %process_wait_go_proc(proc) +// --------------------------- +// Lift `proc` over ERA/INC/SUP; default forwards to io stage. +fn Term process_wait_go_proc(Term *args) { + Term proc_wnf = wnf(args[0]); + + switch (term_tag(proc_wnf)) { + case ERA: { + // %process_wait_go_proc(&{}) + // --------------------------- process-wait-go-proc-era + // &{} + return term_new_era(); + } + case INC: { + // %process_wait_go_proc(↑x) + // -------------------------- process-wait-go-proc-inc + // ↑(%process_wait(x)) + u32 inc_loc = term_val(proc_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("process_wait", 12), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %process_wait_go_proc(&L{x,y}) + // ------------------------------- process-wait-go-proc-sup + // &L{%process_wait(x), %process_wait(y)} + u32 lab = term_ext(proc_wnf); + u32 sup_loc = term_val(proc_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("process_wait", 12), 1, &x); + Term t1 = term_new_pri(table_find("process_wait", 12), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %process_wait_go_proc(proc) + // --------------------------- process-wait-go-proc-default + // %process_wait_go_io(proc) + Term args0[1] = {proc_wnf}; + Term t = term_new_pri(table_find("process_wait_go_io", 18), 1, args0); + return wnf(t); + } + } +} + +// %process_wait_go_io(proc) +// ------------------------- +// #OK{#Rdy{#Proc{id,seq+1},#Exit{n}|#Sig{n}}} | #ERR{String} +fn Term prim_fn_process_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!process_parse_handle(args[0], &id, &seq)) { + return process_new_err("process_wait", PROCESS_ERR_BAD_HANDLE, "invalid `proc`; expected #Proc{id,seq}"); + } + + if (!process_is_valid_id(id)) { + return process_new_err("process_wait", PROCESS_ERR_BAD_HANDLE, "unknown process id"); + } + + pid_t pid = 0; + u8 finished = 0; + u8 signaled = 0; + u32 code = 0; + if (!process_claim(id, seq, &pid, &finished, &signaled, &code)) { + return process_new_err("process_wait", PROCESS_ERR_STALE, "stale process handle"); + } + + if (finished) { + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); + } + + int status = 0; + pid_t got = 0; + while (1) { + got = waitpid(pid, &status, 0); + if (got >= 0) { + break; + } + if (errno == EINTR) { + continue; + } + return process_new_err("process_wait", PROCESS_ERR_IO, strerror(errno)); + } + + process_status_from_wait(status, &signaled, &code); + process_set_finished(id, signaled, code); + return process_new_ok(process_new_rdy(id, seq + 1, signaled, code)); +} + +fn void prim_process_wait_init(void) { + prim_register("process_wait", 12, 1, prim_fn_process_wait); + prim_register("process_wait_go_proc", 20, 1, process_wait_go_proc); + prim_register("process_wait_go_io", 18, 1, prim_fn_process_wait_go_io); +} diff --git a/clang/prim/fn/rand.c b/clang/prim/fn/rand.c new file mode 100644 index 00000000..35f942d5 --- /dev/null +++ b/clang/prim/fn/rand.c @@ -0,0 +1,11 @@ +// %rand(dummy) +// ------------ +// NUM +fn Term prim_fn_rand(Term *args) { + (void)args[0]; + return term_new_num((u32)rand()); +} + +fn void prim_rand_init(void) { + prim_register("rand", 4, 1, prim_fn_rand); +} diff --git a/clang/prim/fn/read_bytes.c b/clang/prim/fn/read_bytes.c new file mode 100644 index 00000000..93d33d2b --- /dev/null +++ b/clang/prim/fn/read_bytes.c @@ -0,0 +1,321 @@ +fn Term read_bytes_go_path(Term *args); +fn Term read_bytes_go_chr(Term *args); +fn Term read_bytes_go_num(Term *args); + +// %read_bytes(path) +// ----------------- +// %read_bytes_go_path(λx.x, path) +fn Term prim_fn_read_bytes(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[2] = {acc, args[0]}; + Term t = term_new_pri(table_find("read_bytes_go_path", 18), 2, args0); + return wnf(t); +} + +// %read_bytes_go_path(acc, list) +// ------------------------------ +// Walk list shape with lifting over ERA/INC/SUP. +fn Term read_bytes_go_path(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %read_bytes_go_path(acc, &{}) + // ----------------------------- read-bytes-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %read_bytes_go_path(acc, ↑x) + // ---------------------------- read-bytes-go-path-inc + // ↑(%read_bytes(acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next = term_new_pri(table_find("read_bytes", 10), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_bytes_go_path(acc, &L{x,y}) + // --------------------------------- read-bytes-go-path-sup + // &L{%read_bytes(acc0(x)), %read_bytes(acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term t0 = term_new_pri(table_find("read_bytes", 10), 1, &app0); + Term t1 = term_new_pri(table_find("read_bytes", 10), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %read_bytes_go_path(acc, #Nil) + // ------------------------------ read-bytes-go-path-nil + // %read_bytes_go_io(acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term path = term_new_app(acc, nil); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_bytes_go_io", 16), 1, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %read_bytes_go_path(acc, #Con{h,t}) + // ----------------------------------- read-bytes-go-path-con + // %read_bytes_go_chr(acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[3] = {acc, head, tail}; + Term t = term_new_pri(table_find("read_bytes_go_chr", 17), 3, args0); + return wnf(t); + } + // %read_bytes_go_path(acc, x) + // ---------------------------- read-bytes-go-path-fallback + // fallthrough default + } + default: { + // %read_bytes_go_path(acc, x) + // ---------------------------- read-bytes-go-path-default + // %read_bytes_go_io(acc(x)) + Term path = term_new_app(acc, list_wnf); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_bytes_go_io", 16), 1, io_args); + return wnf(io); + } + } +} + +// %read_bytes_go_chr(acc, head, tail) +// ------------------------------------ +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term read_bytes_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %read_bytes_go_chr(acc, &{}, t) + // ------------------------------- read-bytes-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %read_bytes_go_chr(acc, ↑x, t) + // ------------------------------- read-bytes-go-chr-inc + // ↑(%read_bytes(acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("read_bytes", 10), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_bytes_go_chr(acc, &L{x,y}, t) + // ------------------------------------ read-bytes-go-chr-sup + // &L{%read_bytes(acc0(#Con{x, t0})), %read_bytes(acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("read_bytes", 10), 1, &app0); + Term t1 = term_new_pri(table_find("read_bytes", 10), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %read_bytes_go_chr(acc, #Chr{c}, t) + // ------------------------------------ read-bytes-go-chr-chr + // %read_bytes_go_num(acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[3] = {acc, code, tail}; + Term t = term_new_pri(table_find("read_bytes_go_num", 17), 3, args0); + return wnf(t); + } + // %read_bytes_go_chr(acc, h, t) + // ------------------------------ read-bytes-go-chr-fallback + // fallthrough default + } + default: { + // %read_bytes_go_chr(acc, h, t) + // ------------------------------ read-bytes-go-chr-default + // %read_bytes_go_io(acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_bytes_go_io", 16), 1, io_args); + return wnf(io); + } + } +} + +// %read_bytes_go_num(acc, code, tail) +// ------------------------------------ +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term read_bytes_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %read_bytes_go_num(acc, &{}, t) + // ------------------------------- read-bytes-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %read_bytes_go_num(acc, ↑x, t) + // ------------------------------- read-bytes-go-num-inc + // ↑(%read_bytes(acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("read_bytes", 10), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_bytes_go_num(acc, &L{x,y}, t) + // ------------------------------------ read-bytes-go-num-sup + // &L{%read_bytes(acc0(#Con{#Chr{x}, t0})), %read_bytes(acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("read_bytes", 10), 1, &app0); + Term t1 = term_new_pri(table_find("read_bytes", 10), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %read_bytes_go_num(acc, n, t) + // ------------------------------ read-bytes-go-num-num + // %read_bytes_go_path(λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[2] = {acc_next, tail}; + Term t = term_new_pri(table_find("read_bytes_go_path", 18), 2, args0); + return wnf(t); + } + default: { + // %read_bytes_go_num(acc, c, t) + // ------------------------------ read-bytes-go-num-default + // %read_bytes_go_io(acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_bytes_go_io", 16), 1, io_args); + return wnf(io); + } + } +} + +// %read_bytes_go_io(path) +// ----------------------- +// #OK{List<#BYT{NUM}>} | #ERR{String} +fn Term prim_fn_read_bytes_go_io(Term *args) { + int MAX_PATH = 1024; + char path[MAX_PATH]; // UTF-8 bytes + const char *OPEN_PATH_ERR_FMT = "ERROR(read_bytes): failed to open path '%s': %s (errno=%d)"; + const char *READ_IO_ERR_FMT = "ERROR(read_bytes): I/O error while reading '%s': %s (errno=%d)"; + + // Decode HVM path string (#CHR list) into `path` as UTF-8 bytes. + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("read_bytes", "path", MAX_PATH, path_err); + } + + FILE *file = fopen(path, "rb"); + if (!file) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(OPEN_PATH_ERR_FMT, path, strerror(err), err) }); + } + + // Initialize output list (empty file => #OK{#NIL}). + Term Nil = term_new_ctr(SYM_NIL, 0, 0); + unsigned char c; + // First read distinguishes empty file (EOF) from read error. + if (fread(&c, 1, 1, file) != 1) { + if (ferror(file)) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(READ_IO_ERR_FMT, path, strerror(err), err) }); + } + // First read hit EOF: file is empty, so payload is #NIL. + fclose(file); + return term_new_ctr(SYM_OK, 1, &Nil); + } + + Term byt[1] = {term_new_num(c)}; + Term h_t[2] = {term_new_ctr(SYM_BYT, 1, byt), Nil}; + Term result = term_new_ctr(SYM_CON, 2, h_t); + + // `curr` is the last #CON in the output List<#BYT{NUM}>. + Term curr = result; + while (fread(&c, 1, 1, file) == 1) { + byt[0] = term_new_num(c); + h_t[0] = term_new_ctr(SYM_BYT, 1, byt); + // Append #CON{#BYT{NUM}, #NIL} at curr tail. + heap_set(term_val(curr) + 1, term_new_ctr(SYM_CON, 2, h_t)); + curr = heap_read(term_val(curr) + 1); + } + + if (ferror(file)) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(READ_IO_ERR_FMT, path, strerror(err), err) }); + } + + fclose(file); + return term_new_ctr(SYM_OK, 1, &result); +} + +fn void prim_read_bytes_init(void) { + prim_register("read_bytes", 10, 1, prim_fn_read_bytes); + prim_register("read_bytes_go_path", 18, 2, read_bytes_go_path); + prim_register("read_bytes_go_chr", 17, 3, read_bytes_go_chr); + prim_register("read_bytes_go_num", 17, 3, read_bytes_go_num); + prim_register("read_bytes_go_io", 16, 1, prim_fn_read_bytes_go_io); +} diff --git a/clang/prim/fn/read_file.c b/clang/prim/fn/read_file.c new file mode 100644 index 00000000..d90e38f3 --- /dev/null +++ b/clang/prim/fn/read_file.c @@ -0,0 +1,352 @@ +fn Term read_file_go_path(Term *args); +fn Term read_file_go_chr(Term *args); +fn Term read_file_go_num(Term *args); + +// %read_file(path) +// ----------------- +// %read_file_go_path(λx.x, path) +fn Term prim_fn_read_file(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[2] = {acc, args[0]}; + Term t = term_new_pri(table_find("read_file_go_path", 17), 2, args0); + return wnf(t); +} + +// %read_file_go_path(acc, list) +// --------------------------- +// Walk list shape with lifting over ERA/INC/SUP. +fn Term read_file_go_path(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %read_file_go_path(acc, &{}) + // -------------------------- read-file-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %read_file_go_path(acc, ↑x) + // ------------------------- read-file-go-path-inc + // ↑(%read_file(acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next = term_new_pri(table_find("read_file", 9), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_file_go_path(acc, &L{x,y}) + // ------------------------------ read-file-go-path-sup + // &L{%read_file(acc0(x)), %read_file(acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term t0 = term_new_pri(table_find("read_file", 9), 1, &app0); + Term t1 = term_new_pri(table_find("read_file", 9), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %read_file_go_path(acc, #Nil) + // ---------------------------- read-file-go-path-nil + // %read_file_go_io(acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term path = term_new_app(acc, nil); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_file_go_io", 15), 1, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %read_file_go_path(acc, #Con{h,t}) + // --------------------------------- read-file-go-path-con + // %read_file_go_chr(acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[3] = {acc, head, tail}; + Term t = term_new_pri(table_find("read_file_go_chr", 16), 3, args0); + return wnf(t); + } + // %read_file_go_path(acc, x) + // ------------------------- read-file-go-path-fallback + // fallthrough default + } + default: { + // %read_file_go_path(acc, x) + // ------------------------- read-file-go-path-default + // %read_file_go_io(acc(x)) + Term path = term_new_app(acc, list_wnf); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_file_go_io", 15), 1, io_args); + return wnf(io); + } + } +} + +// %read_file_go_chr(acc, head, tail) +// --------------------------------- +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term read_file_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %read_file_go_chr(acc, &{}, t) + // ----------------------------- read-file-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %read_file_go_chr(acc, ↑x, t) + // ------------------------------ read-file-go-chr-inc + // ↑(%read_file(acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("read_file", 9), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_file_go_chr(acc, &L{x,y}, t) + // --------------------------------- read-file-go-chr-sup + // &L{%read_file(acc0(#Con{x, t0})), %read_file(acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("read_file", 9), 1, &app0); + Term t1 = term_new_pri(table_find("read_file", 9), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %read_file_go_chr(acc, #Chr{c}, t) + // ---------------------------------- read-file-go-chr-chr + // %read_file_go_num(acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[3] = {acc, code, tail}; + Term t = term_new_pri(table_find("read_file_go_num", 16), 3, args0); + return wnf(t); + } + // %read_file_go_chr(acc, h, t) + // ---------------------------- read-file-go-chr-fallback + // fallthrough default + } + default: { + // %read_file_go_chr(acc, h, t) + // ---------------------------- read-file-go-chr-default + // %read_file_go_io(acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_file_go_io", 15), 1, io_args); + return wnf(io); + } + } +} + +// %read_file_go_num(acc, code, tail) +// --------------------------------- +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term read_file_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %read_file_go_num(acc, &{}, t) + // ----------------------------- read-file-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %read_file_go_num(acc, ↑x, t) + // ------------------------------ read-file-go-num-inc + // ↑(%read_file(acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next = term_new_pri(table_find("read_file", 9), 1, &app); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %read_file_go_num(acc, &L{x,y}, t) + // --------------------------------- read-file-go-num-sup + // &L{%read_file(acc0(#Con{#Chr{x}, t0})), %read_file(acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term t0 = term_new_pri(table_find("read_file", 9), 1, &app0); + Term t1 = term_new_pri(table_find("read_file", 9), 1, &app1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %read_file_go_num(acc, n, t) + // ----------------------------- read-file-go-num-num + // %read_file_go_path(λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[2] = {acc_next, tail}; + Term t = term_new_pri(table_find("read_file_go_path", 17), 2, args0); + return wnf(t); + } + default: { + // %read_file_go_num(acc, c, t) + // ---------------------------- read-file-go-num-default + // %read_file_go_io(acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + Term io_args[1] = {path}; + Term io = term_new_pri(table_find("read_file_go_io", 15), 1, io_args); + return wnf(io); + } + } +} + +// %read_file_go_io(path) +// ---------------------- +// #OK{List<#CHR{NUM}>} | #ERR{String} +fn Term prim_fn_read_file_go_io(Term *args) { + int MAX_PATH = 1024; + char path[MAX_PATH]; // UTF-8 bytes + const char *OPEN_PATH_ERR_FMT = "ERROR(read_file): failed to open path '%s': %s (errno=%d)"; + const char *READ_IO_ERR_FMT = "ERROR(read_file): I/O error while reading '%s': %s (errno=%d)"; + const char *INVALID_UTF8_FMT = "ERROR(read_file): invalid UTF-8 at byte index %i"; + const char *TRUNC_UTF8_FMT = "ERROR(read_file): truncated UTF-8 sequence at byte index %i"; + + // Decode HVM path string (#CHR list) into `path` as UTF-8 bytes. + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("read_file", "path", MAX_PATH, path_err); + } + + FILE *file = fopen(path, "rb"); + if (!file) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(OPEN_PATH_ERR_FMT, path, strerror(err), err) }); + } + + Term Nil = term_new_ctr(SYM_NIL, 0, 0); + Term result = Nil; + Term curr = Nil; + u8 has_node = 0; + + // Incremental UTF-8 decoder state. + // `seq` stores bytes of the current candidate codepoint. + u8 seq[4]; + int seq_len = 0; + int byte_i = 0; + + u8 b; + while (fread(&b, 1, 1, file) == 1) { + if (seq_len >= 4) { + int seq_start = byte_i - seq_len; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(INVALID_UTF8_FMT, seq_start) }); + } + seq[seq_len] = b; + seq_len += 1; + + // Try to decode the current sequence from byte slice (not NUL-terminated). + u32 seq_idx = 0; + u32 cp = 0; + int dec = utf8_decode_next_bytes(seq, (u32)seq_len, &seq_idx, &cp); + if (dec == -2) { + // Need more bytes for the current codepoint. + byte_i += 1; + continue; + } + if (dec < 0) { + int seq_start = byte_i - (seq_len - 1); + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(INVALID_UTF8_FMT, seq_start) }); + } + + Term num = term_new_num(cp); + Term chr = term_new_ctr(SYM_CHR, 1, &num); + Term h_t[2] = {chr, Nil}; + Term node = term_new_ctr(SYM_CON, 2, h_t); + + if (!has_node) { + result = node; + has_node = 1; + } else { + heap_set(term_val(curr) + 1, node); + } + curr = node; + + seq_len = 0; + byte_i += 1; + } + + if (ferror(file)) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(READ_IO_ERR_FMT, path, strerror(err), err) }); + } + + if (seq_len != 0) { + int seq_start = byte_i - seq_len; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(TRUNC_UTF8_FMT, seq_start) }); + } + + fclose(file); + return term_new_ctr(SYM_OK, 1, &result); +} + +fn void prim_read_file_init(void) { + prim_register("read_file", 9, 1, prim_fn_read_file); + prim_register("read_file_go_path", 17, 2, read_file_go_path); + prim_register("read_file_go_chr", 16, 3, read_file_go_chr); + prim_register("read_file_go_num", 16, 3, read_file_go_num); + prim_register("read_file_go_io", 15, 1, prim_fn_read_file_go_io); +} diff --git a/clang/prim/fn/stream/_.c b/clang/prim/fn/stream/_.c new file mode 100644 index 00000000..476c22aa --- /dev/null +++ b/clang/prim/fn/stream/_.c @@ -0,0 +1,234 @@ +#include +#include +#include + +#define STREAM_CAP (1u << 20) + +#define STREAM_ERR_BAD_ARG 1 +#define STREAM_ERR_BAD_HANDLE 2 +#define STREAM_ERR_STALE 3 +#define STREAM_ERR_FULL 4 +#define STREAM_ERR_IO 5 + +#define STREAM_KIND_STDIN 1 +#define STREAM_KIND_FILE 2 + +typedef struct { + u32 expected_seq; + u8 kind; + u8 closed; + int fd; +} StreamSlot; + +static StreamSlot STREAM_SLOTS[STREAM_CAP]; +static u32 STREAM_NEXT_ID = 1; +static pthread_mutex_t STREAM_LOCK = PTHREAD_MUTEX_INITIALIZER; + +static u32 STREAM_NAM_STRM = 0; +static u32 STREAM_NAM_PEND = 0; +static u32 STREAM_NAM_RDY = 0; +static u32 STREAM_NAM_STREAM_BYTE = 0; +static u32 STREAM_NAM_STREAM_EOF = 0; + +fn Term wnf(Term term); + +fn Term stream_new_err(const char *prim, u32 code, const char *msg) { + Term txt = term_string_printf("ERROR(%s): E%u %s", prim, code, msg); + return term_new_ctr(SYM_ERR, 1, &txt); +} + +fn Term stream_new_ok(Term val) { + return term_new_ctr(SYM_OK, 1, &val); +} + +fn Term stream_new_handle(u32 id, u32 seq) { + Term args[2] = {term_new_num(id), term_new_num(seq)}; + return term_new_ctr(STREAM_NAM_STRM, 2, args); +} + +fn Term stream_new_pend(u32 id, u32 seq) { + Term strm = stream_new_handle(id, seq); + return term_new_ctr(STREAM_NAM_PEND, 1, &strm); +} + +fn Term stream_new_stream_byte(u32 byte) { + Term num = term_new_num(byte); + Term byt = term_new_ctr(SYM_BYT, 1, &num); + return term_new_ctr(STREAM_NAM_STREAM_BYTE, 1, &byt); +} + +fn Term stream_new_rdy_payload(u32 id, u32 seq, Term payload) { + Term strm = stream_new_handle(id, seq); + Term args[2] = {strm, payload}; + return term_new_ctr(STREAM_NAM_RDY, 2, args); +} + +fn Term stream_new_rdy_byt(u32 id, u32 seq, u32 byt) { + return stream_new_rdy_payload(id, seq, stream_new_stream_byte(byt)); +} + +fn Term stream_new_rdy_eof(u32 id, u32 seq) { + Term eof = term_new_ctr(STREAM_NAM_STREAM_EOF, 0, NULL); + return stream_new_rdy_payload(id, seq, eof); +} + +fn u8 stream_parse_num(Term term, u32 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case NUM: { + *out = term_val(val); + return 1; + } + default: { + return 0; + } + } +} + +fn u8 stream_parse_handle(Term term, u32 *id, u32 *seq) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C02: { + if (term_ext(val) != STREAM_NAM_STRM) { + return 0; + } + + u32 loc = term_val(val); + Term id_tm = heap_read(loc + 0); + Term seq_tm = heap_read(loc + 1); + + if (!stream_parse_num(id_tm, id)) { + return 0; + } + if (!stream_parse_num(seq_tm, seq)) { + return 0; + } + return 1; + } + default: { + return 0; + } + } +} + +fn u8 stream_is_valid_id(u32 id) { + pthread_mutex_lock(&STREAM_LOCK); + + if (id == 0 || id >= STREAM_NEXT_ID || id >= STREAM_CAP) { + pthread_mutex_unlock(&STREAM_LOCK); + return 0; + } + + pthread_mutex_unlock(&STREAM_LOCK); + return 1; +} + +fn u8 stream_claim(u32 id, u32 seq, u8 *kind, u8 *closed, int *fd) { + pthread_mutex_lock(&STREAM_LOCK); + + if (id == 0 || id >= STREAM_NEXT_ID || id >= STREAM_CAP) { + pthread_mutex_unlock(&STREAM_LOCK); + return 0; + } + + StreamSlot *slot = &STREAM_SLOTS[id]; + if (slot->expected_seq != seq) { + pthread_mutex_unlock(&STREAM_LOCK); + return 0; + } + + slot->expected_seq = seq + 1; + *kind = slot->kind; + *closed = slot->closed; + *fd = slot->fd; + + pthread_mutex_unlock(&STREAM_LOCK); + return 1; +} + +fn void stream_set_closed(u32 id) { + pthread_mutex_lock(&STREAM_LOCK); + + if (id != 0 && id < STREAM_NEXT_ID && id < STREAM_CAP) { + STREAM_SLOTS[id].closed = 1; + } + + pthread_mutex_unlock(&STREAM_LOCK); +} + +// Returns: +// 1 : ready (byte or eof) +// 0 : pending +// -1 : io error +fn int stream_stdin_read(int fd, int timeout_ms, u8 *out_byt, u8 *out_eof) { + *out_eof = 0; + + struct pollfd pfd = { + .fd = fd, + .events = POLLIN, + .revents = 0, + }; + + int poll_ret = 0; + while (1) { + poll_ret = poll(&pfd, 1, timeout_ms); + if (poll_ret >= 0) { + break; + } + if (errno == EINTR) { + continue; + } + return -1; + } + + if (poll_ret == 0) { + return 0; + } + + if ((pfd.revents & (POLLIN | POLLHUP | POLLERR)) == 0) { + return 0; + } + + while (1) { + u8 byt = 0; + ssize_t rd = read(fd, &byt, 1); + + if (rd == 1) { + *out_byt = byt; + return 1; + } + if (rd == 0) { + *out_eof = 1; + return 1; + } + if (errno == EINTR) { + continue; + } + if (errno == EAGAIN || errno == EWOULDBLOCK) { + return 0; + } + return -1; + } +} + +#include "stdin_open.c" +#include "file_open.c" +#include "poll.c" +#include "wait.c" +#include "close.c" + +fn void prim_stream_init(void) { + STREAM_NAM_STRM = table_find("Strm", 4); + STREAM_NAM_PEND = table_find("Pend", 4); + STREAM_NAM_RDY = table_find("Rdy", 3); + STREAM_NAM_STREAM_BYTE = table_find("StreamByte", 10); + STREAM_NAM_STREAM_EOF = table_find("StreamEof", 9); + + prim_stream_stdin_open_init(); + prim_stream_file_open_init(); + prim_stream_poll_init(); + prim_stream_wait_init(); + prim_stream_close_init(); +} diff --git a/clang/prim/fn/stream/close.c b/clang/prim/fn/stream/close.c new file mode 100644 index 00000000..9edb5451 --- /dev/null +++ b/clang/prim/fn/stream/close.c @@ -0,0 +1,100 @@ +// %stream_close(strm) +// ------------------- +// %stream_close_go_strm(strm) +fn Term prim_fn_stream_close(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("stream_close_go_strm", 20), 1, args0); + return wnf(t); +} + +// %stream_close_go_strm(strm) +// --------------------------- +// Lift `strm` over ERA/INC/SUP; default forwards to io stage. +fn Term stream_close_go_strm(Term *args) { + Term strm_wnf = wnf(args[0]); + + switch (term_tag(strm_wnf)) { + case ERA: { + // %stream_close_go_strm(&{}) + // -------------------------- stream-close-go-strm-era + // &{} + return term_new_era(); + } + case INC: { + // %stream_close_go_strm(↑x) + // ------------------------- stream-close-go-strm-inc + // ↑(%stream_close(x)) + u32 inc_loc = term_val(strm_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("stream_close", 12), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %stream_close_go_strm(&L{x,y}) + // ------------------------------- stream-close-go-strm-sup + // &L{%stream_close(x), %stream_close(y)} + u32 lab = term_ext(strm_wnf); + u32 sup_loc = term_val(strm_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("stream_close", 12), 1, &x); + Term t1 = term_new_pri(table_find("stream_close", 12), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %stream_close_go_strm(strm) + // --------------------------- stream-close-go-strm-default + // %stream_close_go_io(strm) + Term args0[1] = {strm_wnf}; + Term t = term_new_pri(table_find("stream_close_go_io", 18), 1, args0); + return wnf(t); + } + } +} + +// %stream_close_go_io(strm) +// ------------------------- +// #OK{#Nil} | #ERR{String} +fn Term prim_fn_stream_close_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!stream_parse_handle(args[0], &id, &seq)) { + return stream_new_err("stream_close", STREAM_ERR_BAD_HANDLE, "invalid `strm`; expected #Strm{id,seq}"); + } + + if (!stream_is_valid_id(id)) { + return stream_new_err("stream_close", STREAM_ERR_BAD_HANDLE, "unknown stream id"); + } + + u8 kind = 0; + u8 closed = 0; + int fd = -1; + if (!stream_claim(id, seq, &kind, &closed, &fd)) { + return stream_new_err("stream_close", STREAM_ERR_STALE, "stale stream handle"); + } + + if (closed) { + return stream_new_err("stream_close", STREAM_ERR_BAD_HANDLE, "stream is closed"); + } + + if (kind == STREAM_KIND_FILE) { + while (close(fd) < 0) { + if (errno == EINTR) { + continue; + } + stream_set_closed(id); + return stream_new_err("stream_close", STREAM_ERR_IO, strerror(errno)); + } + } + + stream_set_closed(id); + Term nil = term_new_ctr(SYM_NIL, 0, NULL); + return stream_new_ok(nil); +} + +fn void prim_stream_close_init(void) { + prim_register("stream_close", 12, 1, prim_fn_stream_close); + prim_register("stream_close_go_strm", 20, 1, stream_close_go_strm); + prim_register("stream_close_go_io", 18, 1, prim_fn_stream_close_go_io); +} diff --git a/clang/prim/fn/stream/file_open.c b/clang/prim/fn/stream/file_open.c new file mode 100644 index 00000000..3d913aec --- /dev/null +++ b/clang/prim/fn/stream/file_open.c @@ -0,0 +1,96 @@ +// %stream_file_open(path) +// ----------------------- +// %stream_file_open_go_path(path) +fn Term prim_fn_stream_file_open(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("stream_file_open_go_path", 24), 1, args0); + return wnf(t); +} + +// %stream_file_open_go_path(path) +// ------------------------------- +// Lift `path` over ERA/INC/SUP; default forwards to io stage. +fn Term stream_file_open_go_path(Term *args) { + Term path_wnf = wnf(args[0]); + + switch (term_tag(path_wnf)) { + case ERA: { + // %stream_file_open_go_path(&{}) + // ------------------------------ stream-file-open-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %stream_file_open_go_path(↑x) + // ----------------------------- stream-file-open-go-path-inc + // ↑(%stream_file_open(x)) + u32 inc_loc = term_val(path_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("stream_file_open", 16), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %stream_file_open_go_path(&L{x,y}) + // ----------------------------------- stream-file-open-go-path-sup + // &L{%stream_file_open(x), %stream_file_open(y)} + u32 lab = term_ext(path_wnf); + u32 sup_loc = term_val(path_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("stream_file_open", 16), 1, &x); + Term t1 = term_new_pri(table_find("stream_file_open", 16), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %stream_file_open_go_path(path) + // ------------------------------- stream-file-open-go-path-default + // %stream_file_open_go_io(path) + Term args0[1] = {path_wnf}; + Term t = term_new_pri(table_find("stream_file_open_go_io", 22), 1, args0); + return wnf(t); + } + } +} + +// %stream_file_open_go_io(path) +// ----------------------------- +// #OK{#Strm{id,0}} | #ERR{String} +fn Term prim_fn_stream_file_open_go_io(Term *args) { + int MAX_PATH = 4096; + char path[MAX_PATH]; + + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("stream_file_open", "path", MAX_PATH, path_err); + } + + int fd = open(path, O_RDONLY | O_CLOEXEC); + if (fd < 0) { + return stream_new_err("stream_file_open", STREAM_ERR_IO, strerror(errno)); + } + + pthread_mutex_lock(&STREAM_LOCK); + + u32 id = STREAM_NEXT_ID; + if (id >= STREAM_CAP) { + pthread_mutex_unlock(&STREAM_LOCK); + close(fd); + return stream_new_err("stream_file_open", STREAM_ERR_FULL, "stream table is full"); + } + + STREAM_NEXT_ID = id + 1; + STREAM_SLOTS[id].expected_seq = 0; + STREAM_SLOTS[id].kind = STREAM_KIND_FILE; + STREAM_SLOTS[id].closed = 0; + STREAM_SLOTS[id].fd = fd; + + pthread_mutex_unlock(&STREAM_LOCK); + return stream_new_ok(stream_new_handle(id, 0)); +} + +fn void prim_stream_file_open_init(void) { + prim_register("stream_file_open", 16, 1, prim_fn_stream_file_open); + prim_register("stream_file_open_go_path", 24, 1, stream_file_open_go_path); + prim_register("stream_file_open_go_io", 22, 1, prim_fn_stream_file_open_go_io); +} diff --git a/clang/prim/fn/stream/poll.c b/clang/prim/fn/stream/poll.c new file mode 100644 index 00000000..71590e89 --- /dev/null +++ b/clang/prim/fn/stream/poll.c @@ -0,0 +1,121 @@ +// %stream_poll(strm) +// ------------------ +// %stream_poll_go_strm(strm) +fn Term prim_fn_stream_poll(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("stream_poll_go_strm", 19), 1, args0); + return wnf(t); +} + +// %stream_poll_go_strm(strm) +// -------------------------- +// Lift `strm` over ERA/INC/SUP; default forwards to io stage. +fn Term stream_poll_go_strm(Term *args) { + Term strm_wnf = wnf(args[0]); + + switch (term_tag(strm_wnf)) { + case ERA: { + // %stream_poll_go_strm(&{}) + // ------------------------- stream-poll-go-strm-era + // &{} + return term_new_era(); + } + case INC: { + // %stream_poll_go_strm(↑x) + // ------------------------ stream-poll-go-strm-inc + // ↑(%stream_poll(x)) + u32 inc_loc = term_val(strm_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("stream_poll", 11), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %stream_poll_go_strm(&L{x,y}) + // ------------------------------ stream-poll-go-strm-sup + // &L{%stream_poll(x), %stream_poll(y)} + u32 lab = term_ext(strm_wnf); + u32 sup_loc = term_val(strm_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("stream_poll", 11), 1, &x); + Term t1 = term_new_pri(table_find("stream_poll", 11), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %stream_poll_go_strm(strm) + // -------------------------- stream-poll-go-strm-default + // %stream_poll_go_io(strm) + Term args0[1] = {strm_wnf}; + Term t = term_new_pri(table_find("stream_poll_go_io", 17), 1, args0); + return wnf(t); + } + } +} + +// %stream_poll_go_io(strm) +// ------------------------ +// #OK{#Pend{#Strm{id,seq+1}}|#Rdy{#Strm{id,seq+1},#StreamByte{#BYT{n}}|#StreamEof{}}} | #ERR{String} +fn Term prim_fn_stream_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!stream_parse_handle(args[0], &id, &seq)) { + return stream_new_err("stream_poll", STREAM_ERR_BAD_HANDLE, "invalid `strm`; expected #Strm{id,seq}"); + } + + if (!stream_is_valid_id(id)) { + return stream_new_err("stream_poll", STREAM_ERR_BAD_HANDLE, "unknown stream id"); + } + + u8 kind = 0; + u8 closed = 0; + int fd = -1; + if (!stream_claim(id, seq, &kind, &closed, &fd)) { + return stream_new_err("stream_poll", STREAM_ERR_STALE, "stale stream handle"); + } + + if (closed) { + return stream_new_err("stream_poll", STREAM_ERR_BAD_HANDLE, "stream is closed"); + } + + if (kind != STREAM_KIND_STDIN && kind != STREAM_KIND_FILE) { + return stream_new_err("stream_poll", STREAM_ERR_BAD_HANDLE, "unsupported stream kind"); + } + + if (kind == STREAM_KIND_FILE) { + while (1) { + u8 byt = 0; + ssize_t rd = read(fd, &byt, 1); + if (rd == 1) { + return stream_new_ok(stream_new_rdy_byt(id, seq + 1, byt)); + } + if (rd == 0) { + return stream_new_ok(stream_new_rdy_eof(id, seq + 1)); + } + if (errno == EINTR) { + continue; + } + return stream_new_err("stream_poll", STREAM_ERR_IO, strerror(errno)); + } + } + + u8 byt = 0; + u8 eof = 0; + int read_ret = stream_stdin_read(fd, 0, &byt, &eof); + if (read_ret < 0) { + return stream_new_err("stream_poll", STREAM_ERR_IO, strerror(errno)); + } + if (eof) { + return stream_new_ok(stream_new_rdy_eof(id, seq + 1)); + } + if (read_ret == 0) { + return stream_new_ok(stream_new_pend(id, seq + 1)); + } + return stream_new_ok(stream_new_rdy_byt(id, seq + 1, byt)); +} + +fn void prim_stream_poll_init(void) { + prim_register("stream_poll", 11, 1, prim_fn_stream_poll); + prim_register("stream_poll_go_strm", 19, 1, stream_poll_go_strm); + prim_register("stream_poll_go_io", 17, 1, prim_fn_stream_poll_go_io); +} diff --git a/clang/prim/fn/stream/stdin_open.c b/clang/prim/fn/stream/stdin_open.c new file mode 100644 index 00000000..d72b72e5 --- /dev/null +++ b/clang/prim/fn/stream/stdin_open.c @@ -0,0 +1,84 @@ +// %stream_stdin_open(seed) +// ------------------------ +// %stream_stdin_open_go_seed(seed) +fn Term prim_fn_stream_stdin_open(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("stream_stdin_open_go_seed", 25), 1, args0); + return wnf(t); +} + +// %stream_stdin_open_go_seed(seed) +// -------------------------------- +// Lift `seed` over ERA/INC/SUP; default forwards to io stage. +fn Term stream_stdin_open_go_seed(Term *args) { + Term seed_wnf = wnf(args[0]); + + switch (term_tag(seed_wnf)) { + case ERA: { + // %stream_stdin_open_go_seed(&{}) + // ------------------------------- stream-stdin-open-go-seed-era + // &{} + return term_new_era(); + } + case INC: { + // %stream_stdin_open_go_seed(↑x) + // ------------------------------ stream-stdin-open-go-seed-inc + // ↑(%stream_stdin_open(x)) + u32 inc_loc = term_val(seed_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("stream_stdin_open", 17), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %stream_stdin_open_go_seed(&L{x,y}) + // ------------------------------------ stream-stdin-open-go-seed-sup + // &L{%stream_stdin_open(x), %stream_stdin_open(y)} + u32 lab = term_ext(seed_wnf); + u32 sup_loc = term_val(seed_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("stream_stdin_open", 17), 1, &x); + Term t1 = term_new_pri(table_find("stream_stdin_open", 17), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %stream_stdin_open_go_seed(seed) + // -------------------------------- stream-stdin-open-go-seed-default + // %stream_stdin_open_go_io(seed) + Term args0[1] = {seed_wnf}; + Term t = term_new_pri(table_find("stream_stdin_open_go_io", 23), 1, args0); + return wnf(t); + } + } +} + +// %stream_stdin_open_go_io(seed) +// ------------------------------- +// #OK{#Strm{id,0}} | #ERR{String} +fn Term prim_fn_stream_stdin_open_go_io(Term *args) { + (void)args; + + pthread_mutex_lock(&STREAM_LOCK); + + u32 id = STREAM_NEXT_ID; + if (id >= STREAM_CAP) { + pthread_mutex_unlock(&STREAM_LOCK); + return stream_new_err("stream_stdin_open", STREAM_ERR_FULL, "stream table is full"); + } + + STREAM_NEXT_ID = id + 1; + STREAM_SLOTS[id].expected_seq = 0; + STREAM_SLOTS[id].kind = STREAM_KIND_STDIN; + STREAM_SLOTS[id].closed = 0; + STREAM_SLOTS[id].fd = 0; + + pthread_mutex_unlock(&STREAM_LOCK); + return stream_new_ok(stream_new_handle(id, 0)); +} + +fn void prim_stream_stdin_open_init(void) { + prim_register("stream_stdin_open", 17, 1, prim_fn_stream_stdin_open); + prim_register("stream_stdin_open_go_seed", 25, 1, stream_stdin_open_go_seed); + prim_register("stream_stdin_open_go_io", 23, 1, prim_fn_stream_stdin_open_go_io); +} diff --git a/clang/prim/fn/stream/wait.c b/clang/prim/fn/stream/wait.c new file mode 100644 index 00000000..d246ca69 --- /dev/null +++ b/clang/prim/fn/stream/wait.c @@ -0,0 +1,123 @@ +// %stream_wait(strm) +// ------------------ +// %stream_wait_go_strm(strm) +fn Term prim_fn_stream_wait(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("stream_wait_go_strm", 19), 1, args0); + return wnf(t); +} + +// %stream_wait_go_strm(strm) +// -------------------------- +// Lift `strm` over ERA/INC/SUP; default forwards to io stage. +fn Term stream_wait_go_strm(Term *args) { + Term strm_wnf = wnf(args[0]); + + switch (term_tag(strm_wnf)) { + case ERA: { + // %stream_wait_go_strm(&{}) + // ------------------------- stream-wait-go-strm-era + // &{} + return term_new_era(); + } + case INC: { + // %stream_wait_go_strm(↑x) + // ------------------------ stream-wait-go-strm-inc + // ↑(%stream_wait(x)) + u32 inc_loc = term_val(strm_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("stream_wait", 11), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %stream_wait_go_strm(&L{x,y}) + // ------------------------------ stream-wait-go-strm-sup + // &L{%stream_wait(x), %stream_wait(y)} + u32 lab = term_ext(strm_wnf); + u32 sup_loc = term_val(strm_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("stream_wait", 11), 1, &x); + Term t1 = term_new_pri(table_find("stream_wait", 11), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %stream_wait_go_strm(strm) + // -------------------------- stream-wait-go-strm-default + // %stream_wait_go_io(strm) + Term args0[1] = {strm_wnf}; + Term t = term_new_pri(table_find("stream_wait_go_io", 17), 1, args0); + return wnf(t); + } + } +} + +// %stream_wait_go_io(strm) +// ------------------------ +// #OK{#Rdy{#Strm{id,seq+1},#StreamByte{#BYT{n}}|#StreamEof{}}} | #ERR{String} +fn Term prim_fn_stream_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!stream_parse_handle(args[0], &id, &seq)) { + return stream_new_err("stream_wait", STREAM_ERR_BAD_HANDLE, "invalid `strm`; expected #Strm{id,seq}"); + } + + if (!stream_is_valid_id(id)) { + return stream_new_err("stream_wait", STREAM_ERR_BAD_HANDLE, "unknown stream id"); + } + + u8 kind = 0; + u8 closed = 0; + int fd = -1; + if (!stream_claim(id, seq, &kind, &closed, &fd)) { + return stream_new_err("stream_wait", STREAM_ERR_STALE, "stale stream handle"); + } + + if (closed) { + return stream_new_err("stream_wait", STREAM_ERR_BAD_HANDLE, "stream is closed"); + } + + if (kind != STREAM_KIND_STDIN && kind != STREAM_KIND_FILE) { + return stream_new_err("stream_wait", STREAM_ERR_BAD_HANDLE, "unsupported stream kind"); + } + + if (kind == STREAM_KIND_FILE) { + while (1) { + u8 byt = 0; + ssize_t rd = read(fd, &byt, 1); + if (rd == 1) { + return stream_new_ok(stream_new_rdy_byt(id, seq + 1, byt)); + } + if (rd == 0) { + return stream_new_ok(stream_new_rdy_eof(id, seq + 1)); + } + if (errno == EINTR) { + continue; + } + return stream_new_err("stream_wait", STREAM_ERR_IO, strerror(errno)); + } + } + + while (1) { + u8 byt = 0; + u8 eof = 0; + int read_ret = stream_stdin_read(fd, -1, &byt, &eof); + if (read_ret < 0) { + return stream_new_err("stream_wait", STREAM_ERR_IO, strerror(errno)); + } + if (read_ret == 0) { + continue; + } + if (eof) { + return stream_new_ok(stream_new_rdy_eof(id, seq + 1)); + } + return stream_new_ok(stream_new_rdy_byt(id, seq + 1, byt)); + } +} + +fn void prim_stream_wait_init(void) { + prim_register("stream_wait", 11, 1, prim_fn_stream_wait); + prim_register("stream_wait_go_strm", 19, 1, stream_wait_go_strm); + prim_register("stream_wait_go_io", 17, 1, prim_fn_stream_wait_go_io); +} diff --git a/clang/prim/fn/tcp/_.c b/clang/prim/fn/tcp/_.c new file mode 100644 index 00000000..2405ea2a --- /dev/null +++ b/clang/prim/fn/tcp/_.c @@ -0,0 +1,708 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#ifndef MSG_NOSIGNAL +#define MSG_NOSIGNAL 0 +#endif + +#define TCP_CAP (1u << 20) +#define TCP_HOST_CAP 1024 +#define TCP_RECV_CAP (1u << 20) +#define TCP_SEND_CAP (1u << 20) + +#define TCP_ERR_BAD_ARG 1 +#define TCP_ERR_BAD_HANDLE 2 +#define TCP_ERR_STALE 3 +#define TCP_ERR_FULL 4 +#define TCP_ERR_IO 5 + +#define TCP_STATE_CONNECTING 1 +#define TCP_STATE_OPEN 2 +#define TCP_STATE_REMOTE_EOF 3 +#define TCP_STATE_CLOSED 4 +#define TCP_STATE_FAILED 5 + +#define TCP_FAIL_TIMEOUT 1 +#define TCP_FAIL_DNS 2 +#define TCP_FAIL_REFUSED 3 +#define TCP_FAIL_UNREACHABLE 4 +#define TCP_FAIL_RESET 5 +#define TCP_FAIL_BROKEN_PIPE 6 +#define TCP_FAIL_PROTOCOL 7 +#define TCP_FAIL_NOT_CONNECTED 8 +#define TCP_FAIL_SYS 9 + +typedef struct { + u32 expected_seq; + int fd; + u8 state; + u32 connect_timeout_ms; + u32 read_timeout_ms; + u32 write_timeout_ms; + u64 connect_start_ms; +} TcpSlot; + +typedef struct { + int fd; + u8 state; + u32 connect_timeout_ms; + u32 read_timeout_ms; + u32 write_timeout_ms; + u64 connect_start_ms; +} TcpSnap; + +static TcpSlot TCP_SLOTS[TCP_CAP]; +static u32 TCP_NEXT_ID = 1; +static pthread_mutex_t TCP_LOCK = PTHREAD_MUTEX_INITIALIZER; + +static u32 TCP_NAM_TCP = 0; +static u32 TCP_NAM_TCP_REQ = 0; +static u32 TCP_NAM_TCP_OPTS = 0; + +static u32 TCP_NAM_PEND = 0; +static u32 TCP_NAM_RDY = 0; +static u32 TCP_NAM_CONN = 0; +static u32 TCP_NAM_RECV = 0; +static u32 TCP_NAM_SENT = 0; +static u32 TCP_NAM_EOF = 0; +static u32 TCP_NAM_CLOSED = 0; +static u32 TCP_NAM_FAIL = 0; + +static u32 TCP_NAM_TIMEOUT = 0; +static u32 TCP_NAM_DNS = 0; +static u32 TCP_NAM_REFUSED = 0; +static u32 TCP_NAM_UNREACHABLE = 0; +static u32 TCP_NAM_RESET = 0; +static u32 TCP_NAM_BROKEN_PIPE = 0; +static u32 TCP_NAM_PROTOCOL = 0; +static u32 TCP_NAM_NOT_CONNECTED = 0; +static u32 TCP_NAM_SYS = 0; + +static u32 TCP_NAM_T = 0; +static u32 TCP_NAM_F = 0; + +fn Term wnf(Term term); + +fn Term tcp_new_err(const char *prim, u32 code, const char *msg) { + Term txt = term_string_printf("ERROR(%s): E%u %s", prim, code, msg); + return term_new_ctr(SYM_ERR, 1, &txt); +} + +fn Term tcp_new_ok(Term val) { + return term_new_ctr(SYM_OK, 1, &val); +} + +fn Term tcp_new_tcp(u32 id, u32 seq) { + Term args[2] = {term_new_num(id), term_new_num(seq)}; + return term_new_ctr(TCP_NAM_TCP, 2, args); +} + +fn Term tcp_new_pend(u32 id, u32 seq) { + Term tcp = tcp_new_tcp(id, seq); + return term_new_ctr(TCP_NAM_PEND, 1, &tcp); +} + +fn Term tcp_new_rdy(u32 id, u32 seq, Term evt) { + Term tcp = tcp_new_tcp(id, seq); + Term args[2] = {tcp, evt}; + return term_new_ctr(TCP_NAM_RDY, 2, args); +} + +fn Term tcp_new_conn_evt(void) { + return term_new_ctr(TCP_NAM_CONN, 0, NULL); +} + +fn Term tcp_new_recv_evt(Term bytes) { + return term_new_ctr(TCP_NAM_RECV, 1, &bytes); +} + +fn Term tcp_new_sent_evt(u32 n) { + Term arg = term_new_num(n); + return term_new_ctr(TCP_NAM_SENT, 1, &arg); +} + +fn Term tcp_new_eof_evt(void) { + return term_new_ctr(TCP_NAM_EOF, 0, NULL); +} + +fn Term tcp_new_closed_evt(void) { + return term_new_ctr(TCP_NAM_CLOSED, 0, NULL); +} + +fn Term tcp_new_reason(u8 kind, u32 code) { + switch (kind) { + case TCP_FAIL_TIMEOUT: { + return term_new_ctr(TCP_NAM_TIMEOUT, 0, NULL); + } + case TCP_FAIL_DNS: { + return term_new_ctr(TCP_NAM_DNS, 0, NULL); + } + case TCP_FAIL_REFUSED: { + return term_new_ctr(TCP_NAM_REFUSED, 0, NULL); + } + case TCP_FAIL_UNREACHABLE: { + return term_new_ctr(TCP_NAM_UNREACHABLE, 0, NULL); + } + case TCP_FAIL_RESET: { + return term_new_ctr(TCP_NAM_RESET, 0, NULL); + } + case TCP_FAIL_BROKEN_PIPE: { + return term_new_ctr(TCP_NAM_BROKEN_PIPE, 0, NULL); + } + case TCP_FAIL_PROTOCOL: { + return term_new_ctr(TCP_NAM_PROTOCOL, 0, NULL); + } + case TCP_FAIL_NOT_CONNECTED: { + return term_new_ctr(TCP_NAM_NOT_CONNECTED, 0, NULL); + } + default: { + Term arg = term_new_num(code); + return term_new_ctr(TCP_NAM_SYS, 1, &arg); + } + } +} + +fn Term tcp_new_fail_evt(Term reason, Term msg) { + Term args[2] = {reason, msg}; + return term_new_ctr(TCP_NAM_FAIL, 2, args); +} + +fn Term tcp_fail_evt(u8 kind, u32 code, const char *msg) { + Term reason = tcp_new_reason(kind, code); + Term text = term_string_from_utf8(msg); + return tcp_new_fail_evt(reason, text); +} + +fn Term tcp_fail_not_connected_evt(void) { + return tcp_fail_evt(TCP_FAIL_NOT_CONNECTED, 0, "socket is not connected"); +} + +fn Term tcp_fail_timeout_evt(const char *op) { + Term reason = tcp_new_reason(TCP_FAIL_TIMEOUT, 0); + Term msg = term_string_printf("%s timeout", op); + return tcp_new_fail_evt(reason, msg); +} + +fn Term tcp_fail_from_errno_evt(const char *op, int err) { + u8 kind = TCP_FAIL_SYS; + + switch (err) { + case ETIMEDOUT: { + kind = TCP_FAIL_TIMEOUT; + break; + } + case ECONNREFUSED: { + kind = TCP_FAIL_REFUSED; + break; + } + case EHOSTUNREACH: + case ENETUNREACH: { + kind = TCP_FAIL_UNREACHABLE; + break; + } + case ECONNRESET: { + kind = TCP_FAIL_RESET; + break; + } + case EPIPE: { + kind = TCP_FAIL_BROKEN_PIPE; + break; + } + case ENOTCONN: { + kind = TCP_FAIL_NOT_CONNECTED; + break; + } + case EPROTO: + case EPROTONOSUPPORT: + case EPROTOTYPE: { + kind = TCP_FAIL_PROTOCOL; + break; + } + default: { + kind = TCP_FAIL_SYS; + break; + } + } + + Term reason = tcp_new_reason(kind, (u32)err); + Term msg = term_string_printf("%s: %s (errno=%d)", op, strerror(err), err); + return tcp_new_fail_evt(reason, msg); +} + +fn Term tcp_fail_from_gai_evt(const char *op, int gai_err) { + if (gai_err == EAI_NONAME || gai_err == EAI_AGAIN) { + Term reason = tcp_new_reason(TCP_FAIL_DNS, 0); + Term msg = term_string_printf("%s: %s (gai=%d)", op, gai_strerror(gai_err), gai_err); + return tcp_new_fail_evt(reason, msg); + } + + Term reason = tcp_new_reason(TCP_FAIL_SYS, (u32)(gai_err < 0 ? -gai_err : gai_err)); + Term msg = term_string_printf("%s: %s (gai=%d)", op, gai_strerror(gai_err), gai_err); + return tcp_new_fail_evt(reason, msg); +} + +fn u64 tcp_now_ms(void) { + struct timespec ts; + clock_gettime(CLOCK_MONOTONIC, &ts); + return (u64)ts.tv_sec * 1000ull + (u64)ts.tv_nsec / 1000000ull; +} + +fn int tcp_timeout_to_poll_ms(u64 start_ms, u32 timeout_ms) { + if (timeout_ms == 0) { + return -1; + } + + u64 now = tcp_now_ms(); + if (now >= start_ms + (u64)timeout_ms) { + return 0; + } + + u64 rem = (start_ms + (u64)timeout_ms) - now; + if (rem > (u64)INT_MAX) { + return INT_MAX; + } + + return (int)rem; +} + +fn u8 tcp_parse_num(Term term, u32 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case NUM: { + *out = term_val(val); + return 1; + } + default: { + return 0; + } + } +} + +fn u8 tcp_parse_bool(Term term, u8 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C00: { + u32 ext = term_ext(val); + if (ext == TCP_NAM_T) { + *out = 1; + return 1; + } + if (ext == TCP_NAM_F) { + *out = 0; + return 1; + } + return 0; + } + default: { + return 0; + } + } +} + +fn u8 tcp_parse_handle(Term term, u32 *id, u32 *seq) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C02: { + if (term_ext(val) != TCP_NAM_TCP) { + return 0; + } + + u32 loc = term_val(val); + Term id_tm = heap_read(loc + 0); + Term seq_tm = heap_read(loc + 1); + + if (!tcp_parse_num(id_tm, id)) { + return 0; + } + if (!tcp_parse_num(seq_tm, seq)) { + return 0; + } + return 1; + } + default: { + return 0; + } + } +} + +fn u8 tcp_is_valid_id(u32 id) { + pthread_mutex_lock(&TCP_LOCK); + + if (id == 0 || id >= TCP_NEXT_ID || id >= TCP_CAP) { + pthread_mutex_unlock(&TCP_LOCK); + return 0; + } + + pthread_mutex_unlock(&TCP_LOCK); + return 1; +} + +fn u8 tcp_claim(u32 id, u32 seq, TcpSnap *out) { + pthread_mutex_lock(&TCP_LOCK); + + if (id == 0 || id >= TCP_NEXT_ID || id >= TCP_CAP) { + pthread_mutex_unlock(&TCP_LOCK); + return 0; + } + + TcpSlot *slot = &TCP_SLOTS[id]; + if (slot->expected_seq != seq) { + pthread_mutex_unlock(&TCP_LOCK); + return 0; + } + + slot->expected_seq = seq + 1; + out->fd = slot->fd; + out->state = slot->state; + out->connect_timeout_ms = slot->connect_timeout_ms; + out->read_timeout_ms = slot->read_timeout_ms; + out->write_timeout_ms = slot->write_timeout_ms; + out->connect_start_ms = slot->connect_start_ms; + + pthread_mutex_unlock(&TCP_LOCK); + return 1; +} + +fn void tcp_slot_set_fd_state(u32 id, int fd, u8 state) { + pthread_mutex_lock(&TCP_LOCK); + + if (id != 0 && id < TCP_NEXT_ID && id < TCP_CAP) { + TcpSlot *slot = &TCP_SLOTS[id]; + slot->fd = fd; + slot->state = state; + } + + pthread_mutex_unlock(&TCP_LOCK); +} + +fn int tcp_close_fd(int fd) { + while (1) { + if (close(fd) == 0) { + return 1; + } + if (errno == EINTR) { + continue; + } + return 0; + } +} + +fn void tcp_slot_close_and_set(u32 id, int fd, u8 state) { + if (fd >= 0) { + tcp_close_fd(fd); + } + tcp_slot_set_fd_state(id, -1, state); +} + +fn int tcp_set_nonblocking(int fd) { + int flags = fcntl(fd, F_GETFL, 0); + if (flags < 0) { + return 0; + } + + if (fcntl(fd, F_SETFL, flags | O_NONBLOCK) < 0) { + return 0; + } + + return 1; +} + +fn int tcp_apply_sockopts(int fd, u8 nodelay, u8 keepalive) { +#ifdef SO_NOSIGPIPE + { + int on = 1; + if (setsockopt(fd, SOL_SOCKET, SO_NOSIGPIPE, &on, sizeof(on)) < 0) { + return 0; + } + } +#endif + + if (nodelay) { + int on = 1; + if (setsockopt(fd, IPPROTO_TCP, TCP_NODELAY, &on, sizeof(on)) < 0) { + return 0; + } + } + + if (keepalive) { + int on = 1; + if (setsockopt(fd, SOL_SOCKET, SO_KEEPALIVE, &on, sizeof(on)) < 0) { + return 0; + } + } + + return 1; +} + +fn u8 tcp_parse_req( + Term req_tm, + char host[TCP_HOST_CAP], + u32 *port, + u32 *connect_timeout_ms, + u32 *read_timeout_ms, + u32 *write_timeout_ms, + u8 *nodelay, + u8 *keepalive, + Term *err_out +) { + Term req = wnf(req_tm); + + if (term_tag(req) != C03 || term_ext(req) != TCP_NAM_TCP_REQ) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `req`; expected #TcpReq{host,port,opts}"); + return 0; + } + + u32 req_loc = term_val(req); + Term host_tm = heap_read(req_loc + 0); + Term port_tm = heap_read(req_loc + 1); + Term opts_tm = heap_read(req_loc + 2); + + HStrErr host_err; + if (!term_string_to_utf8_cstr(host_tm, host, TCP_HOST_CAP, NULL, &host_err)) { + *err_out = term_string_from_hstrerr("tcp_connect", "host", TCP_HOST_CAP, host_err); + return 0; + } + + if (!tcp_parse_num(port_tm, port) || *port == 0 || *port > 65535) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `port`; expected NUM in [1,65535]"); + return 0; + } + + Term opts = wnf(opts_tm); + if (term_tag(opts) != C05 || term_ext(opts) != TCP_NAM_TCP_OPTS) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `opts`; expected #TcpOpts{connect_timeout_ms,read_timeout_ms,write_timeout_ms,nodelay,keepalive}"); + return 0; + } + + u32 opts_loc = term_val(opts); + Term connect_tm = heap_read(opts_loc + 0); + Term read_tm = heap_read(opts_loc + 1); + Term write_tm = heap_read(opts_loc + 2); + Term nodelay_tm = heap_read(opts_loc + 3); + Term keep_tm = heap_read(opts_loc + 4); + + if (!tcp_parse_num(connect_tm, connect_timeout_ms)) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `connect_timeout_ms`; expected NUM"); + return 0; + } + if (!tcp_parse_num(read_tm, read_timeout_ms)) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `read_timeout_ms`; expected NUM"); + return 0; + } + if (!tcp_parse_num(write_tm, write_timeout_ms)) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `write_timeout_ms`; expected NUM"); + return 0; + } + if (!tcp_parse_bool(nodelay_tm, nodelay)) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `nodelay`; expected #T{}|#F{}"); + return 0; + } + if (!tcp_parse_bool(keep_tm, keepalive)) { + *err_out = tcp_new_err("tcp_connect", TCP_ERR_BAD_ARG, "invalid `keepalive`; expected #T{}|#F{}"); + return 0; + } + + return 1; +} + +fn u8 tcp_parse_recv_max(Term max_tm, u32 *max_bytes, Term *err_out) { + if (!tcp_parse_num(max_tm, max_bytes) || *max_bytes == 0 || *max_bytes > TCP_RECV_CAP) { + *err_out = tcp_new_err("tcp_recv", TCP_ERR_BAD_ARG, "invalid `max_bytes`; expected NUM in [1,TCP_RECV_CAP]"); + return 0; + } + return 1; +} + +fn u8 tcp_decode_bytes( + Term bytes_tm, + u8 **buf_out, + u32 *len_out, + u32 max_len, + Term *err_out +) { + Term cur = wnf(bytes_tm); + + u8 *buf = NULL; + u32 len = 0; + u32 cap = 0; + + while (term_tag(cur) == C02 && term_ext(cur) == SYM_CON) { + u32 loc = term_val(cur); + Term head = wnf(heap_read(loc + 0)); + Term tail = heap_read(loc + 1); + + if (term_tag(head) != C01 || term_ext(head) != SYM_BYT) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; expected List<#BYT{n}>"); + return 0; + } + + Term num = wnf(heap_read(term_val(head))); + if (term_tag(num) != NUM) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; expected #BYT{NUM}"); + return 0; + } + + u32 val = term_val(num); + if (val > 255) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; byte must be in [0,255]"); + return 0; + } + + if (len >= max_len) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; payload too large"); + return 0; + } + + if (len == cap) { + u32 next_cap = cap == 0 ? 256 : cap * 2; + if (next_cap > max_len) { + next_cap = max_len; + } + if (next_cap == cap) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; payload too large"); + return 0; + } + + u8 *next = realloc(buf, next_cap); + if (!next) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_IO, "out of memory while decoding bytes"); + return 0; + } + + buf = next; + cap = next_cap; + } + + buf[len] = (u8)val; + len = len + 1; + cur = wnf(tail); + } + + if (term_tag(cur) != C00 || term_ext(cur) != SYM_NIL) { + free(buf); + *err_out = tcp_new_err("tcp_send", TCP_ERR_BAD_ARG, "invalid `bytes`; expected List<#BYT{n}>"); + return 0; + } + + *buf_out = buf; + *len_out = len; + return 1; +} + +fn Term tcp_bytes_to_list(const u8 *buf, u32 len) { + Term nil = term_new_ctr(SYM_NIL, 0, NULL); + if (len == 0) { + return nil; + } + + Term byt[1] = {term_new_num(buf[0])}; + Term head_tail[2] = {term_new_ctr(SYM_BYT, 1, byt), nil}; + Term out = term_new_ctr(SYM_CON, 2, head_tail); + Term cur = out; + + for (u32 i = 1; i < len; ++i) { + byt[0] = term_new_num(buf[i]); + head_tail[0] = term_new_ctr(SYM_BYT, 1, byt); + heap_set(term_val(cur) + 1, term_new_ctr(SYM_CON, 2, head_tail)); + cur = heap_read(term_val(cur) + 1); + } + + return out; +} + +fn int tcp_poll_retry(struct pollfd *pfd, nfds_t nfd, int timeout_ms) { + while (1) { + int got = poll(pfd, nfd, timeout_ms); + if (got >= 0) { + return got; + } + if (errno == EINTR) { + continue; + } + return -1; + } +} + +fn Term tcp_connect_check_ready(u32 id, u32 seq, int fd) { + int so_err = 0; + socklen_t len = sizeof(so_err); + + if (getsockopt(fd, SOL_SOCKET, SO_ERROR, &so_err, &len) < 0) { + int err = errno; + tcp_slot_close_and_set(id, fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_connect", err))); + } + + if (so_err == 0) { + tcp_slot_set_fd_state(id, fd, TCP_STATE_OPEN); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_conn_evt())); + } + + tcp_slot_close_and_set(id, fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_connect", so_err))); +} + +fn Term tcp_state_not_connected(u32 id, u32 seq) { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_not_connected_evt())); +} + +#include "connect.c" +#include "connect_poll.c" +#include "connect_wait.c" +#include "recv_poll.c" +#include "recv_wait.c" +#include "send_poll.c" +#include "send_wait.c" +#include "close.c" + +fn void prim_tcp_init(void) { + TCP_NAM_TCP = table_find("Tcp", 3); + TCP_NAM_TCP_REQ = table_find("TcpReq", 6); + TCP_NAM_TCP_OPTS = table_find("TcpOpts", 7); + + TCP_NAM_PEND = table_find("Pend", 4); + TCP_NAM_RDY = table_find("Rdy", 3); + TCP_NAM_CONN = table_find("Conn", 4); + TCP_NAM_RECV = table_find("Recv", 4); + TCP_NAM_SENT = table_find("Sent", 4); + TCP_NAM_EOF = table_find("TcpEof", 6); + TCP_NAM_CLOSED = table_find("Closed", 6); + TCP_NAM_FAIL = table_find("TcpFail", 7); + + TCP_NAM_TIMEOUT = table_find("TcpTimeout", 10); + TCP_NAM_DNS = table_find("TcpDns", 6); + TCP_NAM_REFUSED = table_find("Refused", 7); + TCP_NAM_UNREACHABLE = table_find("Unreachable", 11); + TCP_NAM_RESET = table_find("Reset", 5); + TCP_NAM_BROKEN_PIPE = table_find("BrokenPipe", 10); + TCP_NAM_PROTOCOL = table_find("TcpProtocol", 11); + TCP_NAM_NOT_CONNECTED = table_find("NotConnected", 12); + TCP_NAM_SYS = table_find("Sys", 3); + + TCP_NAM_T = table_find("T", 1); + TCP_NAM_F = table_find("F", 1); + + prim_tcp_connect_init(); + prim_tcp_connect_poll_init(); + prim_tcp_connect_wait_init(); + prim_tcp_recv_poll_init(); + prim_tcp_recv_wait_init(); + prim_tcp_send_poll_init(); + prim_tcp_send_wait_init(); + prim_tcp_close_init(); +} diff --git a/clang/prim/fn/tcp/close.c b/clang/prim/fn/tcp/close.c new file mode 100644 index 00000000..092ad303 --- /dev/null +++ b/clang/prim/fn/tcp/close.c @@ -0,0 +1,102 @@ +// %tcp_close(tcp) +// --------------- +// %tcp_close_go_tcp(tcp) +fn Term prim_fn_tcp_close(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("tcp_close_go_tcp", sizeof("tcp_close_go_tcp") - 1), 1, args0); + return wnf(t); +} + +// %tcp_close_go_tcp(tcp) +// ---------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_close_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_close_go_tcp(&{}) + // ---------------------- tcp-close-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_close_go_tcp(↑x) + // --------------------- tcp-close-go-tcp-inc + // ↑(%tcp_close(x)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("tcp_close", sizeof("tcp_close") - 1), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_close_go_tcp(&L{x,y}) + // -------------------------- tcp-close-go-tcp-sup + // &L{%tcp_close(x), %tcp_close(y)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("tcp_close", sizeof("tcp_close") - 1), 1, &x); + Term t1 = term_new_pri(table_find("tcp_close", sizeof("tcp_close") - 1), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_close_go_tcp(tcp) + // ---------------------- tcp-close-go-tcp-default + // %tcp_close_go_io(tcp) + Term args0[1] = {tcp_wnf}; + Term t = term_new_pri(table_find("tcp_close_go_io", sizeof("tcp_close_go_io") - 1), 1, args0); + return wnf(t); + } + } +} + +// %tcp_close_go_io(tcp) +// --------------------- +// #OK{#Rdy{#Tcp{id,seq+1},#Closed{}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_close_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_close", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_close", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + return tcp_new_err("tcp_close", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_CONNECTING: + case TCP_STATE_OPEN: + case TCP_STATE_REMOTE_EOF: { + if (snap.fd >= 0 && !tcp_close_fd(snap.fd)) { + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_err("tcp_close", TCP_ERR_IO, strerror(errno)); + } + + tcp_slot_set_fd_state(id, -1, TCP_STATE_CLOSED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_closed_evt())); + } + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + return tcp_state_not_connected(id, seq); + } + default: { + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_close_init(void) { + prim_register("tcp_close", sizeof("tcp_close") - 1, 1, prim_fn_tcp_close); + prim_register("tcp_close_go_tcp", sizeof("tcp_close_go_tcp") - 1, 1, tcp_close_go_tcp); + prim_register("tcp_close_go_io", sizeof("tcp_close_go_io") - 1, 1, prim_fn_tcp_close_go_io); +} diff --git a/clang/prim/fn/tcp/connect.c b/clang/prim/fn/tcp/connect.c new file mode 100644 index 00000000..d260f575 --- /dev/null +++ b/clang/prim/fn/tcp/connect.c @@ -0,0 +1,179 @@ +// %tcp_connect(req) +// ----------------- +// %tcp_connect_go_req(req) +fn Term prim_fn_tcp_connect(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("tcp_connect_go_req", sizeof("tcp_connect_go_req") - 1), 1, args0); + return wnf(t); +} + +// %tcp_connect_go_req(req) +// ------------------------ +// Lift `req` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_connect_go_req(Term *args) { + Term req_wnf = wnf(args[0]); + + switch (term_tag(req_wnf)) { + case ERA: { + // %tcp_connect_go_req(&{}) + // ------------------------ tcp-connect-go-req-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_connect_go_req(↑x) + // ----------------------- tcp-connect-go-req-inc + // ↑(%tcp_connect(x)) + u32 inc_loc = term_val(req_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("tcp_connect", sizeof("tcp_connect") - 1), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_connect_go_req(&L{x,y}) + // ---------------------------- tcp-connect-go-req-sup + // &L{%tcp_connect(x), %tcp_connect(y)} + u32 lab = term_ext(req_wnf); + u32 sup_loc = term_val(req_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("tcp_connect", sizeof("tcp_connect") - 1), 1, &x); + Term t1 = term_new_pri(table_find("tcp_connect", sizeof("tcp_connect") - 1), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_connect_go_req(req) + // ------------------------ tcp-connect-go-req-default + // %tcp_connect_go_io(req) + Term args0[1] = {req_wnf}; + Term t = term_new_pri(table_find("tcp_connect_go_io", sizeof("tcp_connect_go_io") - 1), 1, args0); + return wnf(t); + } + } +} + +// %tcp_connect_go_io(req) +// ----------------------- +// #OK{#Tcp{id,0}} | #ERR{String} +fn Term prim_fn_tcp_connect_go_io(Term *args) { + char host[TCP_HOST_CAP]; + u32 port = 0; + u32 connect_timeout_ms = 0; + u32 read_timeout_ms = 0; + u32 write_timeout_ms = 0; + u8 nodelay = 0; + u8 keepalive = 0; + + Term parse_err = term_new_era(); + if (!tcp_parse_req( + args[0], + host, + &port, + &connect_timeout_ms, + &read_timeout_ms, + &write_timeout_ms, + &nodelay, + &keepalive, + &parse_err + )) { + return parse_err; + } + + char port_str[16]; + snprintf(port_str, sizeof(port_str), "%u", port); + + struct addrinfo hints; + struct addrinfo *res = NULL; + struct addrinfo *it = NULL; + int last_err = 0; + + memset(&hints, 0, sizeof(hints)); + hints.ai_family = AF_UNSPEC; + hints.ai_socktype = SOCK_STREAM; + hints.ai_protocol = IPPROTO_TCP; + + int gai_err = getaddrinfo(host, port_str, &hints, &res); + if (gai_err != 0) { + Term evt = tcp_fail_from_gai_evt("tcp_connect", gai_err); + u32 loc = term_val(evt); + Term msg = heap_read(loc + 1); + return term_new_ctr(SYM_ERR, 1, &msg); + } + + int fd = -1; + u8 state = TCP_STATE_CONNECTING; + + for (it = res; it != NULL; it = it->ai_next) { + fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol); + if (fd < 0) { + last_err = errno; + continue; + } + + if (!tcp_set_nonblocking(fd)) { + last_err = errno; + tcp_close_fd(fd); + fd = -1; + continue; + } + + if (!tcp_apply_sockopts(fd, nodelay, keepalive)) { + last_err = errno; + tcp_close_fd(fd); + fd = -1; + continue; + } + + if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) { + state = TCP_STATE_OPEN; + break; + } + + if (errno == EINPROGRESS || errno == EWOULDBLOCK || errno == EALREADY) { + state = TCP_STATE_CONNECTING; + break; + } + + last_err = errno; + tcp_close_fd(fd); + fd = -1; + } + + freeaddrinfo(res); + + if (fd < 0) { + if (last_err == 0) { + last_err = EIO; + } + return tcp_new_err("tcp_connect", TCP_ERR_IO, strerror(last_err)); + } + + pthread_mutex_lock(&TCP_LOCK); + + u32 id = TCP_NEXT_ID; + if (id >= TCP_CAP) { + pthread_mutex_unlock(&TCP_LOCK); + tcp_close_fd(fd); + return tcp_new_err("tcp_connect", TCP_ERR_FULL, "tcp table is full"); + } + + TCP_NEXT_ID = id + 1; + TcpSlot *slot = &TCP_SLOTS[id]; + slot->expected_seq = 0; + slot->fd = fd; + slot->state = state; + slot->connect_timeout_ms = connect_timeout_ms; + slot->read_timeout_ms = read_timeout_ms; + slot->write_timeout_ms = write_timeout_ms; + slot->connect_start_ms = tcp_now_ms(); + + pthread_mutex_unlock(&TCP_LOCK); + return tcp_new_ok(tcp_new_tcp(id, 0)); +} + +fn void prim_tcp_connect_init(void) { + prim_register("tcp_connect", sizeof("tcp_connect") - 1, 1, prim_fn_tcp_connect); + prim_register("tcp_connect_go_req", sizeof("tcp_connect_go_req") - 1, 1, tcp_connect_go_req); + prim_register("tcp_connect_go_io", sizeof("tcp_connect_go_io") - 1, 1, prim_fn_tcp_connect_go_io); +} diff --git a/clang/prim/fn/tcp/connect_poll.c b/clang/prim/fn/tcp/connect_poll.c new file mode 100644 index 00000000..b474d98c --- /dev/null +++ b/clang/prim/fn/tcp/connect_poll.c @@ -0,0 +1,121 @@ +// %tcp_connect_poll(tcp) +// ---------------------- +// %tcp_connect_poll_go_tcp(tcp) +fn Term prim_fn_tcp_connect_poll(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("tcp_connect_poll_go_tcp", sizeof("tcp_connect_poll_go_tcp") - 1), 1, args0); + return wnf(t); +} + +// %tcp_connect_poll_go_tcp(tcp) +// ----------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_connect_poll_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_connect_poll_go_tcp(&{}) + // ----------------------------- tcp-connect-poll-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_connect_poll_go_tcp(↑x) + // ---------------------------- tcp-connect-poll-go-tcp-inc + // ↑(%tcp_connect_poll(x)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("tcp_connect_poll", sizeof("tcp_connect_poll") - 1), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_connect_poll_go_tcp(&L{x,y}) + // --------------------------------- tcp-connect-poll-go-tcp-sup + // &L{%tcp_connect_poll(x), %tcp_connect_poll(y)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("tcp_connect_poll", sizeof("tcp_connect_poll") - 1), 1, &x); + Term t1 = term_new_pri(table_find("tcp_connect_poll", sizeof("tcp_connect_poll") - 1), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_connect_poll_go_tcp(tcp) + // ----------------------------- tcp-connect-poll-go-tcp-default + // %tcp_connect_poll_go_io(tcp) + Term args0[1] = {tcp_wnf}; + Term t = term_new_pri(table_find("tcp_connect_poll_go_io", sizeof("tcp_connect_poll_go_io") - 1), 1, args0); + return wnf(t); + } + } +} + +// %tcp_connect_poll_go_io(tcp) +// ---------------------------- +// #OK{#Pend{#Tcp{id,seq+1}}|#Rdy{#Tcp{id,seq+1},#Conn{}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_connect_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_connect_poll", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_connect_poll", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + return tcp_new_err("tcp_connect_poll", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_OPEN: + case TCP_STATE_REMOTE_EOF: { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_conn_evt())); + } + case TCP_STATE_CONNECTING: { + if (snap.fd < 0) { + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid connecting socket"))); + } + + if (snap.connect_timeout_ms != 0 && tcp_timeout_to_poll_ms(snap.connect_start_ms, snap.connect_timeout_ms) == 0) { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_connect"))); + } + + struct pollfd pfd = { + .fd = snap.fd, + .events = POLLOUT | POLLERR | POLLHUP, + .revents = 0, + }; + + int got = tcp_poll_retry(&pfd, 1, 0); + if (got < 0) { + return tcp_new_err("tcp_connect_poll", TCP_ERR_IO, strerror(errno)); + } + if (got == 0) { + return tcp_new_ok(tcp_new_pend(id, seq + 1)); + } + + return tcp_connect_check_ready(id, seq, snap.fd); + } + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + return tcp_state_not_connected(id, seq); + } + default: { + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_connect_poll_init(void) { + prim_register("tcp_connect_poll", sizeof("tcp_connect_poll") - 1, 1, prim_fn_tcp_connect_poll); + prim_register("tcp_connect_poll_go_tcp", sizeof("tcp_connect_poll_go_tcp") - 1, 1, tcp_connect_poll_go_tcp); + prim_register("tcp_connect_poll_go_io", sizeof("tcp_connect_poll_go_io") - 1, 1, prim_fn_tcp_connect_poll_go_io); +} diff --git a/clang/prim/fn/tcp/connect_wait.c b/clang/prim/fn/tcp/connect_wait.c new file mode 100644 index 00000000..9f98746c --- /dev/null +++ b/clang/prim/fn/tcp/connect_wait.c @@ -0,0 +1,122 @@ +// %tcp_connect_wait(tcp) +// ---------------------- +// %tcp_connect_wait_go_tcp(tcp) +fn Term prim_fn_tcp_connect_wait(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("tcp_connect_wait_go_tcp", sizeof("tcp_connect_wait_go_tcp") - 1), 1, args0); + return wnf(t); +} + +// %tcp_connect_wait_go_tcp(tcp) +// ----------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_connect_wait_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_connect_wait_go_tcp(&{}) + // ----------------------------- tcp-connect-wait-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_connect_wait_go_tcp(↑x) + // ---------------------------- tcp-connect-wait-go-tcp-inc + // ↑(%tcp_connect_wait(x)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("tcp_connect_wait", sizeof("tcp_connect_wait") - 1), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_connect_wait_go_tcp(&L{x,y}) + // --------------------------------- tcp-connect-wait-go-tcp-sup + // &L{%tcp_connect_wait(x), %tcp_connect_wait(y)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("tcp_connect_wait", sizeof("tcp_connect_wait") - 1), 1, &x); + Term t1 = term_new_pri(table_find("tcp_connect_wait", sizeof("tcp_connect_wait") - 1), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_connect_wait_go_tcp(tcp) + // ----------------------------- tcp-connect-wait-go-tcp-default + // %tcp_connect_wait_go_io(tcp) + Term args0[1] = {tcp_wnf}; + Term t = term_new_pri(table_find("tcp_connect_wait_go_io", sizeof("tcp_connect_wait_go_io") - 1), 1, args0); + return wnf(t); + } + } +} + +// %tcp_connect_wait_go_io(tcp) +// ---------------------------- +// #OK{#Rdy{#Tcp{id,seq+1},#Conn{}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_connect_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_connect_wait", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_connect_wait", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + return tcp_new_err("tcp_connect_wait", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_OPEN: + case TCP_STATE_REMOTE_EOF: { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_conn_evt())); + } + case TCP_STATE_CONNECTING: { + if (snap.fd < 0) { + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid connecting socket"))); + } + + int timeout_ms = tcp_timeout_to_poll_ms(snap.connect_start_ms, snap.connect_timeout_ms); + if (timeout_ms == 0) { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_connect"))); + } + + struct pollfd pfd = { + .fd = snap.fd, + .events = POLLOUT | POLLERR | POLLHUP, + .revents = 0, + }; + + int got = tcp_poll_retry(&pfd, 1, timeout_ms); + if (got < 0) { + return tcp_new_err("tcp_connect_wait", TCP_ERR_IO, strerror(errno)); + } + if (got == 0) { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_connect"))); + } + + return tcp_connect_check_ready(id, seq, snap.fd); + } + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + return tcp_state_not_connected(id, seq); + } + default: { + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_connect_wait_init(void) { + prim_register("tcp_connect_wait", sizeof("tcp_connect_wait") - 1, 1, prim_fn_tcp_connect_wait); + prim_register("tcp_connect_wait_go_tcp", sizeof("tcp_connect_wait_go_tcp") - 1, 1, tcp_connect_wait_go_tcp); + prim_register("tcp_connect_wait_go_io", sizeof("tcp_connect_wait_go_io") - 1, 1, prim_fn_tcp_connect_wait_go_io); +} diff --git a/clang/prim/fn/tcp/recv_poll.c b/clang/prim/fn/tcp/recv_poll.c new file mode 100644 index 00000000..f1bf47b1 --- /dev/null +++ b/clang/prim/fn/tcp/recv_poll.c @@ -0,0 +1,198 @@ +// %tcp_recv_poll(tcp, max_bytes) +// ------------------------------ +// %tcp_recv_poll_go_tcp(tcp, max_bytes) +fn Term prim_fn_tcp_recv_poll(Term *args) { + Term args0[2] = {args[0], args[1]}; + Term t = term_new_pri(table_find("tcp_recv_poll_go_tcp", sizeof("tcp_recv_poll_go_tcp") - 1), 2, args0); + return wnf(t); +} + +// %tcp_recv_poll_go_tcp(tcp, max_bytes) +// ------------------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to max stage. +fn Term tcp_recv_poll_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + Term max_bytes = args[1]; + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_recv_poll_go_tcp(&{}, max_bytes) + // ------------------------------------- tcp-recv-poll-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_recv_poll_go_tcp(↑x, max_bytes) + // ------------------------------------ tcp-recv-poll-go-tcp-inc + // ↑(%tcp_recv_poll(x, max_bytes)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {inner, max_bytes}; + Term next = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_recv_poll_go_tcp(&L{x,y}, max_bytes) + // ----------------------------------------- tcp-recv-poll-go-tcp-sup + // &L{%tcp_recv_poll(x, max0), %tcp_recv_poll(y, max1)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy M = term_clone(lab, max_bytes); + Term a0[2] = {x, M.k0}; + Term a1[2] = {y, M.k1}; + Term t0 = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_recv_poll_go_tcp(tcp, max_bytes) + // ------------------------------------- tcp-recv-poll-go-tcp-default + // %tcp_recv_poll_go_max(tcp, max_bytes) + Term args0[2] = {tcp_wnf, max_bytes}; + Term t = term_new_pri(table_find("tcp_recv_poll_go_max", sizeof("tcp_recv_poll_go_max") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_recv_poll_go_max(tcp, max_bytes) +// ------------------------------------- +// Lift `max_bytes` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_recv_poll_go_max(Term *args) { + Term tcp = args[0]; + Term max_wnf = wnf(args[1]); + + switch (term_tag(max_wnf)) { + case ERA: { + // %tcp_recv_poll_go_max(tcp, &{}) + // ------------------------------- tcp-recv-poll-go-max-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_recv_poll_go_max(tcp, ↑x) + // ------------------------------ tcp-recv-poll-go-max-inc + // ↑(%tcp_recv_poll(tcp, x)) + u32 inc_loc = term_val(max_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {tcp, inner}; + Term next = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_recv_poll_go_max(tcp, &L{x,y}) + // ------------------------------------ tcp-recv-poll-go-max-sup + // &L{%tcp_recv_poll(tcp0, x), %tcp_recv_poll(tcp1, y)} + u32 lab = term_ext(max_wnf); + u32 sup_loc = term_val(max_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy T = term_clone(lab, tcp); + Term a0[2] = {T.k0, x}; + Term a1[2] = {T.k1, y}; + Term t0 = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_recv_poll", sizeof("tcp_recv_poll") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_recv_poll_go_max(tcp, max_bytes) + // ------------------------------------- tcp-recv-poll-go-max-default + // %tcp_recv_poll_go_io(tcp, max_bytes) + Term args0[2] = {tcp, max_wnf}; + Term t = term_new_pri(table_find("tcp_recv_poll_go_io", sizeof("tcp_recv_poll_go_io") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_recv_poll_go_io(tcp, max_bytes) +// ------------------------------------ +// #OK{#Pend{#Tcp{id,seq+1}}|#Rdy{#Tcp{id,seq+1},#Recv{bytes}|#TcpEof{}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_recv_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_recv_poll", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_recv_poll", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + Term err = term_new_era(); + u32 max_bytes = 0; + if (!tcp_parse_recv_max(args[1], &max_bytes, &err)) { + return err; + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + return tcp_new_err("tcp_recv_poll", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_REMOTE_EOF: { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_eof_evt())); + } + case TCP_STATE_OPEN: { + if (snap.fd < 0) { + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_not_connected_evt())); + } + + u8 *buf = malloc(max_bytes); + if (!buf) { + return tcp_new_err("tcp_recv_poll", TCP_ERR_IO, "out of memory"); + } + + while (1) { + ssize_t got = recv(snap.fd, buf, max_bytes, 0); + if (got > 0) { + Term bytes = tcp_bytes_to_list(buf, (u32)got); + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_recv_evt(bytes))); + } + + if (got == 0) { + free(buf); + tcp_slot_set_fd_state(id, snap.fd, TCP_STATE_REMOTE_EOF); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_eof_evt())); + } + + if (errno == EINTR) { + continue; + } + + if (errno == EAGAIN || errno == EWOULDBLOCK) { + free(buf); + return tcp_new_ok(tcp_new_pend(id, seq + 1)); + } + + int errn = errno; + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_recv", errn))); + } + } + case TCP_STATE_CONNECTING: + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + return tcp_state_not_connected(id, seq); + } + default: { + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_recv_poll_init(void) { + prim_register("tcp_recv_poll", sizeof("tcp_recv_poll") - 1, 2, prim_fn_tcp_recv_poll); + prim_register("tcp_recv_poll_go_tcp", sizeof("tcp_recv_poll_go_tcp") - 1, 2, tcp_recv_poll_go_tcp); + prim_register("tcp_recv_poll_go_max", sizeof("tcp_recv_poll_go_max") - 1, 2, tcp_recv_poll_go_max); + prim_register("tcp_recv_poll_go_io", sizeof("tcp_recv_poll_go_io") - 1, 2, prim_fn_tcp_recv_poll_go_io); +} diff --git a/clang/prim/fn/tcp/recv_wait.c b/clang/prim/fn/tcp/recv_wait.c new file mode 100644 index 00000000..58ba6e19 --- /dev/null +++ b/clang/prim/fn/tcp/recv_wait.c @@ -0,0 +1,220 @@ +// %tcp_recv_wait(tcp, max_bytes) +// ------------------------------ +// %tcp_recv_wait_go_tcp(tcp, max_bytes) +fn Term prim_fn_tcp_recv_wait(Term *args) { + Term args0[2] = {args[0], args[1]}; + Term t = term_new_pri(table_find("tcp_recv_wait_go_tcp", sizeof("tcp_recv_wait_go_tcp") - 1), 2, args0); + return wnf(t); +} + +// %tcp_recv_wait_go_tcp(tcp, max_bytes) +// ------------------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to max stage. +fn Term tcp_recv_wait_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + Term max_bytes = args[1]; + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_recv_wait_go_tcp(&{}, max_bytes) + // ------------------------------------- tcp-recv-wait-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_recv_wait_go_tcp(↑x, max_bytes) + // ------------------------------------ tcp-recv-wait-go-tcp-inc + // ↑(%tcp_recv_wait(x, max_bytes)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {inner, max_bytes}; + Term next = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_recv_wait_go_tcp(&L{x,y}, max_bytes) + // ----------------------------------------- tcp-recv-wait-go-tcp-sup + // &L{%tcp_recv_wait(x, max0), %tcp_recv_wait(y, max1)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy M = term_clone(lab, max_bytes); + Term a0[2] = {x, M.k0}; + Term a1[2] = {y, M.k1}; + Term t0 = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_recv_wait_go_tcp(tcp, max_bytes) + // ------------------------------------- tcp-recv-wait-go-tcp-default + // %tcp_recv_wait_go_max(tcp, max_bytes) + Term args0[2] = {tcp_wnf, max_bytes}; + Term t = term_new_pri(table_find("tcp_recv_wait_go_max", sizeof("tcp_recv_wait_go_max") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_recv_wait_go_max(tcp, max_bytes) +// ------------------------------------- +// Lift `max_bytes` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_recv_wait_go_max(Term *args) { + Term tcp = args[0]; + Term max_wnf = wnf(args[1]); + + switch (term_tag(max_wnf)) { + case ERA: { + // %tcp_recv_wait_go_max(tcp, &{}) + // ------------------------------- tcp-recv-wait-go-max-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_recv_wait_go_max(tcp, ↑x) + // ------------------------------ tcp-recv-wait-go-max-inc + // ↑(%tcp_recv_wait(tcp, x)) + u32 inc_loc = term_val(max_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {tcp, inner}; + Term next = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_recv_wait_go_max(tcp, &L{x,y}) + // ----------------------------------- tcp-recv-wait-go-max-sup + // &L{%tcp_recv_wait(tcp0, x), %tcp_recv_wait(tcp1, y)} + u32 lab = term_ext(max_wnf); + u32 sup_loc = term_val(max_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy T = term_clone(lab, tcp); + Term a0[2] = {T.k0, x}; + Term a1[2] = {T.k1, y}; + Term t0 = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_recv_wait", sizeof("tcp_recv_wait") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_recv_wait_go_max(tcp, max_bytes) + // ------------------------------------- tcp-recv-wait-go-max-default + // %tcp_recv_wait_go_io(tcp, max_bytes) + Term args0[2] = {tcp, max_wnf}; + Term t = term_new_pri(table_find("tcp_recv_wait_go_io", sizeof("tcp_recv_wait_go_io") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_recv_wait_go_io(tcp, max_bytes) +// ------------------------------------ +// #OK{#Rdy{#Tcp{id,seq+1},#Recv{bytes}|#TcpEof{}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_recv_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_recv_wait", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_recv_wait", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + Term err = term_new_era(); + u32 max_bytes = 0; + if (!tcp_parse_recv_max(args[1], &max_bytes, &err)) { + return err; + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + return tcp_new_err("tcp_recv_wait", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_REMOTE_EOF: { + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_eof_evt())); + } + case TCP_STATE_OPEN: { + if (snap.fd < 0) { + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_not_connected_evt())); + } + + u8 *buf = malloc(max_bytes); + if (!buf) { + return tcp_new_err("tcp_recv_wait", TCP_ERR_IO, "out of memory"); + } + + u64 wait_start_ms = tcp_now_ms(); + + while (1) { + ssize_t got = recv(snap.fd, buf, max_bytes, 0); + if (got > 0) { + Term bytes = tcp_bytes_to_list(buf, (u32)got); + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_recv_evt(bytes))); + } + + if (got == 0) { + free(buf); + tcp_slot_set_fd_state(id, snap.fd, TCP_STATE_REMOTE_EOF); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_eof_evt())); + } + + if (errno == EINTR) { + continue; + } + + if (errno == EAGAIN || errno == EWOULDBLOCK) { + int timeout_ms = tcp_timeout_to_poll_ms(wait_start_ms, snap.read_timeout_ms); + if (timeout_ms == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_recv"))); + } + + struct pollfd pfd = { + .fd = snap.fd, + .events = POLLIN | POLLERR | POLLHUP, + .revents = 0, + }; + + int polled = tcp_poll_retry(&pfd, 1, timeout_ms); + if (polled < 0) { + free(buf); + return tcp_new_err("tcp_recv_wait", TCP_ERR_IO, strerror(errno)); + } + if (polled == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_recv"))); + } + continue; + } + + int errn = errno; + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_recv", errn))); + } + } + case TCP_STATE_CONNECTING: + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + return tcp_state_not_connected(id, seq); + } + default: { + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_recv_wait_init(void) { + prim_register("tcp_recv_wait", sizeof("tcp_recv_wait") - 1, 2, prim_fn_tcp_recv_wait); + prim_register("tcp_recv_wait_go_tcp", sizeof("tcp_recv_wait_go_tcp") - 1, 2, tcp_recv_wait_go_tcp); + prim_register("tcp_recv_wait_go_max", sizeof("tcp_recv_wait_go_max") - 1, 2, tcp_recv_wait_go_max); + prim_register("tcp_recv_wait_go_io", sizeof("tcp_recv_wait_go_io") - 1, 2, prim_fn_tcp_recv_wait_go_io); +} diff --git a/clang/prim/fn/tcp/send_poll.c b/clang/prim/fn/tcp/send_poll.c new file mode 100644 index 00000000..11065543 --- /dev/null +++ b/clang/prim/fn/tcp/send_poll.c @@ -0,0 +1,194 @@ +// %tcp_send_poll(tcp, bytes) +// -------------------------- +// %tcp_send_poll_go_tcp(tcp, bytes) +fn Term prim_fn_tcp_send_poll(Term *args) { + Term args0[2] = {args[0], args[1]}; + Term t = term_new_pri(table_find("tcp_send_poll_go_tcp", sizeof("tcp_send_poll_go_tcp") - 1), 2, args0); + return wnf(t); +} + +// %tcp_send_poll_go_tcp(tcp, bytes) +// --------------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to bytes stage. +fn Term tcp_send_poll_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + Term bytes = args[1]; + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_send_poll_go_tcp(&{}, bytes) + // --------------------------------- tcp-send-poll-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_send_poll_go_tcp(↑x, bytes) + // -------------------------------- tcp-send-poll-go-tcp-inc + // ↑(%tcp_send_poll(x, bytes)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {inner, bytes}; + Term next = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_send_poll_go_tcp(&L{x,y}, bytes) + // ------------------------------------- tcp-send-poll-go-tcp-sup + // &L{%tcp_send_poll(x, bytes0), %tcp_send_poll(y, bytes1)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy B = term_clone(lab, bytes); + Term a0[2] = {x, B.k0}; + Term a1[2] = {y, B.k1}; + Term t0 = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_send_poll_go_tcp(tcp, bytes) + // --------------------------------- tcp-send-poll-go-tcp-default + // %tcp_send_poll_go_bytes(tcp, bytes) + Term args0[2] = {tcp_wnf, bytes}; + Term t = term_new_pri(table_find("tcp_send_poll_go_bytes", sizeof("tcp_send_poll_go_bytes") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_send_poll_go_bytes(tcp, bytes) +// ----------------------------------- +// Lift `bytes` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_send_poll_go_bytes(Term *args) { + Term tcp = args[0]; + Term bytes_wnf = wnf(args[1]); + + switch (term_tag(bytes_wnf)) { + case ERA: { + // %tcp_send_poll_go_bytes(tcp, &{}) + // --------------------------------- tcp-send-poll-go-bytes-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_send_poll_go_bytes(tcp, ↑x) + // -------------------------------- tcp-send-poll-go-bytes-inc + // ↑(%tcp_send_poll(tcp, x)) + u32 inc_loc = term_val(bytes_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {tcp, inner}; + Term next = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_send_poll_go_bytes(tcp, &L{x,y}) + // ------------------------------------- tcp-send-poll-go-bytes-sup + // &L{%tcp_send_poll(tcp0, x), %tcp_send_poll(tcp1, y)} + u32 lab = term_ext(bytes_wnf); + u32 sup_loc = term_val(bytes_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy T = term_clone(lab, tcp); + Term a0[2] = {T.k0, x}; + Term a1[2] = {T.k1, y}; + Term t0 = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_send_poll", sizeof("tcp_send_poll") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_send_poll_go_bytes(tcp, bytes) + // ----------------------------------- tcp-send-poll-go-bytes-default + // %tcp_send_poll_go_io(tcp, bytes) + Term args0[2] = {tcp, bytes_wnf}; + Term t = term_new_pri(table_find("tcp_send_poll_go_io", sizeof("tcp_send_poll_go_io") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_send_poll_go_io(tcp, bytes) +// -------------------------------- +// #OK{#Pend{#Tcp{id,seq+1}}|#Rdy{#Tcp{id,seq+1},#Sent{n}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_send_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_send_poll", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_send_poll", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + Term err = term_new_era(); + u8 *buf = NULL; + u32 len = 0; + if (!tcp_decode_bytes(args[1], &buf, &len, TCP_SEND_CAP, &err)) { + return err; + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + free(buf); + return tcp_new_err("tcp_send_poll", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_OPEN: + case TCP_STATE_REMOTE_EOF: { + if (snap.fd < 0) { + free(buf); + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_not_connected_evt())); + } + + if (len == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_sent_evt(0))); + } + + while (1) { + ssize_t sent = send(snap.fd, buf, len, MSG_NOSIGNAL); + if (sent >= 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_sent_evt((u32)sent))); + } + + if (errno == EINTR) { + continue; + } + + if (errno == EAGAIN || errno == EWOULDBLOCK) { + free(buf); + return tcp_new_ok(tcp_new_pend(id, seq + 1)); + } + + int errn = errno; + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_send", errn))); + } + } + case TCP_STATE_CONNECTING: + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + free(buf); + return tcp_state_not_connected(id, seq); + } + default: { + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_send_poll_init(void) { + prim_register("tcp_send_poll", sizeof("tcp_send_poll") - 1, 2, prim_fn_tcp_send_poll); + prim_register("tcp_send_poll_go_tcp", sizeof("tcp_send_poll_go_tcp") - 1, 2, tcp_send_poll_go_tcp); + prim_register("tcp_send_poll_go_bytes", sizeof("tcp_send_poll_go_bytes") - 1, 2, tcp_send_poll_go_bytes); + prim_register("tcp_send_poll_go_io", sizeof("tcp_send_poll_go_io") - 1, 2, prim_fn_tcp_send_poll_go_io); +} diff --git a/clang/prim/fn/tcp/send_wait.c b/clang/prim/fn/tcp/send_wait.c new file mode 100644 index 00000000..57bfaf0b --- /dev/null +++ b/clang/prim/fn/tcp/send_wait.c @@ -0,0 +1,216 @@ +// %tcp_send_wait(tcp, bytes) +// -------------------------- +// %tcp_send_wait_go_tcp(tcp, bytes) +fn Term prim_fn_tcp_send_wait(Term *args) { + Term args0[2] = {args[0], args[1]}; + Term t = term_new_pri(table_find("tcp_send_wait_go_tcp", sizeof("tcp_send_wait_go_tcp") - 1), 2, args0); + return wnf(t); +} + +// %tcp_send_wait_go_tcp(tcp, bytes) +// --------------------------------- +// Lift `tcp` over ERA/INC/SUP; default forwards to bytes stage. +fn Term tcp_send_wait_go_tcp(Term *args) { + Term tcp_wnf = wnf(args[0]); + Term bytes = args[1]; + + switch (term_tag(tcp_wnf)) { + case ERA: { + // %tcp_send_wait_go_tcp(&{}, bytes) + // --------------------------------- tcp-send-wait-go-tcp-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_send_wait_go_tcp(↑x, bytes) + // -------------------------------- tcp-send-wait-go-tcp-inc + // ↑(%tcp_send_wait(x, bytes)) + u32 inc_loc = term_val(tcp_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {inner, bytes}; + Term next = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_send_wait_go_tcp(&L{x,y}, bytes) + // ------------------------------------- tcp-send-wait-go-tcp-sup + // &L{%tcp_send_wait(x, bytes0), %tcp_send_wait(y, bytes1)} + u32 lab = term_ext(tcp_wnf); + u32 sup_loc = term_val(tcp_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy B = term_clone(lab, bytes); + Term a0[2] = {x, B.k0}; + Term a1[2] = {y, B.k1}; + Term t0 = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_send_wait_go_tcp(tcp, bytes) + // --------------------------------- tcp-send-wait-go-tcp-default + // %tcp_send_wait_go_bytes(tcp, bytes) + Term args0[2] = {tcp_wnf, bytes}; + Term t = term_new_pri(table_find("tcp_send_wait_go_bytes", sizeof("tcp_send_wait_go_bytes") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_send_wait_go_bytes(tcp, bytes) +// ----------------------------------- +// Lift `bytes` over ERA/INC/SUP; default forwards to io stage. +fn Term tcp_send_wait_go_bytes(Term *args) { + Term tcp = args[0]; + Term bytes_wnf = wnf(args[1]); + + switch (term_tag(bytes_wnf)) { + case ERA: { + // %tcp_send_wait_go_bytes(tcp, &{}) + // --------------------------------- tcp-send-wait-go-bytes-era + // &{} + return term_new_era(); + } + case INC: { + // %tcp_send_wait_go_bytes(tcp, ↑x) + // -------------------------------- tcp-send-wait-go-bytes-inc + // ↑(%tcp_send_wait(tcp, x)) + u32 inc_loc = term_val(bytes_wnf); + Term inner = heap_read(inc_loc); + Term args0[2] = {tcp, inner}; + Term next = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, args0); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %tcp_send_wait_go_bytes(tcp, &L{x,y}) + // ------------------------------------- tcp-send-wait-go-bytes-sup + // &L{%tcp_send_wait(tcp0, x), %tcp_send_wait(tcp1, y)} + u32 lab = term_ext(bytes_wnf); + u32 sup_loc = term_val(bytes_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy T = term_clone(lab, tcp); + Term a0[2] = {T.k0, x}; + Term a1[2] = {T.k1, y}; + Term t0 = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, a0); + Term t1 = term_new_pri(table_find("tcp_send_wait", sizeof("tcp_send_wait") - 1), 2, a1); + return term_new_sup(lab, t0, t1); + } + default: { + // %tcp_send_wait_go_bytes(tcp, bytes) + // ----------------------------------- tcp-send-wait-go-bytes-default + // %tcp_send_wait_go_io(tcp, bytes) + Term args0[2] = {tcp, bytes_wnf}; + Term t = term_new_pri(table_find("tcp_send_wait_go_io", sizeof("tcp_send_wait_go_io") - 1), 2, args0); + return wnf(t); + } + } +} + +// %tcp_send_wait_go_io(tcp, bytes) +// -------------------------------- +// #OK{#Rdy{#Tcp{id,seq+1},#Sent{n}|#TcpFail{reason,msg}}} | #ERR{String} +fn Term prim_fn_tcp_send_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!tcp_parse_handle(args[0], &id, &seq)) { + return tcp_new_err("tcp_send_wait", TCP_ERR_BAD_HANDLE, "invalid `tcp`; expected #Tcp{id,seq}"); + } + + if (!tcp_is_valid_id(id)) { + return tcp_new_err("tcp_send_wait", TCP_ERR_BAD_HANDLE, "unknown tcp id"); + } + + Term err = term_new_era(); + u8 *buf = NULL; + u32 len = 0; + if (!tcp_decode_bytes(args[1], &buf, &len, TCP_SEND_CAP, &err)) { + return err; + } + + TcpSnap snap; + if (!tcp_claim(id, seq, &snap)) { + free(buf); + return tcp_new_err("tcp_send_wait", TCP_ERR_STALE, "stale tcp handle"); + } + + switch (snap.state) { + case TCP_STATE_OPEN: + case TCP_STATE_REMOTE_EOF: { + if (snap.fd < 0) { + free(buf); + tcp_slot_set_fd_state(id, -1, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_not_connected_evt())); + } + + if (len == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_sent_evt(0))); + } + + u64 wait_start_ms = tcp_now_ms(); + + while (1) { + ssize_t sent = send(snap.fd, buf, len, MSG_NOSIGNAL); + if (sent >= 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_new_sent_evt((u32)sent))); + } + + if (errno == EINTR) { + continue; + } + + if (errno == EAGAIN || errno == EWOULDBLOCK) { + int timeout_ms = tcp_timeout_to_poll_ms(wait_start_ms, snap.write_timeout_ms); + if (timeout_ms == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_send"))); + } + + struct pollfd pfd = { + .fd = snap.fd, + .events = POLLOUT | POLLERR | POLLHUP, + .revents = 0, + }; + + int polled = tcp_poll_retry(&pfd, 1, timeout_ms); + if (polled < 0) { + free(buf); + return tcp_new_err("tcp_send_wait", TCP_ERR_IO, strerror(errno)); + } + if (polled == 0) { + free(buf); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_timeout_evt("tcp_send"))); + } + continue; + } + + int errn = errno; + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_from_errno_evt("tcp_send", errn))); + } + } + case TCP_STATE_CONNECTING: + case TCP_STATE_CLOSED: + case TCP_STATE_FAILED: { + free(buf); + return tcp_state_not_connected(id, seq); + } + default: { + free(buf); + tcp_slot_close_and_set(id, snap.fd, TCP_STATE_FAILED); + return tcp_new_ok(tcp_new_rdy(id, seq + 1, tcp_fail_evt(TCP_FAIL_PROTOCOL, 0, "invalid tcp state"))); + } + } +} + +fn void prim_tcp_send_wait_init(void) { + prim_register("tcp_send_wait", sizeof("tcp_send_wait") - 1, 2, prim_fn_tcp_send_wait); + prim_register("tcp_send_wait_go_tcp", sizeof("tcp_send_wait_go_tcp") - 1, 2, tcp_send_wait_go_tcp); + prim_register("tcp_send_wait_go_bytes", sizeof("tcp_send_wait_go_bytes") - 1, 2, tcp_send_wait_go_bytes); + prim_register("tcp_send_wait_go_io", sizeof("tcp_send_wait_go_io") - 1, 2, prim_fn_tcp_send_wait_go_io); +} diff --git a/clang/prim/fn/timer/_.c b/clang/prim/fn/timer/_.c new file mode 100644 index 00000000..79d4e608 --- /dev/null +++ b/clang/prim/fn/timer/_.c @@ -0,0 +1,155 @@ +#define TIMER_CAP (1u << 20) + +#define TIMER_ERR_BAD_ARG 1 +#define TIMER_ERR_BAD_HANDLE 2 +#define TIMER_ERR_STALE 3 +#define TIMER_ERR_FULL 4 + +typedef struct { + u32 expected_seq; + u64 due_ns; +} TimerSlot; + +static TimerSlot TIMER_SLOTS[TIMER_CAP]; +static u32 TIMER_NEXT_ID = 1; +static pthread_mutex_t TIMER_LOCK = PTHREAD_MUTEX_INITIALIZER; + +static u32 TIMER_NAM_TIME = 0; +static u32 TIMER_NAM_PEND = 0; +static u32 TIMER_NAM_RDY = 0; +static u32 TIMER_NAM_NONE = 0; + +fn Term wnf(Term term); + +fn u64 timer_now_ns(void) { + struct timespec ts; + clock_gettime(CLOCK_MONOTONIC, &ts); + return (u64)ts.tv_sec * 1000000000ull + (u64)ts.tv_nsec; +} + +fn void timer_sleep_ns(u64 ns) { + struct timespec req = { + .tv_sec = (time_t)(ns / 1000000000ull), + .tv_nsec = (long)(ns % 1000000000ull), + }; + + while (req.tv_sec != 0 || req.tv_nsec != 0) { + if (nanosleep(&req, &req) == 0) { + return; + } + } +} + +fn Term timer_new_err(const char *prim, u32 code, const char *msg) { + Term txt = term_string_printf("ERROR(%s): E%u %s", prim, code, msg); + return term_new_ctr(SYM_ERR, 1, &txt); +} + +fn Term timer_new_ok(Term val) { + return term_new_ctr(SYM_OK, 1, &val); +} + +fn Term timer_new_time(u32 id, u32 seq) { + Term args[2] = {term_new_num(id), term_new_num(seq)}; + return term_new_ctr(TIMER_NAM_TIME, 2, args); +} + +fn Term timer_new_pend(u32 id, u32 seq) { + Term time = timer_new_time(id, seq); + return term_new_ctr(TIMER_NAM_PEND, 1, &time); +} + +fn Term timer_new_rdy(u32 id, u32 seq) { + Term time = timer_new_time(id, seq); + Term none = term_new_ctr(TIMER_NAM_NONE, 0, NULL); + Term args[2] = {time, none}; + return term_new_ctr(TIMER_NAM_RDY, 2, args); +} + +fn u8 timer_parse_num(Term term, u32 *out) { + Term val = wnf(term); + + switch (term_tag(val)) { + case NUM: { + *out = term_val(val); + return 1; + } + default: { + return 0; + } + } +} + +fn u8 timer_parse_handle(Term term, u32 *id, u32 *seq) { + Term val = wnf(term); + + switch (term_tag(val)) { + case C02: { + if (term_ext(val) != TIMER_NAM_TIME) { + return 0; + } + + u32 loc = term_val(val); + Term id_tm = heap_read(loc + 0); + Term seq_tm = heap_read(loc + 1); + + if (!timer_parse_num(id_tm, id)) { + return 0; + } + if (!timer_parse_num(seq_tm, seq)) { + return 0; + } + return 1; + } + default: { + return 0; + } + } +} + +fn u8 timer_is_valid_id(u32 id) { + pthread_mutex_lock(&TIMER_LOCK); + + if (id == 0 || id >= TIMER_NEXT_ID || id >= TIMER_CAP) { + pthread_mutex_unlock(&TIMER_LOCK); + return 0; + } + + pthread_mutex_unlock(&TIMER_LOCK); + return 1; +} + +fn u8 timer_claim(u32 id, u32 seq, u64 *due_ns) { + pthread_mutex_lock(&TIMER_LOCK); + + if (id == 0 || id >= TIMER_NEXT_ID || id >= TIMER_CAP) { + pthread_mutex_unlock(&TIMER_LOCK); + return 0; + } + + TimerSlot *slot = &TIMER_SLOTS[id]; + if (slot->expected_seq != seq) { + pthread_mutex_unlock(&TIMER_LOCK); + return 0; + } + + slot->expected_seq = seq + 1; + *due_ns = slot->due_ns; + pthread_mutex_unlock(&TIMER_LOCK); + return 1; +} + +#include "start.c" +#include "poll.c" +#include "wait.c" + +fn void prim_timer_init(void) { + TIMER_NAM_TIME = table_find("Time", 4); + TIMER_NAM_PEND = table_find("Pend", 4); + TIMER_NAM_RDY = table_find("Rdy", 3); + TIMER_NAM_NONE = table_find("None", 4); + + prim_timer_start_init(); + prim_timer_poll_init(); + prim_timer_wait_init(); +} diff --git a/clang/prim/fn/timer/poll.c b/clang/prim/fn/timer/poll.c new file mode 100644 index 00000000..c2fe6e08 --- /dev/null +++ b/clang/prim/fn/timer/poll.c @@ -0,0 +1,86 @@ +// %timer_poll(time) +// ----------------- +// %timer_poll_go_time(time) +fn Term prim_fn_timer_poll(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("timer_poll_go_time", 18), 1, args0); + return wnf(t); +} + +// %timer_poll_go_time(time) +// ------------------------- +// Lift `time` over ERA/INC/SUP; default forwards to io stage. +fn Term timer_poll_go_time(Term *args) { + Term time_wnf = wnf(args[0]); + + switch (term_tag(time_wnf)) { + case ERA: { + // %timer_poll_go_time(&{}) + // ------------------------ timer-poll-go-time-era + // &{} + return term_new_era(); + } + case INC: { + // %timer_poll_go_time(↑x) + // ----------------------- timer-poll-go-time-inc + // ↑(%timer_poll(x)) + u32 inc_loc = term_val(time_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("timer_poll", 10), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %timer_poll_go_time(&L{x,y}) + // ---------------------------- timer-poll-go-time-sup + // &L{%timer_poll(x), %timer_poll(y)} + u32 lab = term_ext(time_wnf); + u32 sup_loc = term_val(time_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("timer_poll", 10), 1, &x); + Term t1 = term_new_pri(table_find("timer_poll", 10), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %timer_poll_go_time(time) + // ------------------------- timer-poll-go-time-default + // %timer_poll_go_io(time) + Term args0[1] = {time_wnf}; + Term t = term_new_pri(table_find("timer_poll_go_io", 16), 1, args0); + return wnf(t); + } + } +} + +// %timer_poll_go_io(time) +// ----------------------- +// #OK{#Pend{#Time{id,seq+1}}|#Rdy{#Time{id,seq+1},#None{}}} | #ERR{String} +fn Term prim_fn_timer_poll_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!timer_parse_handle(args[0], &id, &seq)) { + return timer_new_err("timer_poll", TIMER_ERR_BAD_HANDLE, "invalid `time`; expected #Time{id,seq}"); + } + + if (!timer_is_valid_id(id)) { + return timer_new_err("timer_poll", TIMER_ERR_BAD_HANDLE, "unknown timer id"); + } + + u64 due_ns = 0; + if (!timer_claim(id, seq, &due_ns)) { + return timer_new_err("timer_poll", TIMER_ERR_STALE, "stale timer handle"); + } + + u64 now = timer_now_ns(); + if (now >= due_ns) { + return timer_new_ok(timer_new_rdy(id, seq + 1)); + } + return timer_new_ok(timer_new_pend(id, seq + 1)); +} + +fn void prim_timer_poll_init(void) { + prim_register("timer_poll", 10, 1, prim_fn_timer_poll); + prim_register("timer_poll_go_time", 18, 1, timer_poll_go_time); + prim_register("timer_poll_go_io", 16, 1, prim_fn_timer_poll_go_io); +} diff --git a/clang/prim/fn/timer/start.c b/clang/prim/fn/timer/start.c new file mode 100644 index 00000000..16ff7e34 --- /dev/null +++ b/clang/prim/fn/timer/start.c @@ -0,0 +1,91 @@ +// %timer_start(ms) +// ---------------- +// %timer_start_go_ms(ms) +fn Term prim_fn_timer_start(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("timer_start_go_ms", 17), 1, args0); + return wnf(t); +} + +// %timer_start_go_ms(ms) +// ---------------------- +// Lift `ms` over ERA/INC/SUP; default forwards to io stage. +fn Term timer_start_go_ms(Term *args) { + Term ms_wnf = wnf(args[0]); + + switch (term_tag(ms_wnf)) { + case ERA: { + // %timer_start_go_ms(&{}) + // ----------------------- timer-start-go-ms-era + // &{} + return term_new_era(); + } + case INC: { + // %timer_start_go_ms(↑x) + // ---------------------- timer-start-go-ms-inc + // ↑(%timer_start(x)) + u32 inc_loc = term_val(ms_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("timer_start", 11), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %timer_start_go_ms(&L{x,y}) + // --------------------------- timer-start-go-ms-sup + // &L{%timer_start(x), %timer_start(y)} + u32 lab = term_ext(ms_wnf); + u32 sup_loc = term_val(ms_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("timer_start", 11), 1, &x); + Term t1 = term_new_pri(table_find("timer_start", 11), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %timer_start_go_ms(ms) + // ---------------------- timer-start-go-ms-default + // %timer_start_go_io(ms) + Term args0[1] = {ms_wnf}; + Term t = term_new_pri(table_find("timer_start_go_io", 17), 1, args0); + return wnf(t); + } + } +} + +// %timer_start_go_io(ms) +// ---------------------- +// #OK{#Time{id,0}} | #ERR{String} +fn Term prim_fn_timer_start_go_io(Term *args) { + u32 ms = 0; + if (!timer_parse_num(args[0], &ms)) { + return timer_new_err("timer_start", TIMER_ERR_BAD_ARG, "invalid `ms`; expected NUM"); + } + + u64 now = timer_now_ns(); + u64 due = now + (u64)ms * 1000000ull; + if (due < now) { + due = UINT64_MAX; + } + + pthread_mutex_lock(&TIMER_LOCK); + + u32 id = TIMER_NEXT_ID; + if (id >= TIMER_CAP) { + pthread_mutex_unlock(&TIMER_LOCK); + return timer_new_err("timer_start", TIMER_ERR_FULL, "timer table is full"); + } + + TIMER_NEXT_ID = id + 1; + TIMER_SLOTS[id].expected_seq = 0; + TIMER_SLOTS[id].due_ns = due; + + pthread_mutex_unlock(&TIMER_LOCK); + return timer_new_ok(timer_new_time(id, 0)); +} + +fn void prim_timer_start_init(void) { + prim_register("timer_start", 11, 1, prim_fn_timer_start); + prim_register("timer_start_go_ms", 17, 1, timer_start_go_ms); + prim_register("timer_start_go_io", 17, 1, prim_fn_timer_start_go_io); +} diff --git a/clang/prim/fn/timer/wait.c b/clang/prim/fn/timer/wait.c new file mode 100644 index 00000000..3ca75a52 --- /dev/null +++ b/clang/prim/fn/timer/wait.c @@ -0,0 +1,87 @@ +// %timer_wait(time) +// ----------------- +// %timer_wait_go_time(time) +fn Term prim_fn_timer_wait(Term *args) { + Term args0[1] = {args[0]}; + Term t = term_new_pri(table_find("timer_wait_go_time", 18), 1, args0); + return wnf(t); +} + +// %timer_wait_go_time(time) +// ------------------------- +// Lift `time` over ERA/INC/SUP; default forwards to io stage. +fn Term timer_wait_go_time(Term *args) { + Term time_wnf = wnf(args[0]); + + switch (term_tag(time_wnf)) { + case ERA: { + // %timer_wait_go_time(&{}) + // ------------------------ timer-wait-go-time-era + // &{} + return term_new_era(); + } + case INC: { + // %timer_wait_go_time(↑x) + // ----------------------- timer-wait-go-time-inc + // ↑(%timer_wait(x)) + u32 inc_loc = term_val(time_wnf); + Term inner = heap_read(inc_loc); + Term next = term_new_pri(table_find("timer_wait", 10), 1, &inner); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %timer_wait_go_time(&L{x,y}) + // ---------------------------- timer-wait-go-time-sup + // &L{%timer_wait(x), %timer_wait(y)} + u32 lab = term_ext(time_wnf); + u32 sup_loc = term_val(time_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Term t0 = term_new_pri(table_find("timer_wait", 10), 1, &x); + Term t1 = term_new_pri(table_find("timer_wait", 10), 1, &y); + return term_new_sup(lab, t0, t1); + } + default: { + // %timer_wait_go_time(time) + // ------------------------- timer-wait-go-time-default + // %timer_wait_go_io(time) + Term args0[1] = {time_wnf}; + Term t = term_new_pri(table_find("timer_wait_go_io", 16), 1, args0); + return wnf(t); + } + } +} + +// %timer_wait_go_io(time) +// ----------------------- +// #OK{#Rdy{#Time{id,seq+1},#None{}}} | #ERR{String} +fn Term prim_fn_timer_wait_go_io(Term *args) { + u32 id = 0; + u32 seq = 0; + if (!timer_parse_handle(args[0], &id, &seq)) { + return timer_new_err("timer_wait", TIMER_ERR_BAD_HANDLE, "invalid `time`; expected #Time{id,seq}"); + } + + if (!timer_is_valid_id(id)) { + return timer_new_err("timer_wait", TIMER_ERR_BAD_HANDLE, "unknown timer id"); + } + + u64 due_ns = 0; + if (!timer_claim(id, seq, &due_ns)) { + return timer_new_err("timer_wait", TIMER_ERR_STALE, "stale timer handle"); + } + + u64 now = timer_now_ns(); + if (now < due_ns) { + timer_sleep_ns(due_ns - now); + } + + return timer_new_ok(timer_new_rdy(id, seq + 1)); +} + +fn void prim_timer_wait_init(void) { + prim_register("timer_wait", 10, 1, prim_fn_timer_wait); + prim_register("timer_wait_go_time", 18, 1, timer_wait_go_time); + prim_register("timer_wait_go_io", 16, 1, prim_fn_timer_wait_go_io); +} diff --git a/clang/prim/fn/uid.c b/clang/prim/fn/uid.c new file mode 100644 index 00000000..79c0417e --- /dev/null +++ b/clang/prim/fn/uid.c @@ -0,0 +1,44 @@ +#include + +static _Atomic u64 UID_PREFIX = 0; +static _Atomic u64 UID_COUNT = 0; + +fn u64 uid_get_prefix(void) { + u64 prefix = atomic_load_explicit(&UID_PREFIX, memory_order_relaxed); + if (prefix != 0) { + return prefix; + } + + struct timespec ts; + clock_gettime(CLOCK_REALTIME, &ts); + u64 seed = ((u64)ts.tv_sec << 32) ^ (u64)ts.tv_nsec ^ (u64)getpid(); + if (seed == 0) { + seed = 1; + } + + u64 expected = 0; + if (atomic_compare_exchange_strong_explicit( + &UID_PREFIX, &expected, seed, memory_order_relaxed, memory_order_relaxed)) { + return seed; + } + + return atomic_load_explicit(&UID_PREFIX, memory_order_relaxed); +} + +// %uid(dummy) +// ----------- +// String (guaranteed unique per process) +fn Term prim_fn_uid(Term *args) { + (void)args[0]; + + u64 prefix = uid_get_prefix(); + u64 n = atomic_fetch_add_explicit(&UID_COUNT, 1, memory_order_relaxed); + + return term_string_printf("uid-%016llx-%016llx", + (unsigned long long)prefix, + (unsigned long long)n); +} + +fn void prim_uid_init(void) { + prim_register("uid", 3, 1, prim_fn_uid); +} diff --git a/clang/prim/fn/uuid.c b/clang/prim/fn/uuid.c new file mode 100644 index 00000000..93f61eff --- /dev/null +++ b/clang/prim/fn/uuid.c @@ -0,0 +1,90 @@ +#include +#include + +fn int uuid_fill_random(u8 out[16], int *err_out) { + int fd = open("/dev/urandom", O_RDONLY); + if (fd < 0) { + if (err_out != NULL) { + *err_out = errno; + } + return 0; + } + + int got = 0; + while (got < 16) { + ssize_t n = read(fd, out + got, (size_t)(16 - got)); + if (n < 0) { + if (errno == EINTR) { + continue; + } + int err = errno; + close(fd); + if (err_out != NULL) { + *err_out = err; + } + return 0; + } + if (n == 0) { + close(fd); + if (err_out != NULL) { + *err_out = EIO; + } + return 0; + } + got += (int)n; + } + + if (close(fd) != 0) { + if (err_out != NULL) { + *err_out = errno; + } + return 0; + } + + if (err_out != NULL) { + *err_out = 0; + } + return 1; +} + +fn void uuid_v4_format(const u8 b[16], char out[37]) { + static const char *HEX = "0123456789abcdef"; + int j = 0; + + for (int i = 0; i < 16; ++i) { + if (i == 4 || i == 6 || i == 8 || i == 10) { + out[j++] = '-'; + } + out[j++] = HEX[(b[i] >> 4) & 0xF]; + out[j++] = HEX[b[i] & 0xF]; + } + + out[j] = 0; +} + +// %uuid(dummy) +// ------------ +// #OK{String} | #ERR{String} +fn Term prim_fn_uuid(Term *args) { + (void)args[0]; + + const char *RNG_ERR_FMT = "ERROR(uuid): failed to get secure random bytes: %s (errno=%d)"; + u8 bytes[16]; + int err = 0; + if (!uuid_fill_random(bytes, &err)) { + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(RNG_ERR_FMT, strerror(err), err) }); + } + + // RFC4122 variant + version 4 layout bits. + bytes[6] = (u8)((bytes[6] & 0x0F) | 0x40); + bytes[8] = (u8)((bytes[8] & 0x3F) | 0x80); + + char str[37]; + uuid_v4_format(bytes, str); + Term out = term_string_from_utf8(str); + return term_new_ctr(SYM_OK, 1, &out); +} + +fn void prim_uuid_init(void) { + prim_register("uuid", 4, 1, prim_fn_uuid); +} diff --git a/clang/prim/fn/write_bytes.c b/clang/prim/fn/write_bytes.c new file mode 100644 index 00000000..dde45ad2 --- /dev/null +++ b/clang/prim/fn/write_bytes.c @@ -0,0 +1,639 @@ +fn Term write_bytes_go_path(Term *args); +fn Term write_bytes_go_chr(Term *args); +fn Term write_bytes_go_num(Term *args); +fn Term write_bytes_go_data(Term *args); +fn Term write_bytes_go_data_byt(Term *args); +fn Term write_bytes_go_data_num(Term *args); + +// %write_bytes(path, data) +// ------------------------ +// %write_bytes_go_path(λx.x, path, data) +fn Term prim_fn_write_bytes(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[3] = {acc, args[0], args[1]}; + Term t = term_new_pri(table_find("write_bytes_go_path", 19), 3, args0); + return wnf(t); +} + +// %write_bytes_go_path(acc, list, data) +// -------------------------------------- +// Walk list shape with lifting over ERA/INC/SUP. +fn Term write_bytes_go_path(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + Term data = args[2]; + + switch (term_tag(list_wnf)) { + case ERA: { + // %write_bytes_go_path(acc, &{}, data) + // ------------------------------------- write-bytes-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_path(acc, ↑x, data) + // ------------------------------------ write-bytes-go-path-inc + // ↑(%write_bytes(acc(x), data)) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_path(acc, &L{x,y}, data) + // ----------------------------------------- write-bytes-go-path-sup + // &L{%write_bytes(acc0(x), data0), %write_bytes(acc1(y), data1)} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy D = term_clone(lab, data); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %write_bytes_go_path(acc, #Nil, data) + // -------------------------------------- write-bytes-go-path-nil + // %write_bytes_go_data(acc(#Nil), λx.x, data) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term path = term_new_app(acc, nil); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_bytes_go_data", 19), 3, args0); + return wnf(t); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %write_bytes_go_path(acc, #Con{h,t}, data) + // ------------------------------------------- write-bytes-go-path-con + // %write_bytes_go_chr(acc, h, t, data) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[4] = {acc, head, tail, data}; + Term t = term_new_pri(table_find("write_bytes_go_chr", 18), 4, args0); + return wnf(t); + } + // %write_bytes_go_path(acc, x, data) + // ----------------------------------- write-bytes-go-path-fallback + // fallthrough default + } + default: { + // %write_bytes_go_path(acc, x, data) + // ----------------------------------- write-bytes-go-path-default + // %write_bytes_go_data(acc(x), λx.x, data) + Term path = term_new_app(acc, list_wnf); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_bytes_go_data", 19), 3, args0); + return wnf(t); + } + } +} + +// %write_bytes_go_chr(acc, head, tail, data) +// ------------------------------------------- +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term write_bytes_go_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + Term data = args[3]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %write_bytes_go_chr(acc, &{}, t, data) + // --------------------------------------- write-bytes-go-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_chr(acc, ↑x, t, data) + // -------------------------------------- write-bytes-go-chr-inc + // ↑(%write_bytes(acc(#Con{x, t}), data)) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_chr(acc, &L{x,y}, t, data) + // ------------------------------------------- write-bytes-go-chr-sup + // &L{%write_bytes(acc0(#Con{x, t0}), data0), %write_bytes(acc1(#Con{y, t1}), data1)} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Copy D = term_clone(lab, data); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %write_bytes_go_chr(acc, #Chr{c}, t, data) + // ------------------------------------------- write-bytes-go-chr-chr + // %write_bytes_go_num(acc, c, t, data) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[4] = {acc, code, tail, data}; + Term t = term_new_pri(table_find("write_bytes_go_num", 18), 4, args0); + return wnf(t); + } + // %write_bytes_go_chr(acc, h, t, data) + // ------------------------------------- write-bytes-go-chr-fallback + // fallthrough default + } + default: { + // %write_bytes_go_chr(acc, h, t, data) + // ------------------------------------- write-bytes-go-chr-default + // %write_bytes_go_data(acc(#Con{h, t}), λx.x, data) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_bytes_go_data", 19), 3, args0); + return wnf(t); + } + } +} + +// %write_bytes_go_num(acc, code, tail, data) +// ------------------------------------------- +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term write_bytes_go_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + Term data = args[3]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %write_bytes_go_num(acc, &{}, t, data) + // --------------------------------------- write-bytes-go-num-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_num(acc, ↑x, t, data) + // -------------------------------------- write-bytes-go-num-inc + // ↑(%write_bytes(acc(#Con{#Chr{x}, t}), data)) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_num(acc, &L{x,y}, t, data) + // ------------------------------------------- write-bytes-go-num-sup + // &L{%write_bytes(acc0(#Con{#Chr{x}, t0}), data0), %write_bytes(acc1(#Con{#Chr{y}, t1}), data1)} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Copy D = term_clone(lab, data); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %write_bytes_go_num(acc, n, t, data) + // ------------------------------------- write-bytes-go-num-num + // %write_bytes_go_path(λx.acc(#Con{#Chr{n}, x}), t, data) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[3] = {acc_next, tail, data}; + Term t = term_new_pri(table_find("write_bytes_go_path", 19), 3, args0); + return wnf(t); + } + default: { + // %write_bytes_go_num(acc, c, t, data) + // ------------------------------------- write-bytes-go-num-default + // %write_bytes_go_data(acc(#Con{#Chr{c}, t}), λx.x, data) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_bytes_go_data", 19), 3, args0); + return wnf(t); + } + } +} + +// %write_bytes_go_data(path, acc, list) +// ------------------------------------- +// Walk data list shape with lifting over ERA/INC/SUP. +fn Term write_bytes_go_data(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term list_wnf = wnf(args[2]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %write_bytes_go_data(path, acc, &{}) + // ------------------------------------ write-bytes-go-data-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_data(path, acc, ↑x) + // ----------------------------------- write-bytes-go-data-inc + // ↑(%write_bytes(path, acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term data = term_new_app(acc, inner); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_data(path, acc, &L{x,y}) + // ---------------------------------------- write-bytes-go-data-sup + // &L{%write_bytes(path0, acc0(x)), %write_bytes(path1, acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Term data0 = term_new_app(A.k0, x); + Term data1 = term_new_app(A.k1, y); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %write_bytes_go_data(path, acc, #Nil) + // ------------------------------------- write-bytes-go-data-nil + // %write_bytes_go_io(path, acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term data = term_new_app(acc, nil); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_bytes_go_io", 17), 2, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %write_bytes_go_data(path, acc, #Con{h,t}) + // ------------------------------------------ write-bytes-go-data-con + // %write_bytes_go_data_byt(path, acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[4] = {path, acc, head, tail}; + Term t = term_new_pri(table_find("write_bytes_go_data_byt", 23), 4, args0); + return wnf(t); + } + // %write_bytes_go_data(path, acc, x) + // ----------------------------------- write-bytes-go-data-fallback + // fallthrough default + } + default: { + // %write_bytes_go_data(path, acc, x) + // ----------------------------------- write-bytes-go-data-default + // %write_bytes_go_io(path, acc(x)) + Term data = term_new_app(acc, list_wnf); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_bytes_go_io", 17), 2, io_args); + return wnf(io); + } + } +} + +// %write_bytes_go_data_byt(path, acc, head, tail) +// ------------------------------------------------ +// Lift head over ERA/INC/SUP; on concrete #BYT{code}, continue with `code`. +fn Term write_bytes_go_data_byt(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term head_wnf = wnf(args[2]); + Term tail = args[3]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %write_bytes_go_data_byt(path, acc, &{}, t) + // -------------------------------------------- write-bytes-go-data-byt-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_data_byt(path, acc, ↑x, t) + // ------------------------------------------- write-bytes-go-data-byt-inc + // ↑(%write_bytes(path, acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_data_byt(path, acc, &L{x,y}, t) + // ------------------------------------------------ write-bytes-go-data-byt-sup + // &L{%write_bytes(path0, acc0(#Con{x, t0})), %write_bytes(path1, acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term data0 = term_new_app(A.k0, con0); + Term data1 = term_new_app(A.k1, con1); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_BYT) { + // %write_bytes_go_data_byt(path, acc, #BYT{c}, t) + // ------------------------------------------------ write-bytes-go-data-byt-byt + // %write_bytes_go_data_num(path, acc, c, t) + u32 byt_loc = term_val(head_wnf); + Term code = heap_read(byt_loc + 0); + Term args0[4] = {path, acc, code, tail}; + Term t = term_new_pri(table_find("write_bytes_go_data_num", 23), 4, args0); + return wnf(t); + } + // %write_bytes_go_data_byt(path, acc, h, t) + // ------------------------------------------ write-bytes-go-data-byt-fallback + // fallthrough default + } + default: { + // %write_bytes_go_data_byt(path, acc, h, t) + // ------------------------------------------ write-bytes-go-data-byt-default + // %write_bytes_go_io(path, acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_bytes_go_io", 17), 2, io_args); + return wnf(io); + } + } +} + +// %write_bytes_go_data_num(path, acc, code, tail) +// ------------------------------------------------ +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term write_bytes_go_data_num(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term code_wnf = wnf(args[2]); + Term tail = args[3]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %write_bytes_go_data_num(path, acc, &{}, t) + // -------------------------------------------- write-bytes-go-data-num-era + // &{} + return term_new_era(); + } + case INC: { + // %write_bytes_go_data_num(path, acc, ↑x, t) + // ------------------------------------------- write-bytes-go-data-num-inc + // ↑(%write_bytes(path, acc(#Con{#BYT{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term byt = term_new_ctr(SYM_BYT, 1, &inner); + Term con_args[2] = {byt, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_bytes", 11), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_bytes_go_data_num(path, acc, &L{x,y}, t) + // ------------------------------------------------ write-bytes-go-data-num-sup + // &L{%write_bytes(path0, acc0(#Con{#BYT{x}, t0})), %write_bytes(path1, acc1(#Con{#BYT{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term byt0 = term_new_ctr(SYM_BYT, 1, &x); + Term byt1 = term_new_ctr(SYM_BYT, 1, &y); + Term con0_args[2] = {byt0, T.k0}; + Term con1_args[2] = {byt1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term data0 = term_new_app(A.k0, con0); + Term data1 = term_new_app(A.k1, con1); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_bytes", 11), 2, args0); + Term t1 = term_new_pri(table_find("write_bytes", 11), 2, args1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %write_bytes_go_data_num(path, acc, n, t) + // ------------------------------------------ write-bytes-go-data-num-num + // %write_bytes_go_data(path, λx.acc(#Con{#BYT{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term byt = term_new_ctr(SYM_BYT, 1, &code_wnf); + Term con_args[2] = {byt, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[3] = {path, acc_next, tail}; + Term t = term_new_pri(table_find("write_bytes_go_data", 19), 3, args0); + return wnf(t); + } + default: { + // %write_bytes_go_data_num(path, acc, c, t) + // ------------------------------------------ write-bytes-go-data-num-default + // %write_bytes_go_io(path, acc(#Con{#BYT{c}, t})) + Term byt = term_new_ctr(SYM_BYT, 1, &code_wnf); + Term con_args[2] = {byt, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_bytes_go_io", 17), 2, io_args); + return wnf(io); + } + } +} + +// %write_bytes_go_io(path, data) +// ------------------------------ +// #OK{#NIL} | #ERR{String} +fn Term prim_fn_write_bytes_go_io(Term *args) { + int MAX_PATH = 1024; + char path[MAX_PATH]; // UTF-8 bytes + int data_i = 0; + Term data_item = args[1]; + const char *DATA_EXPECTED = "ERROR(write_bytes): invalid `data`; expected #NIL or #CON(#BYT{NUM}, tail)"; + const char *OPEN_PATH_ERR_FMT = "ERROR(write_bytes): failed to open path '%s': %s (errno=%d)"; + const char *DATA_INVALID_BYTE_FMT = "ERROR(write_bytes): invalid byte %llu at `data` index %i; expected 0..255"; + const char *WRITE_IO_ERR_FMT = "ERROR(write_bytes): I/O error while writing '%s': %s (errno=%d)"; + const char *FLUSH_ERR_FMT = "ERROR(write_bytes): failed to flush '%s': %s (errno=%d)"; + const char *CLOSE_ERR_FMT = "ERROR(write_bytes): failed to close '%s': %s (errno=%d)"; + + // Decode HVM path string (#CHR list) into `path` as UTF-8 bytes. + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("write_bytes", "path", MAX_PATH, path_err); + } + + FILE *file = fopen(path, "wb"); + if (!file) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(OPEN_PATH_ERR_FMT, path, strerror(err), err) }); + } + + // Write hvm4 bytes list List<#BYT{NUM}> into file. + data_item = wnf(data_item); + while (term_tag(data_item) == C02) { + // wnf(data_item) must be List<#BYT{b}> + if (term_ext(data_item) != SYM_CON) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + Term head_loc = term_val(data_item); + Term head = heap_read(head_loc + 0); + Term tail = heap_read(head_loc + 1); + head = wnf(head); + + // wnf(head) must be #BYT{b} + if (term_tag(head) != C01 || term_ext(head) != SYM_BYT) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + Term b_loc = term_val(head); + Term b_trm = wnf(heap_read(b_loc)); + + // b in #BYT{b} must be NUM + if (term_tag(b_trm) != NUM) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + // NUM must fit one byte. + u32 b = term_val(b_trm); + if (b > 0xFF) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(DATA_INVALID_BYTE_FMT, (unsigned long long)b, data_i) }); + } + + unsigned char out = (unsigned char)b; + if (fwrite(&out, 1, 1, file) != 1) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(WRITE_IO_ERR_FMT, path, strerror(err), err) }); + } + + data_i += 1; + data_item = wnf(tail); + } + + if (term_tag(data_item) != C00 || term_ext(data_item) != SYM_NIL) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + if (fflush(file) != 0) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(FLUSH_ERR_FMT, path, strerror(err), err) }); + } + + if (fclose(file) != 0) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(CLOSE_ERR_FMT, path, strerror(err), err) }); + } + + Term Nil = term_new_ctr(SYM_NIL, 0, 0); + return term_new_ctr(SYM_OK, 1, &Nil); +} + +fn void prim_write_bytes_init(void) { + prim_register("write_bytes", 11, 2, prim_fn_write_bytes); + prim_register("write_bytes_go_path", 19, 3, write_bytes_go_path); + prim_register("write_bytes_go_chr", 18, 4, write_bytes_go_chr); + prim_register("write_bytes_go_num", 18, 4, write_bytes_go_num); + prim_register("write_bytes_go_data", 19, 3, write_bytes_go_data); + prim_register("write_bytes_go_data_byt", 23, 4, write_bytes_go_data_byt); + prim_register("write_bytes_go_data_num", 23, 4, write_bytes_go_data_num); + prim_register("write_bytes_go_io", 17, 2, prim_fn_write_bytes_go_io); +} diff --git a/clang/prim/fn/write_file.c b/clang/prim/fn/write_file.c new file mode 100644 index 00000000..d064458a --- /dev/null +++ b/clang/prim/fn/write_file.c @@ -0,0 +1,640 @@ +fn Term write_file_go_path(Term *args); +fn Term write_file_go_path_chr(Term *args); +fn Term write_file_go_path_num(Term *args); +fn Term write_file_go_data(Term *args); +fn Term write_file_go_data_chr(Term *args); +fn Term write_file_go_data_num(Term *args); + +// %write_file(path, data) +// ----------------------- +// %write_file_go_path(λx.x, path, data) +fn Term prim_fn_write_file(Term *args) { + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term acc = term_new_lam_at(loc, var); + Term args0[3] = {acc, args[0], args[1]}; + Term t = term_new_pri(table_find("write_file_go_path", 18), 3, args0); + return wnf(t); +} + +// %write_file_go_path(acc, list, data) +// ------------------------------------- +// Walk list shape with lifting over ERA/INC/SUP. +fn Term write_file_go_path(Term *args) { + Term acc = args[0]; + Term list_wnf = wnf(args[1]); + Term data = args[2]; + + switch (term_tag(list_wnf)) { + case ERA: { + // %write_file_go_path(acc, &{}, data) + // ------------------------------------ write-file-go-path-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_path(acc, ↑x, data) + // ----------------------------------- write-file-go-path-inc + // ↑(%write_file(acc(x), data)) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term app = term_new_app(acc, inner); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_path(acc, &L{x,y}, data) + // ---------------------------------------- write-file-go-path-sup + // &L{%write_file(acc0(x), data0), %write_file(acc1(y), data1)} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy D = term_clone(lab, data); + Term app0 = term_new_app(A.k0, x); + Term app1 = term_new_app(A.k1, y); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %write_file_go_path(acc, #Nil, data) + // ------------------------------------- write-file-go-path-nil + // %write_file_go_data(acc(#Nil), λx.x, data) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term path = term_new_app(acc, nil); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_file_go_data", 18), 3, args0); + return wnf(t); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %write_file_go_path(acc, #Con{h,t}, data) + // ------------------------------------------ write-file-go-path-con + // %write_file_go_path_chr(acc, h, t, data) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[4] = {acc, head, tail, data}; + Term t = term_new_pri(table_find("write_file_go_path_chr", 22), 4, args0); + return wnf(t); + } + // %write_file_go_path(acc, x, data) + // ---------------------------------- write-file-go-path-fallback + // fallthrough default + } + default: { + // %write_file_go_path(acc, x, data) + // ---------------------------------- write-file-go-path-default + // %write_file_go_data(acc(x), λx.x, data) + Term path = term_new_app(acc, list_wnf); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_file_go_data", 18), 3, args0); + return wnf(t); + } + } +} + +// %write_file_go_path_chr(acc, head, tail, data) +// ----------------------------------------------- +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term write_file_go_path_chr(Term *args) { + Term acc = args[0]; + Term head_wnf = wnf(args[1]); + Term tail = args[2]; + Term data = args[3]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %write_file_go_path_chr(acc, &{}, t, data) + // ------------------------------------------- write-file-go-path-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_path_chr(acc, ↑x, t, data) + // ------------------------------------------ write-file-go-path-chr-inc + // ↑(%write_file(acc(#Con{x, t}), data)) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_path_chr(acc, &L{x,y}, t, data) + // ----------------------------------------------- write-file-go-path-chr-sup + // &L{%write_file(acc0(#Con{x, t0}), data0), %write_file(acc1(#Con{y, t1}), data1)} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Copy D = term_clone(lab, data); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %write_file_go_path_chr(acc, #Chr{c}, t, data) + // ----------------------------------------------- write-file-go-path-chr-chr + // %write_file_go_path_num(acc, c, t, data) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[4] = {acc, code, tail, data}; + Term t = term_new_pri(table_find("write_file_go_path_num", 22), 4, args0); + return wnf(t); + } + // %write_file_go_path_chr(acc, h, t, data) + // ----------------------------------------- write-file-go-path-chr-fallback + // fallthrough default + } + default: { + // %write_file_go_path_chr(acc, h, t, data) + // ----------------------------------------- write-file-go-path-chr-default + // %write_file_go_data(acc(#Con{h, t}), λx.x, data) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_file_go_data", 18), 3, args0); + return wnf(t); + } + } +} + +// %write_file_go_path_num(acc, code, tail, data) +// ----------------------------------------------- +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term write_file_go_path_num(Term *args) { + Term acc = args[0]; + Term code_wnf = wnf(args[1]); + Term tail = args[2]; + Term data = args[3]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %write_file_go_path_num(acc, &{}, t, data) + // ------------------------------------------- write-file-go-path-num-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_path_num(acc, ↑x, t, data) + // ------------------------------------------ write-file-go-path-num-inc + // ↑(%write_file(acc(#Con{#Chr{x}, t}), data)) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term app = term_new_app(acc, con); + Term next_args[2] = {app, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_path_num(acc, &L{x,y}, t, data) + // ----------------------------------------------- write-file-go-path-num-sup + // &L{%write_file(acc0(#Con{#Chr{x}, t0}), data0), %write_file(acc1(#Con{#Chr{y}, t1}), data1)} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Copy D = term_clone(lab, data); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term app0 = term_new_app(A.k0, con0); + Term app1 = term_new_app(A.k1, con1); + Term args0[2] = {app0, D.k0}; + Term args1[2] = {app1, D.k1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %write_file_go_path_num(acc, n, t, data) + // ----------------------------------------- write-file-go-path-num-num + // %write_file_go_path(λx.acc(#Con{#Chr{n}, x}), t, data) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[3] = {acc_next, tail, data}; + Term t = term_new_pri(table_find("write_file_go_path", 18), 3, args0); + return wnf(t); + } + default: { + // %write_file_go_path_num(acc, c, t, data) + // ----------------------------------------- write-file-go-path-num-default + // %write_file_go_data(acc(#Con{#Chr{c}, t}), λx.x, data) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term path = term_new_app(acc, con); + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term data_acc = term_new_lam_at(loc, var); + Term args0[3] = {path, data_acc, data}; + Term t = term_new_pri(table_find("write_file_go_data", 18), 3, args0); + return wnf(t); + } + } +} + +// %write_file_go_data(path, acc, list) +// ------------------------------------ +// Walk data list shape with lifting over ERA/INC/SUP. +fn Term write_file_go_data(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term list_wnf = wnf(args[2]); + + switch (term_tag(list_wnf)) { + case ERA: { + // %write_file_go_data(path, acc, &{}) + // ----------------------------------- write-file-go-data-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_data(path, acc, ↑x) + // ---------------------------------- write-file-go-data-inc + // ↑(%write_file(path, acc(x))) + u32 inc_loc = term_val(list_wnf); + Term inner = heap_read(inc_loc); + Term data = term_new_app(acc, inner); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_data(path, acc, &L{x,y}) + // --------------------------------------- write-file-go-data-sup + // &L{%write_file(path0, acc0(x)), %write_file(path1, acc1(y))} + u32 lab = term_ext(list_wnf); + u32 sup_loc = term_val(list_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Term data0 = term_new_app(A.k0, x); + Term data1 = term_new_app(A.k1, y); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(list_wnf) == C00 && term_ext(list_wnf) == SYM_NIL) { + // %write_file_go_data(path, acc, #Nil) + // ------------------------------------ write-file-go-data-nil + // %write_file_go_io(path, acc(#Nil)) + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term data = term_new_app(acc, nil); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_file_go_io", 16), 2, io_args); + return wnf(io); + } + if (term_tag(list_wnf) == C02 && term_ext(list_wnf) == SYM_CON) { + // %write_file_go_data(path, acc, #Con{h,t}) + // ----------------------------------------- write-file-go-data-con + // %write_file_go_data_chr(path, acc, h, t) + u32 con_loc = term_val(list_wnf); + Term head = heap_read(con_loc + 0); + Term tail = heap_read(con_loc + 1); + Term args0[4] = {path, acc, head, tail}; + Term t = term_new_pri(table_find("write_file_go_data_chr", 22), 4, args0); + return wnf(t); + } + // %write_file_go_data(path, acc, x) + // ---------------------------------- write-file-go-data-fallback + // fallthrough default + } + default: { + // %write_file_go_data(path, acc, x) + // ---------------------------------- write-file-go-data-default + // %write_file_go_io(path, acc(x)) + Term data = term_new_app(acc, list_wnf); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_file_go_io", 16), 2, io_args); + return wnf(io); + } + } +} + +// %write_file_go_data_chr(path, acc, head, tail) +// ----------------------------------------------- +// Lift head over ERA/INC/SUP; on concrete #CHR{code}, continue with `code`. +fn Term write_file_go_data_chr(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term head_wnf = wnf(args[2]); + Term tail = args[3]; + + switch (term_tag(head_wnf)) { + case ERA: { + // %write_file_go_data_chr(path, acc, &{}, t) + // ------------------------------------------- write-file-go-data-chr-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_data_chr(path, acc, ↑x, t) + // ------------------------------------------ write-file-go-data-chr-inc + // ↑(%write_file(path, acc(#Con{x, t}))) + u32 inc_loc = term_val(head_wnf); + Term inner = heap_read(inc_loc); + Term con_args[2] = {inner, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_data_chr(path, acc, &L{x,y}, t) + // ----------------------------------------------- write-file-go-data-chr-sup + // &L{%write_file(path0, acc0(#Con{x, t0})), %write_file(path1, acc1(#Con{y, t1}))} + u32 lab = term_ext(head_wnf); + u32 sup_loc = term_val(head_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term con0_args[2] = {x, T.k0}; + Term con1_args[2] = {y, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term data0 = term_new_app(A.k0, con0); + Term data1 = term_new_app(A.k1, con1); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case C00 ... C16: { + if (term_tag(head_wnf) == C01 && term_ext(head_wnf) == SYM_CHR) { + // %write_file_go_data_chr(path, acc, #Chr{c}, t) + // ----------------------------------------------- write-file-go-data-chr-chr + // %write_file_go_data_num(path, acc, c, t) + u32 chr_loc = term_val(head_wnf); + Term code = heap_read(chr_loc + 0); + Term args0[4] = {path, acc, code, tail}; + Term t = term_new_pri(table_find("write_file_go_data_num", 22), 4, args0); + return wnf(t); + } + // %write_file_go_data_chr(path, acc, h, t) + // ----------------------------------------- write-file-go-data-chr-fallback + // fallthrough default + } + default: { + // %write_file_go_data_chr(path, acc, h, t) + // ----------------------------------------- write-file-go-data-chr-default + // %write_file_go_io(path, acc(#Con{h, t})) + Term con_args[2] = {head_wnf, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_file_go_io", 16), 2, io_args); + return wnf(io); + } + } +} + +// %write_file_go_data_num(path, acc, code, tail) +// ----------------------------------------------- +// Lift code over ERA/INC/SUP; on concrete NUM, extend accumulator and continue. +fn Term write_file_go_data_num(Term *args) { + Term path = args[0]; + Term acc = args[1]; + Term code_wnf = wnf(args[2]); + Term tail = args[3]; + + switch (term_tag(code_wnf)) { + case ERA: { + // %write_file_go_data_num(path, acc, &{}, t) + // ------------------------------------------- write-file-go-data-num-era + // &{} + return term_new_era(); + } + case INC: { + // %write_file_go_data_num(path, acc, ↑x, t) + // ------------------------------------------ write-file-go-data-num-inc + // ↑(%write_file(path, acc(#Con{#Chr{x}, t}))) + u32 inc_loc = term_val(code_wnf); + Term inner = heap_read(inc_loc); + Term chr = term_new_ctr(SYM_CHR, 1, &inner); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term next_args[2] = {path, data}; + Term next = term_new_pri(table_find("write_file", 10), 2, next_args); + heap_set(inc_loc, next); + return term_new(0, INC, 0, inc_loc); + } + case SUP: { + // %write_file_go_data_num(path, acc, &L{x,y}, t) + // ----------------------------------------------- write-file-go-data-num-sup + // &L{%write_file(path0, acc0(#Con{#Chr{x}, t0})), %write_file(path1, acc1(#Con{#Chr{y}, t1}))} + u32 lab = term_ext(code_wnf); + u32 sup_loc = term_val(code_wnf); + Term x = heap_read(sup_loc + 0); + Term y = heap_read(sup_loc + 1); + Copy P = term_clone(lab, path); + Copy A = term_clone(lab, acc); + Copy T = term_clone(lab, tail); + Term chr0 = term_new_ctr(SYM_CHR, 1, &x); + Term chr1 = term_new_ctr(SYM_CHR, 1, &y); + Term con0_args[2] = {chr0, T.k0}; + Term con1_args[2] = {chr1, T.k1}; + Term con0 = term_new_ctr(SYM_CON, 2, con0_args); + Term con1 = term_new_ctr(SYM_CON, 2, con1_args); + Term data0 = term_new_app(A.k0, con0); + Term data1 = term_new_app(A.k1, con1); + Term args0[2] = {P.k0, data0}; + Term args1[2] = {P.k1, data1}; + Term t0 = term_new_pri(table_find("write_file", 10), 2, args0); + Term t1 = term_new_pri(table_find("write_file", 10), 2, args1); + return term_new_sup(lab, t0, t1); + } + case NUM: { + // %write_file_go_data_num(path, acc, n, t) + // ----------------------------------------- write-file-go-data-num-num + // %write_file_go_data(path, λx.acc(#Con{#Chr{n}, x}), t) + u64 loc = heap_alloc(1); + Term var = term_new_var(loc); + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, var}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term bod = term_new_app(acc, con); + Term acc_next = term_new_lam_at(loc, bod); + Term args0[3] = {path, acc_next, tail}; + Term t = term_new_pri(table_find("write_file_go_data", 18), 3, args0); + return wnf(t); + } + default: { + // %write_file_go_data_num(path, acc, c, t) + // ----------------------------------------- write-file-go-data-num-default + // %write_file_go_io(path, acc(#Con{#Chr{c}, t})) + Term chr = term_new_ctr(SYM_CHR, 1, &code_wnf); + Term con_args[2] = {chr, tail}; + Term con = term_new_ctr(SYM_CON, 2, con_args); + Term data = term_new_app(acc, con); + Term io_args[2] = {path, data}; + Term io = term_new_pri(table_find("write_file_go_io", 16), 2, io_args); + return wnf(io); + } + } +} + +// %write_file_go_io(path, data) +// ----------------------------- +// #OK{#NIL} | #ERR{String} +fn Term prim_fn_write_file_go_io(Term *args) { + int MAX_PATH = 1024; + char path[MAX_PATH]; // UTF-8 bytes + int data_i = 0; + Term data_item = args[1]; + const char *DATA_EXPECTED = "ERROR(write_file): invalid `data`; expected #NIL or #CON(#CHR{NUM}, tail)"; + const char *OPEN_PATH_ERR_FMT = "ERROR(write_file): failed to open path '%s': %s (errno=%d)"; + const char *DATA_INVALID_CP_FMT = "ERROR(write_file): invalid UTF-32 codepoint U+%08llX at `data` index %i"; + const char *WRITE_IO_ERR_FMT = "ERROR(write_file): I/O error while writing '%s': %s (errno=%d)"; + const char *FLUSH_ERR_FMT = "ERROR(write_file): failed to flush '%s': %s (errno=%d)"; + const char *CLOSE_ERR_FMT = "ERROR(write_file): failed to close '%s': %s (errno=%d)"; + + // Decode HVM path string (#CHR list) into `path` as UTF-8 bytes. + HStrErr path_err; + if (!term_string_to_utf8_cstr(args[0], path, MAX_PATH, NULL, &path_err)) { + return term_string_from_hstrerr("write_file", "path", MAX_PATH, path_err); + } + + FILE *file = fopen(path, "wb"); + if (!file) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(OPEN_PATH_ERR_FMT, path, strerror(err), err) }); + } + + // Write hvm4 string List<#CHR{NUM}> into file as UTF-8 bytes. + data_item = wnf(data_item); + while (term_tag(data_item) == C02) { + // wnf(data_item) must be List<#CHR{c}> + if (term_ext(data_item) != SYM_CON) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + Term head_loc = term_val(data_item); + Term head = heap_read(head_loc + 0); + Term tail = heap_read(head_loc + 1); + head = wnf(head); + + // wnf(head) must be #CHR{c} + if (term_tag(head) != C01 || term_ext(head) != SYM_CHR) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + Term c_loc = term_val(head); + Term c_trm = wnf(heap_read(c_loc)); + + // c in #CHR{c} must be NUM + if (term_tag(c_trm) != NUM) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + // Encode UTF-32 codepoint (NUM) into UTF-8 bytes. + u32 cp = term_val(c_trm); + char cp_utf8[4]; + int n_bytes = utf8_encode_scalar(cp, cp_utf8); + if (n_bytes < 0) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(DATA_INVALID_CP_FMT, (unsigned long long)cp, data_i) }); + } + + if (fwrite(cp_utf8, 1, (size_t)n_bytes, file) != (size_t)n_bytes) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(WRITE_IO_ERR_FMT, path, strerror(err), err) }); + } + + data_i += 1; + data_item = wnf(tail); + } + + if (term_tag(data_item) != C00 || term_ext(data_item) != SYM_NIL) { + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf("%s", DATA_EXPECTED) }); + } + + if (fflush(file) != 0) { + // Capture errno before fclose because fclose may overwrite it. + int err = errno; + fclose(file); + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(FLUSH_ERR_FMT, path, strerror(err), err) }); + } + + if (fclose(file) != 0) { + int err = errno; + return term_new_ctr(SYM_ERR, 1, (Term[]){ term_string_printf(CLOSE_ERR_FMT, path, strerror(err), err) }); + } + + Term Nil = term_new_ctr(SYM_NIL, 0, 0); + return term_new_ctr(SYM_OK, 1, &Nil); +} + +fn void prim_write_file_init(void) { + prim_register("write_file", 10, 2, prim_fn_write_file); + prim_register("write_file_go_path", 18, 3, write_file_go_path); + prim_register("write_file_go_path_chr", 22, 4, write_file_go_path_chr); + prim_register("write_file_go_path_num", 22, 4, write_file_go_path_num); + prim_register("write_file_go_data", 18, 3, write_file_go_data); + prim_register("write_file_go_data_chr", 22, 4, write_file_go_data_chr); + prim_register("write_file_go_data_num", 22, 4, write_file_go_data_num); + prim_register("write_file_go_io", 16, 2, prim_fn_write_file_go_io); +} diff --git a/clang/prim/init.c b/clang/prim/init.c index f5d1348d..7c6eafbe 100644 --- a/clang/prim/init.c +++ b/clang/prim/init.c @@ -1,3 +1,20 @@ fn void prim_init(void) { prim_log_init(); + prim_panic_init(); + prim_argv_init(); + prim_rand_init(); + prim_uuid_init(); + prim_uid_init(); + prim_process_init(); + prim_stream_init(); + prim_timer_init(); + prim_http_init(); + prim_tcp_init(); + prim_env_init(); + prim_cwd_init(); + prim_chdir_init(); + prim_read_bytes_init(); + prim_write_bytes_init(); + prim_read_file_init(); + prim_write_file_init(); } diff --git a/clang/prim/string.c b/clang/prim/string.c new file mode 100644 index 00000000..95864a16 --- /dev/null +++ b/clang/prim/string.c @@ -0,0 +1,437 @@ +#include +#include +#include + +fn Term wnf(Term term); + +// Type helpers +typedef enum HStrErrKind HStrErrKind; +typedef struct HStrErr HStrErr; + +// UTF-8 helpers +fn int utf8_encode_scalar(u32 cp, char out[4]); +fn int utf8_decode_next_bytes(const u8 *s, u32 len, u32 *idx, u32 *cp); +fn int utf8_decode_next_cstr(const char *s, u32 *idx, u32 *cp); + +// Term <-> c string, conversion helpers +fn int term_chr_from_scalar(u32 cp, Term *out); +fn Term term_string_from_utf8(const char *s); +fn Term term_string_vprintf(const char *fmt, va_list ap); +fn Term term_string_printf(const char *fmt, ...); +fn int term_string_to_utf8_cstr(Term src, char *dst, int cap, int *out_len, HStrErr *err); +fn Term term_string_from_hstrerr(const char *prim, const char *arg, int cap, HStrErr err); + +// Local utility +fn void hstr_set(HStrErr *err, HStrErrKind kind, int index, int bytes, u64 cp); +fn int utf8_seq_expected_len(u8 b0); +fn int utf8_decode_seq(const u8 *p, int n, u32 *cp); + +enum HStrErrKind { + HSTR_OK = 0, + HSTR_BAD_SHAPE, // Not #NIL / #CON(#CHR{NUM}, tail) + HSTR_BAD_CP, // Invalid UTF-32 scalar value in #CHR{NUM} + HSTR_TOO_LONG, // Destination C buffer cannot fit UTF-8 + trailing '\0' +}; + +struct HStrErr { + HStrErrKind kind; + int index; // Codepoint index in the source HVM list. + int bytes; // Current/required UTF-8 bytes in destination buffer. + u64 cp; // Offending codepoint for HSTR_BAD_CP. +}; + + +// Small helper to fill an error struct only when caller asked for diagnostics. +fn void hstr_set(HStrErr *err, HStrErrKind kind, int index, int bytes, u64 cp) { + if (err == NULL) { + return; + } + err->kind = kind; + err->index = index; + err->bytes = bytes; + err->cp = cp; +} + +// Encode one UTF-32 codepoint into UTF-8 bytes. +// Returns 1..4 on success, -1 on invalid scalar value. +fn int utf8_encode_scalar(u32 cp, char out[4]) { + if (cp <= 0x7F) { + out[0] = (char)cp; + return 1; + } + + if (cp <= 0x7FF) { + out[0] = (char)(0xC0 | (cp >> 6)); + out[1] = (char)(0x80 | (cp & 0x3F)); + return 2; + } + + if (cp >= 0xD800 && cp <= 0xDFFF) { + return -1; + } + + if (cp <= 0xFFFF) { + out[0] = (char)(0xE0 | (cp >> 12)); + out[1] = (char)(0x80 | ((cp >> 6) & 0x3F)); + out[2] = (char)(0x80 | (cp & 0x3F)); + return 3; + } + + if (cp <= 0x10FFFF) { + out[0] = (char)(0xF0 | (cp >> 18)); + out[1] = (char)(0x80 | ((cp >> 12) & 0x3F)); + out[2] = (char)(0x80 | ((cp >> 6) & 0x3F)); + out[3] = (char)(0x80 | (cp & 0x3F)); + return 4; + } + + return -1; +} + +// Get UTF-8 sequence length from the first byte. +// Returns 1..4 on valid leading byte, -1 otherwise. +fn int utf8_seq_expected_len(u8 b0) { + if (b0 < 0x80) { + return 1; + } + if ((b0 & 0xE0) == 0xC0) { + return 2; + } + if ((b0 & 0xF0) == 0xE0) { + return 3; + } + if ((b0 & 0xF8) == 0xF0) { + return 4; + } + return -1; +} + +// Decode exactly one UTF-8 sequence from `p[0..n-1]`. +// Returns 1 on success, 0 on invalid encoding. +fn int utf8_decode_seq(const u8 *p, int n, u32 *cp) { + u8 b0 = p[0]; + + if (n == 1) { + *cp = b0; + return 1; + } + + if (n == 2) { + u8 b1 = p[1]; + if ((b1 & 0xC0) != 0x80) { + return 0; + } + u32 x = ((u32)(b0 & 0x1F) << 6) | (u32)(b1 & 0x3F); + if (x < 0x80) { + return 0; + } + *cp = x; + return 1; + } + + if (n == 3) { + u8 b1 = p[1]; + u8 b2 = p[2]; + if ((b1 & 0xC0) != 0x80 || (b2 & 0xC0) != 0x80) { + return 0; + } + u32 x = ((u32)(b0 & 0x0F) << 12) + | ((u32)(b1 & 0x3F) << 6) + | ((u32)(b2 & 0x3F)); + if (x < 0x800 || (x >= 0xD800 && x <= 0xDFFF)) { + return 0; + } + *cp = x; + return 1; + } + + if (n == 4) { + u8 b1 = p[1]; + u8 b2 = p[2]; + u8 b3 = p[3]; + if ((b1 & 0xC0) != 0x80 || (b2 & 0xC0) != 0x80 || (b3 & 0xC0) != 0x80) { + return 0; + } + u32 x = ((u32)(b0 & 0x07) << 18) + | ((u32)(b1 & 0x3F) << 12) + | ((u32)(b2 & 0x3F) << 6) + | ((u32)(b3 & 0x3F)); + if (x < 0x10000 || x > 0x10FFFF) { + return 0; + } + *cp = x; + return 1; + } + + return 0; +} + +// Decode one UTF-8 codepoint from a byte slice `s[0..len-1]` at byte index `*idx`. +// Returns: 0=end of slice, 1..4=bytes consumed, -1=invalid sequence, -2=truncated sequence. +fn int utf8_decode_next_bytes(const u8 *s, u32 len, u32 *idx, u32 *cp) { + if (*idx >= len) { + return 0; + } + + u32 i = *idx; + int n = utf8_seq_expected_len(s[i]); + if (n < 0) { + return -1; + } + if (i + (u32)n > len) { + return -2; + } + if (!utf8_decode_seq(s + i, n, cp)) { + return -1; + } + + *idx = i + (u32)n; + return n; +} + +// Decode one UTF-8 codepoint from a NUL-terminated C string at byte index `*idx`. +// Returns: 0=end of string, 1..4=bytes consumed, -1=invalid/truncated sequence. +fn int utf8_decode_next_cstr(const char *s, u32 *idx, u32 *cp) { + const u8 *p = (const u8 *)s + *idx; + if (p[0] == 0) { + return 0; + } + + int n = utf8_seq_expected_len(p[0]); + if (n < 0) { + return -1; + } + for (int j = 1; j < n; ++j) { + if (p[j] == 0) { + return -1; + } + } + if (!utf8_decode_seq(p, n, cp)) { + return -1; + } + + *idx = *idx + (u32)n; + return n; +} + +// Build #CHR{NUM} from a UTF-32 scalar. +// Returns 1 on success, 0 if scalar is invalid. +fn int term_chr_from_scalar(u32 cp, Term *out) { + if (cp > 0x10FFFF) { + return 0; + } + + if (cp >= 0xD800 && cp <= 0xDFFF) { + return 0; + } + + Term num = term_new_num(cp); + *out = term_new_ctr(SYM_CHR, 1, &num); + return 1; +} + +// NOTE: Assumes `s` is a NUL-terminated UTF-8 C string. +fn Term term_string_from_utf8(const char *s) { + Term nil = term_new_ctr(SYM_NIL, 0, 0); + Term out = nil; + Term cur = nil; + u32 idx = 0; + u8 has_node = 0; + + while (1) { + u32 cp = 0; + int n = utf8_decode_next_cstr(s, &idx, &cp); + if (n == 0) { + break; + } + if (n < 0) { + // Replace one invalid byte with U+FFFD and move forward. + cp = 0xFFFD; + idx = idx + 1; + } + + Term chr; + if (!term_chr_from_scalar(cp, &chr)) { + Term repl; + term_chr_from_scalar(0xFFFD, &repl); + chr = repl; + } + + Term args[2] = {chr, nil}; + Term node = term_new_ctr(SYM_CON, 2, args); + + if (!has_node) { + out = node; + has_node = 1; + } else { + heap_set(term_val(cur) + 1, node); + } + cur = node; + } + + return out; +} + +// Format with libc and convert the resulting UTF-8 C string to HVM String. +// On failure, returns sentinel strings like "" or "". +fn Term term_string_vprintf(const char *fmt, va_list ap) { + // First pass asks libc for the exact byte count (without NUL). + va_list ap_len; + va_copy(ap_len, ap); + int need = vsnprintf(NULL, 0, fmt, ap_len); + va_end(ap_len); + + if (need < 0) { + return term_string_from_utf8(""); + } + + size_t cap = (size_t)need + 1; + char *buf = malloc(cap); + if (buf == NULL) { + return term_string_from_utf8(""); + } + + // Second pass emits the formatted UTF-8 bytes, then we decode to HVM #CHR list. + va_list ap_fmt; + va_copy(ap_fmt, ap); + int got = vsnprintf(buf, cap, fmt, ap_fmt); + va_end(ap_fmt); + + if (got < 0 || (size_t)got >= cap) { + free(buf); + return term_string_from_utf8(""); + } + + Term out = term_string_from_utf8(buf); + free(buf); + return out; +} + +// Variadic wrapper over `term_string_vprintf`. +fn Term term_string_printf(const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + Term out = term_string_vprintf(fmt, ap); + va_end(ap); + return out; +} + +// Decode an HVM String into a NUL-terminated UTF-8 C string. +// +// src: #NIL or #CON(#CHR{NUM}, tail). +// dst: ptr to destinatation c string +// cap: max size of `dst` includes space for the trailing '\0'. +// out_len: final size of dst +// err: ptr to HStrErr to keep error information +// +// Returns 1 on success. +// Returns 0 on failure and fills `err` when provided. +// On failure, `dst` may be partially written. +fn int term_string_to_utf8_cstr(Term src, char *dst, int cap, int *out_len, HStrErr *err) { + // Walk the HVM list, validate each node, encode codepoints to UTF-8, append to `dst`. + int len = 0; // UTF-8 bytes already written to dst (without trailing '\0') + int i = 0; // Codepoint index in the HVM string, for error printing + Term cur = wnf(src); // Current list node while traversing `src` + + if (dst == NULL || cap <= 0) { + hstr_set(err, HSTR_TOO_LONG, 0, 0, 0); + return 0; + } + + while (term_tag(cur) == C02 && len < cap) { + // wnf(cur) must be List<#CHR{c}> + if (term_ext(cur) != SYM_CON) { + hstr_set(err, HSTR_BAD_SHAPE, i, len, 0); + return 0; + } + + Term loc = term_val(cur); + Term head = wnf(heap_read(loc + 0)); + Term tail = heap_read(loc + 1); + + // wnf(head) must be #CHR{c} + if (term_tag(head) != C01 || term_ext(head) != SYM_CHR) { + hstr_set(err, HSTR_BAD_SHAPE, i, len, 0); + return 0; + } + + // c must be NUM + Term c = wnf(heap_read(term_val(head))); + if (term_tag(c) != NUM) { + hstr_set(err, HSTR_BAD_SHAPE, i, len, 0); + return 0; + } + + u32 cp = term_val(c); // UTF-32 scalar stored in #CHR{NUM} + char cp_utf8[4]; + int n = utf8_encode_scalar(cp, cp_utf8); + if (n < 0) { + hstr_set(err, HSTR_BAD_CP, i, len, cp); + return 0; + } + if (len + n >= cap) { + hstr_set(err, HSTR_TOO_LONG, i, len + n, cp); + return 0; + } + memcpy(dst + len, cp_utf8, n); + len += n; + i += 1; + + cur = wnf(tail); + } + + if (len >= cap) { + hstr_set(err, HSTR_TOO_LONG, i, len, 0); + return 0; + } + if (term_tag(cur) != C00 || term_ext(cur) != SYM_NIL) { + hstr_set(err, HSTR_BAD_SHAPE, i, len, 0); + return 0; + } + + dst[len] = '\0'; + if (out_len != NULL) { + *out_len = len; + } + hstr_set(err, HSTR_OK, i, len, 0); + return 1; +} + +// Convert a decoding error into #ERR{String}. +// Prefix is "ERROR(): " when `prim` is non-empty, else "ERROR: ". +fn Term term_string_from_hstrerr(const char *prim, const char *arg, int cap, HStrErr err) { + int has_prim = prim != NULL && prim[0] != '\0'; // Whether to include primitive function name in prefix + if (arg == NULL || arg[0] == '\0') { + arg = "arg"; + } + + char prefix[256]; // Shared prefix reused by all error message variants + if (has_prim) { + // If prefix formatting fails/overflows, fall back to generic prefix. + int n = snprintf(prefix, sizeof(prefix), "ERROR(%s): ", prim); + if (n < 0 || n >= (int)sizeof(prefix)) { + snprintf(prefix, sizeof(prefix), "ERROR: "); + } + } else { + snprintf(prefix, sizeof(prefix), "ERROR: "); + } + + Term msg; // Message payload for #ERR + switch (err.kind) { + case HSTR_BAD_SHAPE: + msg = term_string_printf("%sinvalid `%s`; expected #NIL or #CON(#CHR{NUM}, tail)", prefix, arg); + break; + case HSTR_BAD_CP: + msg = term_string_printf("%sinvalid UTF-32 codepoint U+%08llX at `%s` index %i", + prefix, (unsigned long long)err.cp, arg, err.index); + break; + case HSTR_TOO_LONG: + msg = term_string_printf("%s`%s` too long at index %i: %i UTF-8 bytes (max %i incl. NUL)", + prefix, arg, err.index, err.bytes, cap); + break; + default: + msg = term_string_printf("%sinvalid `%s`", prefix, arg); + break; + } + return term_new_ctr(SYM_ERR, 1, &msg); +} diff --git a/docs/hvm/core.md b/docs/hvm/core.md index ee877b19..cc99c311 100644 --- a/docs/hvm/core.md +++ b/docs/hvm/core.md @@ -52,3 +52,22 @@ Oper ::= "+" | "-" | "*" | "/" | "%" | "&&" | "||" correct arity; `%log` prints a string and yields `#Nil`. - Surface sugar accepts `λ$x. body` as an unscoped lambda, equivalent to `! f = λ x ; f(body)` with fresh `f` (see `docs/hvm/syntax.md`). + correct arity; `%log` prints a string and yields `#Nil`; process primitives + (`%process_spawn`, `%process_poll`, `%process_wait`, `%process_kill`) use + `#Proc`, `#Pend`, `#Rdy`, `#Exit`, and `#Sig` under `#OK{...}`, or `#ERR{String}`; + timer primitives (`%timer_start`, `%timer_poll`, `%timer_wait`) use `#Time`, + `#Pend`, and `#Rdy` under `#OK{...}`, or `#ERR{String}`; stream primitives + (`%stream_stdin_open`, `%stream_file_open`, `%stream_poll`, `%stream_wait`, + `%stream_close`) use `#Strm`, `#Pend`, `#Rdy`, `#BYT`, and `#Eof` under + `#OK{...}`, or `#ERR{String}` (`%stream_close` returns `#OK{#Nil}`); http + primitives (`%http_request`, `%http_poll`, `%http_wait`, `%http_cancel`) use + `#Http`, `#Pend`, and `#Rdy` under `#OK{...}`, where `%http_request` expects + `#Req{method,url,headers,body,opts}` and outcomes are + `#Resp{status,headers,body}`, `#Fail{reason,msg}`, or `#Canceled` + (all under `#OK{...}`), or `#ERR{String}`; tcp primitives (`%tcp_connect`, + `%tcp_connect_poll`, `%tcp_connect_wait`, `%tcp_recv_poll`, `%tcp_recv_wait`, + `%tcp_send_poll`, `%tcp_send_wait`, `%tcp_close`) use `#Tcp`, `#Pend`, and + `#Rdy` under `#OK{...}`; `%tcp_connect` expects + `#TcpReq{host,port,#TcpOpts{connect_timeout_ms,read_timeout_ms,write_timeout_ms,nodelay,keepalive}}` + and outcomes are `#Conn`, `#Recv`, `#Sent`, `#Eof`, `#Closed`, or + `#Fail{reason,msg}` with reason in `#Timeout|#Dns|#Refused|#Unreachable|#Reset|#BrokenPipe|#Protocol|#NotConnected|#Sys{errno}`. diff --git a/docs/hvm/syntax.md b/docs/hvm/syntax.md index 7a31949f..ced1b35c 100644 --- a/docs/hvm/syntax.md +++ b/docs/hvm/syntax.md @@ -231,6 +231,41 @@ can be written as `_ : d` or as a bare `d`. ### Primitives - `%log` prints a string (list of `#Chr`) to stdout and returns `#Nil`. +- `%process_spawn(cmd)` returns `#OK{#Proc{id,seq}}` or `#ERR{String}`. +- `%process_poll(proc)` returns `#OK{#Pend{proc2}|#Rdy{proc2,#Exit{n}|#Sig{n}}}` or `#ERR{String}`. +- `%process_wait(proc)` returns `#OK{#Rdy{proc2,#Exit{n}|#Sig{n}}}` or `#ERR{String}`. +- `%process_kill(proc)` returns `#OK{#Pend{proc2}|#Rdy{...}}` or `#ERR{String}`. +- `%stream_stdin_open(seed)` returns `#OK{#Strm{id,0}}` or `#ERR{String}`. +- `%stream_file_open(path)` returns `#OK{#Strm{id,0}}` or `#ERR{String}`. +- `%stream_poll(strm)` returns `#OK{#Pend{strm2}|#Rdy{strm2,#BYT{n}|#Eof}}` or `#ERR{String}`. +- `%stream_wait(strm)` returns `#OK{#Rdy{strm2,#BYT{n}|#Eof}}` or `#ERR{String}`. +- `%stream_close(strm)` returns `#OK{#Nil}` or `#ERR{String}`. +- `%timer_start(ms)` returns `#OK{#Time{id,seq}}` or `#ERR{String}`. +- `%timer_poll(time)` returns `#OK{#Pend{time2}|#Rdy{time2}}` or `#ERR{String}`. +- `%timer_wait(time)` returns `#OK{#Rdy{time2}}` or `#ERR{String}`. +- `%http_request(req)` returns `#OK{#Http{id,seq}}` or `#ERR{String}`. +- `req` must be `#Req{method,url,headers,body,opts}`: + - `method`: `#Get|#Post|#Put|#Patch|#Delete|#Head|#Options` + - `headers`: `List<#Hdr{name,value}>` + - `body`: `#NoBody|#BodyText{String}|#BodyBytes{List<#BYT{n}>}` + - `opts`: `#Opts{timeout_ms,connect_timeout_ms,follow_redirects,max_redirects,verify_tls,max_body_bytes}` +- `%http_poll(http)` returns `#OK{#Pend{http2}|#Rdy{http2,#Resp{status,headers,body}|#Fail{reason,msg}|#Canceled}}` or `#ERR{String}`. +- `%http_wait(http)` returns `#OK{#Rdy{http2,#Resp{status,headers,body}|#Fail{reason,msg}|#Canceled}}` or `#ERR{String}`. +- `%http_cancel(http)` returns `#OK{#Pend{http2}|#Rdy{http2,#Resp{status,headers,body}|#Fail{reason,msg}|#Canceled}}` or `#ERR{String}`. +- `%tcp_connect(req)` returns `#OK{#Tcp{id,seq}}` or `#ERR{String}`. +- `req` must be `#TcpReq{host,port,opts}`: + - `host`: `String` + - `port`: `NUM` in `[1,65535]` + - `opts`: `#TcpOpts{connect_timeout_ms,read_timeout_ms,write_timeout_ms,nodelay,keepalive}` +- `%tcp_connect_poll(tcp)` returns `#OK{#Pend{tcp2}|#Rdy{tcp2,#Conn{}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_connect_wait(tcp)` returns `#OK{#Rdy{tcp2,#Conn{}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_recv_poll(tcp,max_bytes)` returns `#OK{#Pend{tcp2}|#Rdy{tcp2,#Recv{bytes}|#Eof{}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_recv_wait(tcp,max_bytes)` returns `#OK{#Rdy{tcp2,#Recv{bytes}|#Eof{}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_send_poll(tcp,bytes)` returns `#OK{#Pend{tcp2}|#Rdy{tcp2,#Sent{n}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_send_wait(tcp,bytes)` returns `#OK{#Rdy{tcp2,#Sent{n}|#Fail{reason,msg}}}` or `#ERR{String}`. +- `%tcp_close(tcp)` returns `#OK{#Rdy{tcp2,#Closed{}|#Fail{reason,msg}}}` or `#ERR{String}`. +- TCP fail reasons are `#Timeout`, `#Dns`, `#Refused`, `#Unreachable`, + `#Reset`, `#BrokenPipe`, `#Protocol`, `#NotConnected`, or `#Sys{errno}`. ## Priority wrapper and wildcard diff --git a/examples/http_get_basic.hvm4 b/examples/http_get_basic.hvm4 new file mode 100644 index 00000000..e63cca3e --- /dev/null +++ b/examples/http_get_basic.hvm4 @@ -0,0 +1,37 @@ +#include "../stdlib/all.hvm4" + +// Performs GET on example.com and returns #P{status, decoded_body}. +// Requires outbound network access. + +@resp_to_status_body = λev. + λ{ + #Resp: λstatus. λheaders. λbody.@pure(#P{status, body}); + #HttpFail: λreason. λmsg.#ERR{msg}; + #Canceled: #ERR{"http request canceled"}; + &{} + }(ev) + +@decode_status_text = λsb1. + !&sb = sb1; + ! st = @fst(sb); + ! bs = @snd(sb); + ! f0 = λ txt ; + @do( + [ + f0, @bytes_to_string(bs) + ], + #P{st, txt} + ) + +@main = + ! f0 = λ ev0 ; + ! f1 = λ sb1 ; + ! f2 = λ out2 ; + @do( + [ + f0, @http_get("https://example.com"), + f1, @resp_to_status_body(ev0), + f2, @decode_status_text(sb1) + ], + out2 + ) diff --git a/examples/process_run_exit.hvm4 b/examples/process_run_exit.hvm4 new file mode 100644 index 00000000..ec5e139e --- /dev/null +++ b/examples/process_run_exit.hvm4 @@ -0,0 +1,17 @@ +#include "../stdlib/process.hvm4" + +// Runs 3 commands and returns their process events. +// Expected events: #Exit{0}, #Exit{7}, #Exit{1}. + +@main = + ! f0 = λ e0 ; + ! f1 = λ e1 ; + ! f2 = λ e2 ; + @do( + [ + f0, @process_run("exit 0"), + f1, @process_run("exit 7"), + f2, @process_run("false") + ], + #P{e0, #P{e1, e2}} + ) diff --git a/examples/process_timeout_kill.hvm4 b/examples/process_timeout_kill.hvm4 new file mode 100644 index 00000000..ebb4d7d3 --- /dev/null +++ b/examples/process_timeout_kill.hvm4 @@ -0,0 +1,36 @@ +#include "../stdlib/all.hvm4" + +// Starts a long process, waits timeout_ms, then kills it. + +@process_kill_wait = λproc. + ! f0 = λ st ; + ! f1 = λ kw ; + @do( + [ + f0, @process_kill(proc), + f1, λ{ + #Rdy: λp2. λev.@pure(#P{p2, ev}); + #Pend: λp2.@process_wait(p2); + &{} + }(st) + ], + kw + ) + +@run_with_timeout = λcmd. λtimeout_ms. + ! f0 = λ p0 ; + ! f1 = λ t0 ; + ! f2 = λ tw ; + ! f3 = λ kw ; + @do( + [ + f0, @process_spawn(cmd), + f1, @timer_start(timeout_ms), + f2, @timer_wait(t0), + f3, @process_kill_wait(p0) + ], + #P{tw, kw} + ) + +@main = + @run_with_timeout("sleep 10", 1000) diff --git a/examples/sample.txt b/examples/sample.txt new file mode 100644 index 00000000..363dfc52 --- /dev/null +++ b/examples/sample.txt @@ -0,0 +1,2 @@ +Hello from HVM4 examples. +This file is read as bytes and decoded with stdlib/bytes.hvm4. diff --git a/examples/stream_file_read_all.hvm4 b/examples/stream_file_read_all.hvm4 new file mode 100644 index 00000000..226bc5c0 --- /dev/null +++ b/examples/stream_file_read_all.hvm4 @@ -0,0 +1,52 @@ +#include "../stdlib/all.hvm4" + +// Reads an entire file via stream, closes it, and decodes UTF-8. + +@stream_read_all_step = λw. λ&acc. + !&w2 = w; + !&h = @fst(w2); + ! e = @snd(w2); + λ{ + #StreamByte: λb.@stream_read_all(h, b <> acc); + #StreamEof: @pure(#P{h, @list_rev(acc)}); + &{} + }(e) + +@stream_read_all = λstrm. λ&acc. + ! f0 = λ w0 ; + ! f1 = λ r1 ; + @do( + [ + f0, @stream_wait(strm), + f1, @stream_read_all_step(w0, acc) + ], + r1 + ) + +@stream_close_decode = λr1. + !&r = r1; + ! f0 = λ c2 ; + ! f1 = λ txt ; + @do( + [ + f0, @stream_close(@fst(r)), + f1, @bytes_to_string(@snd(r)) + ], + txt + ) + +@stream_file_read_all = λpath. + ! f0 = λ s0 ; + ! f1 = λ r1 ; + ! f2 = λ txt ; + @do( + [ + f0, @stream_file_open(path), + f1, @stream_read_all(s0, []), + f2, @stream_close_decode(r1) + ], + txt + ) + +@main = + @stream_file_read_all("examples/sample.txt") diff --git a/examples/stream_stdin_line.hvm4 b/examples/stream_stdin_line.hvm4 new file mode 100644 index 00000000..7dfc5bcd --- /dev/null +++ b/examples/stream_stdin_line.hvm4 @@ -0,0 +1,63 @@ +#include "../stdlib/all.hvm4" + +// Reads one line from stdin (until '\n'), closes stream, decodes UTF-8. + +@stream_read_line_step = λw. λ&acc. + !&w2 = w; + !&h = @fst(w2); + ! e = @snd(w2); + λ{ + #StreamByte: λb. + λ{ + #BYT: λn. + λ{ + 10: + @pure(#P{h, @list_rev(acc)}); + λx. + @stream_read_line(h, #BYT{x} <> acc) + }(n); + &{} + }(b); + #StreamEof: + @pure(#P{h, @list_rev(acc)}); + &{} + }(e) + +@stream_read_line = λstrm. λ&acc. + ! f0 = λ w0 ; + ! f1 = λ r1 ; + @do( + [ + f0, @stream_wait(strm), + f1, @stream_read_line_step(w0, acc) + ], + r1 + ) + +@stream_close_decode = λr1. + !&r = r1; + ! f0 = λ c2 ; + ! f1 = λ txt ; + @do( + [ + f0, @stream_close(@fst(r)), + f1, @bytes_to_string(@snd(r)) + ], + txt + ) + +@stdin_read_line = + ! f0 = λ s0 ; + ! f1 = λ r1 ; + ! f2 = λ txt ; + @do( + [ + f0, @stream_stdin_open(0), + f1, @stream_read_line(s0, []), + f2, @stream_close_decode(r1) + ], + txt + ) + +@main = + @stdin_read_line diff --git a/examples/tcp_echo_client.hvm4 b/examples/tcp_echo_client.hvm4 new file mode 100644 index 00000000..e1f540bf --- /dev/null +++ b/examples/tcp_echo_client.hvm4 @@ -0,0 +1,37 @@ +#include "../stdlib/all.hvm4" + +// Connects to localhost:9090, sends "ping\n", waits reply, closes socket. +// Requires an echo server running on 127.0.0.1:9090. + +@decode_recv_evt = λev. + λ{ + #Recv: λbs.@bytes_to_string(bs); + #TcpEof: @pure(""); + #TcpFail: λreason. λmsg.#ERR{msg}; + &{} + }(ev) + +@decode_roundtrip = λout0. + !&o = out0; + ! p = @snd(o); + ! recv_evt = @snd(p); + ! f0 = λ txt ; + @do( + [ + f0, @decode_recv_evt(recv_evt) + ], + #P{o, txt} + ) + +@main = + ! req = @tcp_req("127.0.0.1", 9090, @tcp_opts_default); + ! payload = [#BYT{112}, #BYT{105}, #BYT{110}, #BYT{103}, #BYT{10}]; + ! f0 = λ out0 ; + ! f1 = λ out1 ; + @do( + [ + f0, @tcp_roundtrip(req, payload, 128), + f1, @decode_roundtrip(out0) + ], + out1 + ) diff --git a/examples/timer_sleep_and_ticks.hvm4 b/examples/timer_sleep_and_ticks.hvm4 new file mode 100644 index 00000000..cdb4f9e6 --- /dev/null +++ b/examples/timer_sleep_and_ticks.hvm4 @@ -0,0 +1,32 @@ +#include "../stdlib/timer.hvm4" + +// Logs "tick" every second, 5 times. + +@ticks = λn. λ&ms. + λ{ + 0: + @pure(#Done{}); + λk. + ! f0 = λ s0 ; + ! f1 = λ l1 ; + ! f2 = λ r2 ; + @do( + [ + f0, @sleep_ms(ms), + f1, @log("tick"), + f2, @ticks(k - 1, ms) + ], + r2 + ) + }(n) + +@main = + ! f0 = λ l0 ; + ! f1 = λ r1 ; + @do( + [ + f0, @log("starting timer example"), + f1, @ticks(5, 1000) + ], + r1 + ) diff --git a/stdlib/_.hvm4 b/stdlib/_.hvm4 new file mode 100644 index 00000000..9d113a32 --- /dev/null +++ b/stdlib/_.hvm4 @@ -0,0 +1,150 @@ +// HVM4 stdlib core +// - Result combinators +// - Generic do-notation interpreter +// - Wait/poll normalization helpers +// - Generic list helpers + +// ----------------------------------------------------------------------------- +// Result Core +// ----------------------------------------------------------------------------- + +@pure = λx.#OK{x} +@ok = @pure + +@fail = λmsg.#ERR{msg} + +@bind = λr. λk. + λ{ + #OK: λx.k(x); + #ERR: λe.#ERR{e}; + &{} + }(r) + +@then = λr. λnext. + @bind(r, λu.next) + +@map = λr. λf. + @bind(r, λx.@pure(f(x))) + +@map_err = λr. λf. + λ{ + #OK: λx.#OK{x}; + #ERR: λe.#ERR{f(e)}; + &{} + }(r) + +@or_else = λr. λkerr. + λ{ + #OK: λx.#OK{x}; + #ERR: λe.kerr(e); + &{} + }(r) + +@log = λmsg. + @pure(%log(msg)) + +@fst = λp. + λ{ + #P: λa. λb.a; + &{} + }(p) + +@snd = λp. + λ{ + #P: λa. λb.b; + &{} + }(p) + +@dup2 = λx. λk. + !d&D = x; + k(d₀, d₁) + +// ----------------------------------------------------------------------------- +// Do Notation Core +// ----------------------------------------------------------------------------- + +// @do_with(bind, pure, steps, cont) +// steps format: [wrap0, action0, wrap1, action1, ...] +// wrapN is an unscoped wrapper built with: ! f = λ x ; ... +@do_with = λ&bind. λ&pure. λsteps. λ&cont. + λ{ + []: pure(cont); + <>: λwrap. λtail. + λ{ + <>: λact. λrest. + bind(act, λv. + λ{ + #P: λrest2. λcont2. + @do_with(bind, pure, rest2, cont2); + &{} + }(wrap(#P{rest,cont})(v)) + ); + []: + #ERR{"do: malformed steps; expected [wrap,action,...]"} + }(tail) + }(steps) + +@do = λsteps. λcont. + @do_with(@bind, @pure, steps, cont) + +// ----------------------------------------------------------------------------- +// Wait/Poll Normalization +// ----------------------------------------------------------------------------- + +@wait = λr. λdecode. + @bind(r, λst.decode(st)) + +@decode_wait_h = λst. + λ{ + #Rdy: λh.@pure(h); + #Pend: λh.#ERR{"expected #Rdy; got #Pend"}; + &{} + }(st) + +@decode_wait_he = λst. + λ{ + #Rdy: λh. λe.@pure(#P{h,e}); + #Pend: λh.#ERR{"expected #Rdy; got #Pend"}; + &{} + }(st) + +@decode_poll_h = λst. + λ{ + #Pend: λh.@pure(#Pend{h}); + #Rdy: λh.@pure(#Rdy{h}); + &{} + }(st) + +@decode_poll_he = λst. + λ{ + #Pend: λh.@pure(#Pend{h}); + #Rdy: λh. λe.@pure(#Rdy{#P{h,e}}); + &{} + }(st) + +@await_poll = λ&poll. λ&decode. λh0. + ! f0 = λ st ; + @do( + [ + f0, @wait(poll(h0), decode) + ], + λ{ + #Pend: λh1.@await_poll(poll, decode, h1); + #Rdy: λout.@pure(out); + &{} + }(st) + ) + +// ----------------------------------------------------------------------------- +// Generic Lists +// ----------------------------------------------------------------------------- + +@list_rev = λxs. + @list_rev_go(xs, []) + +@list_rev_go = λxs. λ&acc. + λ{ + []: acc; + <>: λh. λt.@list_rev_go(t, h <> acc); + &{} + }(xs) diff --git a/stdlib/all.hvm4 b/stdlib/all.hvm4 new file mode 100644 index 00000000..ef0985be --- /dev/null +++ b/stdlib/all.hvm4 @@ -0,0 +1,9 @@ +#include "_.hvm4" +#include "bytes.hvm4" +#include "timer.hvm4" +#include "process.hvm4" +#include "stream.hvm4" +#include "http.hvm4" +#include "tcp.hvm4" +#include "fs.hvm4" +#include "os.hvm4" diff --git a/stdlib/bytes.hvm4 b/stdlib/bytes.hvm4 new file mode 100644 index 00000000..575778b4 --- /dev/null +++ b/stdlib/bytes.hvm4 @@ -0,0 +1,156 @@ +#include "_.hvm4" + +// Byte helpers +// - UTF-8 decode from List<#BYT{n}> to String (List<#CHR{codepoint}>) + +@bytes_if = λcond. λyes. λno. + λ{ + 0: no; + λx.yes + }(cond) + +@bytes_is_cont = λ&b. + ((b >= 128) && (b <= 191)) + +@bytes_valid_b1_3 = λ&b0. λ&b1. + @bytes_if( + (b0 == 224), + ((b1 >= 160) && (b1 <= 191)), + @bytes_if( + (b0 == 237), + ((b1 >= 128) && (b1 <= 159)), + @bytes_is_cont(b1) + ) + ) + +@bytes_valid_b1_4 = λ&b0. λ&b1. + @bytes_if( + (b0 == 240), + ((b1 >= 144) && (b1 <= 191)), + @bytes_if( + (b0 == 244), + ((b1 >= 128) && (b1 <= 143)), + @bytes_is_cont(b1) + ) + ) + +@bytes_to_string = λbytes. + @bytes_to_string_go(bytes, []) + +@bytes_to_string_go = λbytes. λ&acc. + λ{ + []: + @pure(@list_rev(acc)); + <>: λhead. λ&tail. + λ{ + #BYT: λ&b0. + @bytes_if( + (b0 <= 127), + @bytes_to_string_go(tail, #CHR{b0} <> acc), + @bytes_if( + ((b0 >= 194) && (b0 <= 223)), + @bytes_to_string_2(b0, tail, acc), + @bytes_if( + ((b0 >= 224) && (b0 <= 239)), + @bytes_to_string_3(b0, tail, acc), + @bytes_if( + ((b0 >= 240) && (b0 <= 244)), + @bytes_to_string_4(b0, tail, acc), + @fail("bytes_to_string: invalid UTF-8 leading byte") + ) + ) + ) + ); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(head); + &{} + }(bytes) + +@bytes_to_string_2 = λ&b0. λtail. λ&acc. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh1. λrest. + λ{ + #BYT: λ&b1. + @bytes_if( + @bytes_is_cont(b1), + ! cp = (((b0 - 192) << 6) + (b1 - 128)); + @bytes_to_string_go(rest, #CHR{cp} <> acc), + @fail("bytes_to_string: invalid UTF-8 continuation byte") + ); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h1); + &{} + }(tail) + +@bytes_to_string_3 = λ&b0. λtail. λ&acc. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh1. λtail2. + λ{ + #BYT: λ&b1. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh2. λrest. + λ{ + #BYT: λ&b2. + @bytes_if( + (@bytes_valid_b1_3(b0, b1) && @bytes_is_cont(b2)), + ! cp = ((((b0 - 224) << 12) + ((b1 - 128) << 6)) + (b2 - 128)); + @bytes_to_string_go(rest, #CHR{cp} <> acc), + @fail("bytes_to_string: invalid UTF-8 continuation byte") + ); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h2); + &{} + }(tail2); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h1); + &{} + }(tail) + +@bytes_to_string_4 = λ&b0. λtail. λ&acc. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh1. λtail2. + λ{ + #BYT: λ&b1. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh2. λtail3. + λ{ + #BYT: λ&b2. + λ{ + []: + @fail("bytes_to_string: truncated UTF-8 sequence"); + <>: λh3. λrest. + λ{ + #BYT: λ&b3. + @bytes_if( + ((@bytes_valid_b1_4(b0, b1) && @bytes_is_cont(b2)) && @bytes_is_cont(b3)), + ! cp = (((((b0 - 240) << 18) + ((b1 - 128) << 12)) + ((b2 - 128) << 6)) + (b3 - 128)); + @bytes_to_string_go(rest, #CHR{cp} <> acc), + @fail("bytes_to_string: invalid UTF-8 continuation byte") + ); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h3); + &{} + }(tail3); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h2); + &{} + }(tail2); + λx.@fail("bytes_to_string: expected List<#BYT{n}>") + }(h1); + &{} + }(tail) + +@bytes_log = λbytes. + @bind(@bytes_to_string(bytes), λtxt. + @log(txt) + ) diff --git a/stdlib/fs.hvm4 b/stdlib/fs.hvm4 new file mode 100644 index 00000000..b503082e --- /dev/null +++ b/stdlib/fs.hvm4 @@ -0,0 +1,15 @@ +#include "_.hvm4" + +// File system helpers + +@fs_read_text = λpath. + %read_file(path) + +@fs_read_bytes = λpath. + %read_bytes(path) + +@fs_write_text = λpath. λtext. + %write_file(path, text) + +@fs_write_bytes = λpath. λdata. + %write_bytes(path, data) diff --git a/stdlib/http.hvm4 b/stdlib/http.hvm4 new file mode 100644 index 00000000..dcd4a7e0 --- /dev/null +++ b/stdlib/http.hvm4 @@ -0,0 +1,50 @@ +#include "_.hvm4" + +// HTTP helpers + +@http_opts_default = + #Opts{5000,2000,#F{},0,#T{},65536} + +@http_req = λmethod. λurl. λheaders. λbody. λopts. + #Req{method,url,headers,body,opts} + +@http_get_req = λurl. + #Req{#Get{},url,[],#NoBody{},@http_opts_default} + +@http_post_text_req = λurl. λtext. + #Req{#Post{},url,[],#BodyText{text},@http_opts_default} + +@http_post_bytes_req = λurl. λbbs. + #Req{#Post{},url,[],#BodyBytes{bbs},@http_opts_default} + +@http_request = λreq. + %http_request(req) + +@http_poll = λhttp. + %http_poll(http) + +@http_wait = λhttp. + @wait(%http_wait(http), @decode_wait_he) + +@http_cancel = λhttp. + %http_cancel(http) + +@http_request_wait = λreq. + ! f0 = λ h0 ; + ! f1 = λ w1 ; + @do( + [ + f0, @http_request(req), + f1, @http_wait(h0) + ], + @snd(w1) + ) + +@http_get = λurl. + @http_request_wait(@http_get_req(url)) + +@http_post_text = λurl. λtext. + @http_request_wait(@http_post_text_req(url, text)) + +@http_post_bytes = λurl. λbbs. + @http_request_wait(@http_post_bytes_req(url, bbs)) diff --git a/stdlib/os.hvm4 b/stdlib/os.hvm4 new file mode 100644 index 00000000..09920250 --- /dev/null +++ b/stdlib/os.hvm4 @@ -0,0 +1,27 @@ +#include "_.hvm4" + +// OS / environment helpers + +@env_get = λname. + %env(name) + +@cwd_get = + %cwd(0) + +@chdir = λpath. + %chdir(path) + +@argv = + @pure(%argv(0)) + +@uid = + @pure(%uid(0)) + +@rand = + @pure(%rand(0)) + +@uuid = + %uuid(0) + +@abort = λmsg. + %panic(msg) diff --git a/stdlib/process.hvm4 b/stdlib/process.hvm4 new file mode 100644 index 00000000..d192d621 --- /dev/null +++ b/stdlib/process.hvm4 @@ -0,0 +1,35 @@ +#include "_.hvm4" + +// Process helpers + +@process_spawn = λcmd. + %process_spawn(cmd) + +@process_poll = λproc. + %process_poll(proc) + +@process_wait = λproc. + @wait(%process_wait(proc), @decode_wait_he) + +@process_wait_evt = λproc. + ! f0 = λ w0 ; + @do( + [ + f0, @process_wait(proc) + ], + @snd(w0) + ) + +@process_kill = λproc. + %process_kill(proc) + +@process_run = λcmd. + ! f0 = λ p0 ; + ! f1 = λ e1 ; + @do( + [ + f0, @process_spawn(cmd), + f1, @process_wait_evt(p0) + ], + e1 + ) diff --git a/stdlib/stream.hvm4 b/stdlib/stream.hvm4 new file mode 100644 index 00000000..9481d397 --- /dev/null +++ b/stdlib/stream.hvm4 @@ -0,0 +1,63 @@ +#include "_.hvm4" + +// Stream helpers + +@stream_stdin_open = λseed. + %stream_stdin_open(seed) + +@stream_file_open = λpath. + %stream_file_open(path) + +@stream_poll = λstrm. + %stream_poll(strm) + +@stream_wait = λstrm. + @wait(%stream_wait(strm), @decode_wait_he) + +@stream_close = λstrm. + %stream_close(strm) + +@stream_read_all = λstrm. + @stream_read_all_go(strm, []) + +@stream_read_all_go = λstrm. λ&acc. + ! f0 = λ w ; + @do( + [ + f0, @stream_wait(strm) + ], + !&wr = w; + !&h = @fst(wr); + ! e = @snd(wr); + !&a = acc; + λ{ + #StreamByte: λb.@stream_read_all_go(h, b <> a); + #StreamEof: @pure(#P{h, @list_rev(a)}); + &{} + }(e) + ) + +@stream_close_and_take = λr1. + !&r = r1; + ! h = @fst(r); + ! b = @snd(r); + ! f0 = λ c0 ; + @do( + [ + f0, @stream_close(h) + ], + b + ) + +@stream_file_read_all = λpath. + ! f0 = λ s0 ; + ! f1 = λ r1 ; + ! f2 = λ b2 ; + @do( + [ + f0, @stream_file_open(path), + f1, @stream_read_all(s0), + f2, @stream_close_and_take(r1) + ], + b2 + ) diff --git a/stdlib/tcp.hvm4 b/stdlib/tcp.hvm4 new file mode 100644 index 00000000..ff6fa2a9 --- /dev/null +++ b/stdlib/tcp.hvm4 @@ -0,0 +1,117 @@ +#include "_.hvm4" + +// TCP helpers + +@tcp_opts_default = + #TcpOpts{5000,5000,5000,#T{},#F{}} + +@tcp_req = λhost. λport. λopts. + #TcpReq{host,port,opts} + +@tcp_connect = λreq. + %tcp_connect(req) + +@tcp_connect_poll = λtcp. + %tcp_connect_poll(tcp) + +@tcp_connect_wait = λtcp. + @wait(%tcp_connect_wait(tcp), @decode_wait_he) + +@tcp_send_poll = λtcp. λdata. + %tcp_send_poll(tcp, data) + +@tcp_send_wait = λtcp. λdata. + @wait(%tcp_send_wait(tcp, data), @decode_wait_he) + +@tcp_recv_poll = λtcp. λmaxb. + %tcp_recv_poll(tcp, maxb) + +@tcp_recv_wait = λtcp. λmaxb. + @wait(%tcp_recv_wait(tcp, maxb), @decode_wait_he) + +@tcp_close = λtcp. + @wait(%tcp_close(tcp), @decode_wait_he) + +@tcp_expect_conn = λw1. + !&w = w1; + ! h = @fst(w); + λ{ + #Conn: @pure(h); + #TcpFail: λreason. λmsg.#ERR{msg}; + &{} + }(@snd(w)) + +@tcp_connect_open = λreq. + ! f0 = λ t0 ; + ! f1 = λ w1 ; + ! f2 = λ h2 ; + @do( + [ + f0, @tcp_connect(req), + f1, @tcp_connect_wait(t0), + f2, @tcp_expect_conn(w1) + ], + h2 + ) + +@tcp_step_send = λw1. λdata. + !&p = w1; + ! h1 = @fst(p); + ! cevt = @snd(p); + ! f0 = λ w2 ; + @do( + [ + f0, @tcp_send_wait(h1, data) + ], + #P{w2, cevt} + ) + +@tcp_step_recv = λst. λmaxb. + !&s = st; + ! w2 = @fst(s); + ! cevt = @snd(s); + !&q = w2; + ! h2 = @fst(q); + ! sevt = @snd(q); + ! f0 = λ w3 ; + @do( + [ + f0, @tcp_recv_wait(h2, maxb) + ], + #P{w3, #P{cevt,sevt}} + ) + +@tcp_step_close = λst. + !&s = st; + ! w3 = @fst(s); + ! pair = @snd(s); + !&q = w3; + ! h3 = @fst(q); + ! revt = @snd(q); + !&r = pair; + ! cevt = @fst(r); + ! sevt = @snd(r); + ! f0 = λ w4 ; + @do( + [ + f0, @tcp_close(h3) + ], + #P{cevt, #P{sevt, revt}} + ) + +@tcp_roundtrip = λreq. λdata. λmaxb. + ! f0 = λ t0 ; + ! f1 = λ w1 ; + ! f2 = λ st2 ; + ! f3 = λ st3 ; + ! f4 = λ out ; + @do( + [ + f0, @tcp_connect(req), + f1, @tcp_connect_wait(t0), + f2, @tcp_step_send(w1, data), + f3, @tcp_step_recv(st2, maxb), + f4, @tcp_step_close(st3) + ], + out + ) diff --git a/stdlib/timer.hvm4 b/stdlib/timer.hvm4 new file mode 100644 index 00000000..bad38f19 --- /dev/null +++ b/stdlib/timer.hvm4 @@ -0,0 +1,26 @@ +#include "_.hvm4" + +// Timer helpers + +@timer_start = λms. + %timer_start(ms) + +@timer_poll = λt. + %timer_poll(t) + +@timer_wait = λt. + @map(@wait(%timer_wait(t), @decode_wait_he), @fst) + +@sleep_ms = λms. + ! f0 = λ t0 ; + ! f1 = λ t1 ; + @do( + [ + f0, @timer_start(ms), + f1, @timer_wait(t0) + ], + [] + ) + +@sleep_s = λsec. + @sleep_ms(sec * 1000) diff --git a/test.hvm4 b/test.hvm4 new file mode 100644 index 00000000..d8f74ba8 --- /dev/null +++ b/test.hvm4 @@ -0,0 +1,31 @@ +//@test_panic = #Pair{%panic((λx.x<>"A")('∀')), 33} +//@test_concat = %concat((λx.x<>[])([1,2]), [3]) +// +//@main = @test_panic +//@main = @test_concat +// +////@main = %concat([1,2],[3]) +////@main = %log(&L{1,2}) +// +// +@trace = λa.λb. !!v = %log(a); b +@main = @trace("works", 90) + + + + + + + + + + + + + + + + + + + diff --git a/test/prim_argv_echo.hvm b/test/prim_argv_echo.hvm new file mode 100644 index 00000000..b6caad82 --- /dev/null +++ b/test/prim_argv_echo.hvm @@ -0,0 +1,4 @@ +//! -- hello +@main = %log(λ{[]: "no argv"; <>: λx,t. x}(%argv([]))) +//!hello +//![] diff --git a/test/prim_argv_with_args.hvm4 b/test/prim_argv_with_args.hvm4 new file mode 100644 index 00000000..506aa453 --- /dev/null +++ b/test/prim_argv_with_args.hvm4 @@ -0,0 +1,3 @@ +@main = %argv(0) +//FLAGS: -- alpha beta +//!["alpha","beta"] diff --git a/test/prim_chdir_dot_ok.hvm4 b/test/prim_chdir_dot_ok.hvm4 new file mode 100644 index 00000000..7bcc03d4 --- /dev/null +++ b/test/prim_chdir_dot_ok.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_chdir_dot_ok +@main = @tag(%chdir(".")) +//!"OK" diff --git a/test/prim_chdir_invalid_shape_err.hvm4 b/test/prim_chdir_invalid_shape_err.hvm4 new file mode 100644 index 00000000..6cc3a82f --- /dev/null +++ b/test/prim_chdir_invalid_shape_err.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_chdir_invalid_shape_err +@main = @tag(%chdir(1)) +//!"ERR" diff --git a/test/prim_chdir_missing_err.hvm4 b/test/prim_chdir_missing_err.hvm4 new file mode 100644 index 00000000..dae112ee --- /dev/null +++ b/test/prim_chdir_missing_err.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_chdir_missing_err +@main = @tag(%chdir("/tmp/hvm4_missing_chdir_001")) +//!"ERR" diff --git a/test/prim_chdir_path_inner_mix.hvm4 b/test/prim_chdir_path_inner_mix.hvm4 new file mode 100644 index 00000000..6f1be192 --- /dev/null +++ b/test/prim_chdir_path_inner_mix.hvm4 @@ -0,0 +1,3 @@ +// prim_chdir_path_inner_mix +@main = %chdir('/'<>&L{&{},↑"tmp"}) +//!&L{&{},↑#OK{[]}} diff --git a/test/prim_chdir_path_mix_inc_sup_era.hvm4 b/test/prim_chdir_path_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..8ccbd44e --- /dev/null +++ b/test/prim_chdir_path_mix_inc_sup_era.hvm4 @@ -0,0 +1,3 @@ +// prim_chdir_path_mix_inc_sup_era +@main = %chdir(↑&L{&{}, "."}) +//!↑&L{&{},#OK{[]}} diff --git a/test/prim_cwd_after_chdir_tmp.hvm4 b/test/prim_cwd_after_chdir_tmp.hvm4 new file mode 100644 index 00000000..33c79010 --- /dev/null +++ b/test/prim_cwd_after_chdir_tmp.hvm4 @@ -0,0 +1,10 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_cwd_after_chdir_tmp +@main = @bind(%chdir("/tmp"), λx.%cwd(0)) +//!#OK{"/tmp"} diff --git a/test/prim_env_bad_shape_err.hvm4 b/test/prim_env_bad_shape_err.hvm4 new file mode 100644 index 00000000..0f808f53 --- /dev/null +++ b/test/prim_env_bad_shape_err.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_env_bad_shape_err +@main = @tag(%env(1)) +//!"ERR" diff --git a/test/prim_env_invalid_utf32_err.hvm4 b/test/prim_env_invalid_utf32_err.hvm4 new file mode 100644 index 00000000..a0c4f255 --- /dev/null +++ b/test/prim_env_invalid_utf32_err.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_env_invalid_utf32_err +@main = @tag(%env(#CON{#CHR{55296}, #NIL})) +//!"ERR" diff --git a/test/prim_env_missing_var_err.hvm4 b/test/prim_env_missing_var_err.hvm4 new file mode 100644 index 00000000..0380a7ef --- /dev/null +++ b/test/prim_env_missing_var_err.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_env_missing_var_err +@main = @tag(%env("__HVM4_SHOULD_NOT_EXIST__")) +//!"ERR" diff --git a/test/prim_env_name_mix_inc_sup_era.hvm4 b/test/prim_env_name_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..49e8d371 --- /dev/null +++ b/test/prim_env_name_mix_inc_sup_era.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_env_name_mix_inc_sup_era +@main = @tag(%env(↑&L{&{}, "PATH"})) +//!↑&L{&{},"OK"} diff --git a/test/prim_env_path_ok.hvm4 b/test/prim_env_path_ok.hvm4 new file mode 100644 index 00000000..450eed25 --- /dev/null +++ b/test/prim_env_path_ok.hvm4 @@ -0,0 +1,10 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_env_path_ok +@main = @tag(%env("PATH")) +//!"OK" diff --git a/test/prim_http_cancel_bad_handle.hvm4 b/test/prim_http_cancel_bad_handle.hvm4 new file mode 100644 index 00000000..4512d114 --- /dev/null +++ b/test/prim_http_cancel_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %http_cancel(#Http{0,0}) +//EXPECT_CONTAINS:ERROR(http_cancel): E2 diff --git a/test/prim_http_poll_bad_handle.hvm4 b/test/prim_http_poll_bad_handle.hvm4 new file mode 100644 index 00000000..7707552a --- /dev/null +++ b/test/prim_http_poll_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %http_poll(#Http{0,0}) +//EXPECT_CONTAINS:ERROR(http_poll): E2 diff --git a/test/prim_http_request_bad_arg.hvm4 b/test/prim_http_request_bad_arg.hvm4 new file mode 100644 index 00000000..ecaa0e9a --- /dev/null +++ b/test/prim_http_request_bad_arg.hvm4 @@ -0,0 +1,2 @@ +@main = %http_request(0) +//EXPECT_CONTAINS:ERROR(http_request): E1 diff --git a/test/prim_http_wait_era.hvm4 b/test/prim_http_wait_era.hvm4 new file mode 100644 index 00000000..5dfba11e --- /dev/null +++ b/test/prim_http_wait_era.hvm4 @@ -0,0 +1,2 @@ +@main = %http_wait(&{}) +//!&{} diff --git a/test/prim_panic_aborts_before_continuation.hvm4 b/test/prim_panic_aborts_before_continuation.hvm4 new file mode 100644 index 00000000..8817ed0b --- /dev/null +++ b/test/prim_panic_aborts_before_continuation.hvm4 @@ -0,0 +1,3 @@ +// prim_panic_aborts_before_continuation +@main = !!x = %panic("panic_001_basic"); "panic_should_not_print" +//panic_001_basic diff --git a/test/prim_panic_message_inner_mix_inc_aborts.hvm4 b/test/prim_panic_message_inner_mix_inc_aborts.hvm4 new file mode 100644 index 00000000..c184c367 --- /dev/null +++ b/test/prim_panic_message_inner_mix_inc_aborts.hvm4 @@ -0,0 +1,3 @@ +// prim_panic_message_inner_mix_inc_aborts +@main = %panic('p'<>↑"anic_inc") +//panic_inc diff --git a/test/prim_process_bad_handle.hvm4 b/test/prim_process_bad_handle.hvm4 new file mode 100644 index 00000000..7fc6964c --- /dev/null +++ b/test/prim_process_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %process_poll(#Proc{1,0}) +//EXPECT_CONTAINS:E2 unknown process id diff --git a/test/prim_process_bind.hvm4 b/test/prim_process_bind.hvm4 new file mode 100644 index 00000000..15ef34d9 --- /dev/null +++ b/test/prim_process_bind.hvm4 @@ -0,0 +1,9 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +@main = @bind(%process_spawn("exit 7"), λp.%process_wait(p)) +//!#OK{#Rdy{#Proc{1,1},#Exit{7}}} diff --git a/test/prim_process_kill_done.hvm4 b/test/prim_process_kill_done.hvm4 new file mode 100644 index 00000000..136f54b5 --- /dev/null +++ b/test/prim_process_kill_done.hvm4 @@ -0,0 +1,5 @@ +@main = + !!s = %process_spawn("exit 0"); + !!r = %process_wait(#Proc{1,0}); + %process_kill(#Proc{1,1}) +//!#OK{#Rdy{#Proc{1,2},#Exit{0}}} diff --git a/test/prim_process_poll_inc.hvm4 b/test/prim_process_poll_inc.hvm4 new file mode 100644 index 00000000..fb164c29 --- /dev/null +++ b/test/prim_process_poll_inc.hvm4 @@ -0,0 +1,2 @@ +@main = %process_poll(↑#Proc{1,0}) +//!↑#ERR{"ERROR(process_poll): E2 unknown process id"} diff --git a/test/prim_process_poll_pending.hvm4 b/test/prim_process_poll_pending.hvm4 new file mode 100644 index 00000000..f4593cb0 --- /dev/null +++ b/test/prim_process_poll_pending.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %process_spawn("sleep 1"); + %process_poll(#Proc{1,0}) +//!#OK{#Pend{#Proc{1,1}}} diff --git a/test/prim_process_spawn.hvm4 b/test/prim_process_spawn.hvm4 new file mode 100644 index 00000000..80f58ee2 --- /dev/null +++ b/test/prim_process_spawn.hvm4 @@ -0,0 +1,2 @@ +@main = %process_spawn("exit 0") +//!#OK{#Proc{1,0}} diff --git a/test/prim_process_stale.hvm4 b/test/prim_process_stale.hvm4 new file mode 100644 index 00000000..cf7b517e --- /dev/null +++ b/test/prim_process_stale.hvm4 @@ -0,0 +1,5 @@ +@main = + !!x = %process_spawn("sleep 1"); + !!y = %process_poll(#Proc{1,0}); + %process_poll(#Proc{1,0}) +//EXPECT_CONTAINS:E3 stale process handle diff --git a/test/prim_process_sup.hvm4 b/test/prim_process_sup.hvm4 new file mode 100644 index 00000000..d87fba5a --- /dev/null +++ b/test/prim_process_sup.hvm4 @@ -0,0 +1,5 @@ +@main = + !!a = %process_spawn("exit 0"); + !!b = %process_spawn("exit 0"); + %process_wait(&L{#Proc{1,0}, #Proc{2,0}}) +//!&L{#OK{#Rdy{#Proc{1,1},#Exit{0}}},#OK{#Rdy{#Proc{2,1},#Exit{0}}}} diff --git a/test/prim_process_wait_era.hvm4 b/test/prim_process_wait_era.hvm4 new file mode 100644 index 00000000..e7374ff4 --- /dev/null +++ b/test/prim_process_wait_era.hvm4 @@ -0,0 +1,2 @@ +@main = %process_wait(&{}) +//!&{} diff --git a/test/prim_process_wait_exit.hvm4 b/test/prim_process_wait_exit.hvm4 new file mode 100644 index 00000000..06bf8fad --- /dev/null +++ b/test/prim_process_wait_exit.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %process_spawn("exit 7"); + %process_wait(#Proc{1,0}) +//!#OK{#Rdy{#Proc{1,1},#Exit{7}}} diff --git a/test/prim_rand_non_negative.hvm4 b/test/prim_rand_non_negative.hvm4 new file mode 100644 index 00000000..68827ecc --- /dev/null +++ b/test/prim_rand_non_negative.hvm4 @@ -0,0 +1,2 @@ +@main = (%rand(0) >= 0) +//1 diff --git a/test/prim_read_bytes_missing.hvm4 b/test/prim_read_bytes_missing.hvm4 new file mode 100644 index 00000000..111b3873 --- /dev/null +++ b/test/prim_read_bytes_missing.hvm4 @@ -0,0 +1,11 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_read_bytes_missing +@path_007 = "/tmp/hvm4_io_missing_007.bin" +@main = @tag(%read_bytes(@path_007)) +//!"ERR" diff --git a/test/prim_read_bytes_path_inner_mix.hvm4 b/test/prim_read_bytes_path_inner_mix.hvm4 new file mode 100644 index 00000000..a07fac0b --- /dev/null +++ b/test/prim_read_bytes_path_inner_mix.hvm4 @@ -0,0 +1,13 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_read_bytes_path_inner_mix +@path_020 = "/tmp/hvm4_io_020.bin" +@bytes_020 = #CON{#BYT{9}, #NIL} +@path_inner_020 = '/'<>&L{&{},↑"tmp/hvm4_io_020.bin"} +@main = @bind(%write_bytes(@path_020, @bytes_020), λx.%read_bytes(@path_inner_020)) +//!&L{&{},↑#OK{[#BYT{9}]}} diff --git a/test/prim_read_bytes_path_mix_inc_sup_era.hvm4 b/test/prim_read_bytes_path_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..f6f74c73 --- /dev/null +++ b/test/prim_read_bytes_path_mix_inc_sup_era.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_read_bytes_path_mix_inc_sup_era +@path_014 = "/tmp/hvm4_io_014.bin" +@bytes_014 = #CON{#BYT{7}, #NIL} +@main = @bind(%write_bytes(@path_014, @bytes_014), λx.%read_bytes(↑&L{@path_014, &{}})) +//!↑&L{#OK{[#BYT{7}]},&{}} diff --git a/test/prim_read_file_invalid_utf8.hvm4 b/test/prim_read_file_invalid_utf8.hvm4 new file mode 100644 index 00000000..6186269f --- /dev/null +++ b/test/prim_read_file_invalid_utf8.hvm4 @@ -0,0 +1,19 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_read_file_invalid_utf8 +@path_005 = "/tmp/hvm4_io_005.bin" +@bytes_005 = #CON{#BYT{195}, #NIL} +@main = @bind(%write_bytes(@path_005, @bytes_005), λx.@tag(%read_file(@path_005))) +//!"ERR" diff --git a/test/prim_read_file_missing.hvm4 b/test/prim_read_file_missing.hvm4 new file mode 100644 index 00000000..64ad8287 --- /dev/null +++ b/test/prim_read_file_missing.hvm4 @@ -0,0 +1,11 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_read_file_missing +@path_006 = "/tmp/hvm4_io_missing_006.txt" +@main = @tag(%read_file(@path_006)) +//!"ERR" diff --git a/test/prim_read_file_path_inner_mix.hvm4 b/test/prim_read_file_path_inner_mix.hvm4 new file mode 100644 index 00000000..69fa8b87 --- /dev/null +++ b/test/prim_read_file_path_inner_mix.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_read_file_path_inner_mix +@path_018 = "/tmp/hvm4_io_018.txt" +@path_inner_018 = '/'<>&L{&{},↑"tmp/hvm4_io_018.txt"} +@main = @bind(%write_file(@path_018, "inner-path"), λx.%read_file(@path_inner_018)) +//!&L{&{},↑#OK{"inner-path"}} diff --git a/test/prim_read_file_path_mix_inc_sup_era.hvm4 b/test/prim_read_file_path_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..df9508da --- /dev/null +++ b/test/prim_read_file_path_mix_inc_sup_era.hvm4 @@ -0,0 +1,11 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_read_file_path_mix_inc_sup_era +@path_013 = "/tmp/hvm4_io_013.txt" +@main = @bind(%write_file(@path_013, "mix-rf"), λx.%read_file(↑&L{&{},@path_013})) +//!↑&L{&{},#OK{"mix-rf"}} diff --git a/test/prim_stream_close_bad_handle.hvm4 b/test/prim_stream_close_bad_handle.hvm4 new file mode 100644 index 00000000..f21eb1c8 --- /dev/null +++ b/test/prim_stream_close_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_close(#Strm{1,0}) +//EXPECT_CONTAINS:E2 unknown stream id diff --git a/test/prim_stream_close_era.hvm4 b/test/prim_stream_close_era.hvm4 new file mode 100644 index 00000000..aac44d6f --- /dev/null +++ b/test/prim_stream_close_era.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_close(&{}) +//!&{} diff --git a/test/prim_stream_close_ok.hvm4 b/test/prim_stream_close_ok.hvm4 new file mode 100644 index 00000000..8830a313 --- /dev/null +++ b/test/prim_stream_close_ok.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %stream_file_open("/dev/null"); + %stream_close(#Strm{1,0}) +//!#OK{[]} diff --git a/test/prim_stream_close_stale.hvm4 b/test/prim_stream_close_stale.hvm4 new file mode 100644 index 00000000..81ae4fe3 --- /dev/null +++ b/test/prim_stream_close_stale.hvm4 @@ -0,0 +1,5 @@ +@main = + !!x = %stream_file_open("/dev/null"); + !!y = %stream_close(#Strm{1,0}); + %stream_close(#Strm{1,0}) +//EXPECT_CONTAINS:E3 stale stream handle diff --git a/test/prim_stream_file_open.hvm4 b/test/prim_stream_file_open.hvm4 new file mode 100644 index 00000000..773ea4d8 --- /dev/null +++ b/test/prim_stream_file_open.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_file_open("/dev/null") +//!#OK{#Strm{1,0}} diff --git a/test/prim_stream_file_open_era.hvm4 b/test/prim_stream_file_open_era.hvm4 new file mode 100644 index 00000000..dd84cbd2 --- /dev/null +++ b/test/prim_stream_file_open_era.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_file_open(&{}) +//!&{} diff --git a/test/prim_stream_file_open_inc.hvm4 b/test/prim_stream_file_open_inc.hvm4 new file mode 100644 index 00000000..b6a551b7 --- /dev/null +++ b/test/prim_stream_file_open_inc.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_file_open(↑"/dev/null") +//!↑#OK{#Strm{1,0}} diff --git a/test/prim_stream_file_open_missing.hvm4 b/test/prim_stream_file_open_missing.hvm4 new file mode 100644 index 00000000..f6e15b8a --- /dev/null +++ b/test/prim_stream_file_open_missing.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_file_open("/definitely_missing_hvm4_stream_file") +//EXPECT_CONTAINS:ERROR(stream_file_open): E5 diff --git a/test/prim_stream_file_open_sup.hvm4 b/test/prim_stream_file_open_sup.hvm4 new file mode 100644 index 00000000..fc482100 --- /dev/null +++ b/test/prim_stream_file_open_sup.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_file_open(&L{"/dev/null", "/dev/null"}) +//!&L{#OK{#Strm{1,0}},#OK{#Strm{2,0}}} diff --git a/test/prim_stream_poll_bad_handle.hvm4 b/test/prim_stream_poll_bad_handle.hvm4 new file mode 100644 index 00000000..67de0129 --- /dev/null +++ b/test/prim_stream_poll_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_poll(#Strm{1,0}) +//EXPECT_CONTAINS:E2 unknown stream id diff --git a/test/prim_stream_poll_closed.hvm4 b/test/prim_stream_poll_closed.hvm4 new file mode 100644 index 00000000..ce3dcb32 --- /dev/null +++ b/test/prim_stream_poll_closed.hvm4 @@ -0,0 +1,5 @@ +@main = + !!x = %stream_file_open("/dev/null"); + !!y = %stream_close(#Strm{1,0}); + %stream_poll(#Strm{1,1}) +//EXPECT_CONTAINS:E2 stream is closed diff --git a/test/prim_stream_poll_era.hvm4 b/test/prim_stream_poll_era.hvm4 new file mode 100644 index 00000000..38d6d2d9 --- /dev/null +++ b/test/prim_stream_poll_era.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_poll(&{}) +//!&{} diff --git a/test/prim_stream_poll_file_eof.hvm4 b/test/prim_stream_poll_file_eof.hvm4 new file mode 100644 index 00000000..da32ec93 --- /dev/null +++ b/test/prim_stream_poll_file_eof.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %stream_file_open("/dev/null"); + %stream_poll(#Strm{1,0}) +//!#OK{#Rdy{#Strm{1,1},#StreamEof{}}} diff --git a/test/prim_stream_poll_open.hvm4 b/test/prim_stream_poll_open.hvm4 new file mode 100644 index 00000000..dd9a6495 --- /dev/null +++ b/test/prim_stream_poll_open.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %stream_stdin_open(0); + %stream_poll(#Strm{1,0}) +//EXPECT_CONTAINS:#Strm{1,1} diff --git a/test/prim_stream_poll_stale.hvm4 b/test/prim_stream_poll_stale.hvm4 new file mode 100644 index 00000000..91d4d546 --- /dev/null +++ b/test/prim_stream_poll_stale.hvm4 @@ -0,0 +1,5 @@ +@main = + !!x = %stream_stdin_open(0); + !!y = %stream_poll(#Strm{1,0}); + %stream_poll(#Strm{1,0}) +//EXPECT_CONTAINS:E3 stale stream handle diff --git a/test/prim_stream_poll_sup.hvm4 b/test/prim_stream_poll_sup.hvm4 new file mode 100644 index 00000000..56cd8850 --- /dev/null +++ b/test/prim_stream_poll_sup.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_poll(&L{&{},&{}}) +//!&L{&{},&{}} diff --git a/test/prim_stream_stdin_open.hvm4 b/test/prim_stream_stdin_open.hvm4 new file mode 100644 index 00000000..6f294c36 --- /dev/null +++ b/test/prim_stream_stdin_open.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_stdin_open(0) +//!#OK{#Strm{1,0}} diff --git a/test/prim_stream_stdin_open_era.hvm4 b/test/prim_stream_stdin_open_era.hvm4 new file mode 100644 index 00000000..758f9607 --- /dev/null +++ b/test/prim_stream_stdin_open_era.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_stdin_open(&{}) +//!&{} diff --git a/test/prim_stream_stdin_open_inc.hvm4 b/test/prim_stream_stdin_open_inc.hvm4 new file mode 100644 index 00000000..00f95c6a --- /dev/null +++ b/test/prim_stream_stdin_open_inc.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_stdin_open(↑0) +//!↑#OK{#Strm{1,0}} diff --git a/test/prim_stream_stdin_open_sup.hvm4 b/test/prim_stream_stdin_open_sup.hvm4 new file mode 100644 index 00000000..d314b28f --- /dev/null +++ b/test/prim_stream_stdin_open_sup.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_stdin_open(&L{0,0}) +//!&L{#OK{#Strm{1,0}},#OK{#Strm{2,0}}} diff --git a/test/prim_stream_wait_bad_handle.hvm4 b/test/prim_stream_wait_bad_handle.hvm4 new file mode 100644 index 00000000..b0f40385 --- /dev/null +++ b/test/prim_stream_wait_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_wait(#Strm{1,0}) +//EXPECT_CONTAINS:E2 unknown stream id diff --git a/test/prim_stream_wait_era.hvm4 b/test/prim_stream_wait_era.hvm4 new file mode 100644 index 00000000..1aee455b --- /dev/null +++ b/test/prim_stream_wait_era.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_wait(&{}) +//!&{} diff --git a/test/prim_stream_wait_file_eof.hvm4 b/test/prim_stream_wait_file_eof.hvm4 new file mode 100644 index 00000000..840e2d77 --- /dev/null +++ b/test/prim_stream_wait_file_eof.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %stream_file_open("/dev/null"); + %stream_wait(#Strm{1,0}) +//!#OK{#Rdy{#Strm{1,1},#StreamEof{}}} diff --git a/test/prim_stream_wait_sup.hvm4 b/test/prim_stream_wait_sup.hvm4 new file mode 100644 index 00000000..eb71bf70 --- /dev/null +++ b/test/prim_stream_wait_sup.hvm4 @@ -0,0 +1,2 @@ +@main = %stream_wait(&L{&{},&{}}) +//!&L{&{},&{}} diff --git a/test/prim_tcp_close_bad_handle.hvm4 b/test/prim_tcp_close_bad_handle.hvm4 new file mode 100644 index 00000000..a730e10f --- /dev/null +++ b/test/prim_tcp_close_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_close(#Tcp{0,0}) +//EXPECT_CONTAINS:ERROR(tcp_close): E2 diff --git a/test/prim_tcp_close_era.hvm4 b/test/prim_tcp_close_era.hvm4 new file mode 100644 index 00000000..f3a07d6d --- /dev/null +++ b/test/prim_tcp_close_era.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_close(&{}) +//!&{} diff --git a/test/prim_tcp_connect_bad_arg.hvm4 b/test/prim_tcp_connect_bad_arg.hvm4 new file mode 100644 index 00000000..aec2a2bd --- /dev/null +++ b/test/prim_tcp_connect_bad_arg.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_connect(0) +//EXPECT_CONTAINS:ERROR(tcp_connect): E1 diff --git a/test/prim_tcp_connect_poll_bad_handle.hvm4 b/test/prim_tcp_connect_poll_bad_handle.hvm4 new file mode 100644 index 00000000..de541a46 --- /dev/null +++ b/test/prim_tcp_connect_poll_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_connect_poll(#Tcp{0,0}) +//EXPECT_CONTAINS:ERROR(tcp_connect_poll): E2 diff --git a/test/prim_tcp_connect_wait_era.hvm4 b/test/prim_tcp_connect_wait_era.hvm4 new file mode 100644 index 00000000..c829e664 --- /dev/null +++ b/test/prim_tcp_connect_wait_era.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_connect_wait(&{}) +//!&{} diff --git a/test/prim_tcp_recv_poll_bad_handle.hvm4 b/test/prim_tcp_recv_poll_bad_handle.hvm4 new file mode 100644 index 00000000..39cc3e27 --- /dev/null +++ b/test/prim_tcp_recv_poll_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_recv_poll(#Tcp{0,0}, 16) +//EXPECT_CONTAINS:ERROR(tcp_recv_poll): E2 diff --git a/test/prim_tcp_recv_wait_era_arg.hvm4 b/test/prim_tcp_recv_wait_era_arg.hvm4 new file mode 100644 index 00000000..271340b6 --- /dev/null +++ b/test/prim_tcp_recv_wait_era_arg.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_recv_wait(#Tcp{0,0}, &{}) +//!&{} diff --git a/test/prim_tcp_send_poll_bad_handle.hvm4 b/test/prim_tcp_send_poll_bad_handle.hvm4 new file mode 100644 index 00000000..b4718f7e --- /dev/null +++ b/test/prim_tcp_send_poll_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_send_poll(#Tcp{0,0}, []) +//EXPECT_CONTAINS:ERROR(tcp_send_poll): E2 diff --git a/test/prim_tcp_send_wait_era_arg.hvm4 b/test/prim_tcp_send_wait_era_arg.hvm4 new file mode 100644 index 00000000..019ca5b7 --- /dev/null +++ b/test/prim_tcp_send_wait_era_arg.hvm4 @@ -0,0 +1,2 @@ +@main = %tcp_send_wait(#Tcp{0,0}, &{}) +//!&{} diff --git a/test/prim_timer_bad_handle.hvm4 b/test/prim_timer_bad_handle.hvm4 new file mode 100644 index 00000000..8cb6d636 --- /dev/null +++ b/test/prim_timer_bad_handle.hvm4 @@ -0,0 +1,2 @@ +@main = %timer_poll(#Time{1,0}) +//EXPECT_CONTAINS:E2 unknown timer id diff --git a/test/prim_timer_bind.hvm4 b/test/prim_timer_bind.hvm4 new file mode 100644 index 00000000..1c511324 --- /dev/null +++ b/test/prim_timer_bind.hvm4 @@ -0,0 +1,9 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +@main = @bind(%timer_start(0), λh.%timer_wait(h)) +//!#OK{#Rdy{#Time{1,1},#None{}}} diff --git a/test/prim_timer_inc.hvm4 b/test/prim_timer_inc.hvm4 new file mode 100644 index 00000000..6e0e93cc --- /dev/null +++ b/test/prim_timer_inc.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %timer_start(0); + %timer_wait(↑#Time{1,0}) +//!↑#OK{#Rdy{#Time{1,1},#None{}}} diff --git a/test/prim_timer_poll_pending.hvm4 b/test/prim_timer_poll_pending.hvm4 new file mode 100644 index 00000000..40b2a87b --- /dev/null +++ b/test/prim_timer_poll_pending.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %timer_start(1000); + %timer_poll(#Time{1,0}) +//!#OK{#Pend{#Time{1,1}}} diff --git a/test/prim_timer_stale.hvm4 b/test/prim_timer_stale.hvm4 new file mode 100644 index 00000000..b42b639a --- /dev/null +++ b/test/prim_timer_stale.hvm4 @@ -0,0 +1,5 @@ +@main = + !!x = %timer_start(0); + !!y = %timer_poll(#Time{1,0}); + %timer_poll(#Time{1,0}) +//EXPECT_CONTAINS:E3 stale timer handle diff --git a/test/prim_timer_start.hvm4 b/test/prim_timer_start.hvm4 new file mode 100644 index 00000000..06bdbaaf --- /dev/null +++ b/test/prim_timer_start.hvm4 @@ -0,0 +1,2 @@ +@main = %timer_start(0) +//!#OK{#Time{1,0}} diff --git a/test/prim_timer_sup.hvm4 b/test/prim_timer_sup.hvm4 new file mode 100644 index 00000000..c57c54aa --- /dev/null +++ b/test/prim_timer_sup.hvm4 @@ -0,0 +1,5 @@ +@main = + !!a = %timer_start(0); + !!b = %timer_start(0); + %timer_wait(&L{#Time{1,0}, #Time{2,0}}) +//!&L{#OK{#Rdy{#Time{1,1},#None{}}},#OK{#Rdy{#Time{2,1},#None{}}}} diff --git a/test/prim_timer_wait_era.hvm4 b/test/prim_timer_wait_era.hvm4 new file mode 100644 index 00000000..c7b1c53a --- /dev/null +++ b/test/prim_timer_wait_era.hvm4 @@ -0,0 +1,2 @@ +@main = %timer_wait(&{}) +//!&{} diff --git a/test/prim_timer_wait_zero.hvm4 b/test/prim_timer_wait_zero.hvm4 new file mode 100644 index 00000000..d0428897 --- /dev/null +++ b/test/prim_timer_wait_zero.hvm4 @@ -0,0 +1,4 @@ +@main = + !!x = %timer_start(0); + %timer_wait(#Time{1,0}) +//!#OK{#Rdy{#Time{1,1},#None{}}} diff --git a/test/prim_uid_distinct.hvm4 b/test/prim_uid_distinct.hvm4 new file mode 100644 index 00000000..d864e259 --- /dev/null +++ b/test/prim_uid_distinct.hvm4 @@ -0,0 +1,2 @@ +@main = (%uid(0) === %uid(0)) +//0 diff --git a/test/prim_uid_prefix.hvm4 b/test/prim_uid_prefix.hvm4 new file mode 100644 index 00000000..170def4d --- /dev/null +++ b/test/prim_uid_prefix.hvm4 @@ -0,0 +1,2 @@ +@main = %uid(0) +//EXPECT_PREFIX:"uid- diff --git a/test/prim_uuid_prefix.hvm4 b/test/prim_uuid_prefix.hvm4 new file mode 100644 index 00000000..a7f17d2e --- /dev/null +++ b/test/prim_uuid_prefix.hvm4 @@ -0,0 +1,2 @@ +@main = %uuid(0) +//EXPECT_PREFIX:#OK{" diff --git a/test/prim_write_bytes_data_inner_mix.hvm4 b/test/prim_write_bytes_data_inner_mix.hvm4 new file mode 100644 index 00000000..4555bfc7 --- /dev/null +++ b/test/prim_write_bytes_data_inner_mix.hvm4 @@ -0,0 +1,5 @@ +// prim_write_bytes_data_inner_mix +@path_021 = "/tmp/hvm4_io_021.bin" +@bytes_021 = #CON{#BYT{65}, #CON{&L{&{},↑#BYT{66}}, #NIL}} +@main = %write_bytes(@path_021, @bytes_021) +//!&L{&{},↑#OK{[]}} diff --git a/test/prim_write_bytes_data_mix_inc_sup_era.hvm4 b/test/prim_write_bytes_data_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..ad01ca46 --- /dev/null +++ b/test/prim_write_bytes_data_mix_inc_sup_era.hvm4 @@ -0,0 +1,5 @@ +// prim_write_bytes_data_mix_inc_sup_era +@path_017 = "/tmp/hvm4_io_017.bin" +@bytes_017 = #CON{#BYT{33}, #NIL} +@main = %write_bytes(@path_017, &L{↑@bytes_017, &{}}) +//!&L{↑#OK{[]},&{}} diff --git a/test/prim_write_bytes_invalid_byte.hvm4 b/test/prim_write_bytes_invalid_byte.hvm4 new file mode 100644 index 00000000..987a90cf --- /dev/null +++ b/test/prim_write_bytes_invalid_byte.hvm4 @@ -0,0 +1,12 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_write_bytes_invalid_byte +@path_011 = "/tmp/hvm4_io_011.bin" +@bytes_011 = #CON{#BYT{300}, #NIL} +@main = @tag(%write_bytes(@path_011, @bytes_011)) +//!"ERR" diff --git a/test/prim_write_bytes_invalid_data_shape.hvm4 b/test/prim_write_bytes_invalid_data_shape.hvm4 new file mode 100644 index 00000000..e785ce68 --- /dev/null +++ b/test/prim_write_bytes_invalid_data_shape.hvm4 @@ -0,0 +1,11 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_write_bytes_invalid_data_shape +@path_010 = "/tmp/hvm4_io_010.bin" +@main = @tag(%write_bytes(@path_010, 1)) +//!"ERR" diff --git a/test/prim_write_bytes_read_bytes_binary.hvm4 b/test/prim_write_bytes_read_bytes_binary.hvm4 new file mode 100644 index 00000000..9c24e61f --- /dev/null +++ b/test/prim_write_bytes_read_bytes_binary.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_write_read_bytes_binary +@path_004 = "/tmp/hvm4_io_004.bin" +@bytes_004 = #CON{#BYT{0}, #CON{#BYT{1}, #CON{#BYT{2}, #CON{#BYT{255}, #NIL}}}} +@main = @bind(%write_bytes(@path_004, @bytes_004), λx.%read_bytes(@path_004)) +//!#OK{[#BYT{0},#BYT{1},#BYT{2},#BYT{255}]} diff --git a/test/prim_write_file_data_inner_mix.hvm4 b/test/prim_write_file_data_inner_mix.hvm4 new file mode 100644 index 00000000..154aa81f --- /dev/null +++ b/test/prim_write_file_data_inner_mix.hvm4 @@ -0,0 +1,5 @@ +// prim_write_file_data_inner_mix +@path_019 = "/tmp/hvm4_io_019.txt" +@text_019 = 'a'<>&L{&{},↑'b'}<>'c'<>[] +@main = %write_file(@path_019, @text_019) +//!&L{&{},↑#OK{[]}} diff --git a/test/prim_write_file_data_mix_inc_sup_era.hvm4 b/test/prim_write_file_data_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..35722697 --- /dev/null +++ b/test/prim_write_file_data_mix_inc_sup_era.hvm4 @@ -0,0 +1,4 @@ +// prim_write_file_data_mix_inc_sup_era +@path_016 = "/tmp/hvm4_io_016.txt" +@main = %write_file(@path_016, &L{↑"mix-data", &{}}) +//!&L{↑#OK{[]},&{}} diff --git a/test/prim_write_file_invalid_data_shape.hvm4 b/test/prim_write_file_invalid_data_shape.hvm4 new file mode 100644 index 00000000..9b573cf3 --- /dev/null +++ b/test/prim_write_file_invalid_data_shape.hvm4 @@ -0,0 +1,11 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_write_file_invalid_data_shape +@path_009 = "/tmp/hvm4_io_009.txt" +@main = @tag(%write_file(@path_009, 1)) +//!"ERR" diff --git a/test/prim_write_file_invalid_path_shape.hvm4 b/test/prim_write_file_invalid_path_shape.hvm4 new file mode 100644 index 00000000..9faec298 --- /dev/null +++ b/test/prim_write_file_invalid_path_shape.hvm4 @@ -0,0 +1,11 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_write_file_invalid_path_shape +@text_008 = "x" +@main = @tag(%write_file(1, @text_008)) +//!"ERR" diff --git a/test/prim_write_file_invalid_utf32.hvm4 b/test/prim_write_file_invalid_utf32.hvm4 new file mode 100644 index 00000000..82029ab5 --- /dev/null +++ b/test/prim_write_file_invalid_utf32.hvm4 @@ -0,0 +1,12 @@ +@tag = λr. + λ{ + #OK: λx. "OK" + #ERR: λe. "ERR" + &{} + }(r) + +// prim_write_file_invalid_utf32 +@path_012 = "/tmp/hvm4_io_012.txt" +@text_012 = #CON{#CHR{55296}, #NIL} +@main = @tag(%write_file(@path_012, @text_012)) +//!"ERR" diff --git a/test/prim_write_file_path_mix_inc_sup_era.hvm4 b/test/prim_write_file_path_mix_inc_sup_era.hvm4 new file mode 100644 index 00000000..84b07aa9 --- /dev/null +++ b/test/prim_write_file_path_mix_inc_sup_era.hvm4 @@ -0,0 +1,4 @@ +// prim_write_file_path_mix_inc_sup_era +@path_015 = "/tmp/hvm4_io_015.txt" +@main = %write_file(&L{↑@path_015, &{}}, "mix-path") +//!&L{↑#OK{[]},&{}} diff --git a/test/prim_write_file_read_bytes_ascii.hvm4 b/test/prim_write_file_read_bytes_ascii.hvm4 new file mode 100644 index 00000000..d116ee96 --- /dev/null +++ b/test/prim_write_file_read_bytes_ascii.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_write_file_read_bytes_ascii +@path_003 = "/tmp/hvm4_io_003.txt" +@text_003 = "ABC" +@main = @bind(%write_file(@path_003, @text_003), λx.%read_bytes(@path_003)) +//!#OK{[#BYT{65},#BYT{66},#BYT{67}]} diff --git a/test/prim_write_file_read_file_empty.hvm4 b/test/prim_write_file_read_file_empty.hvm4 new file mode 100644 index 00000000..3bb2b749 --- /dev/null +++ b/test/prim_write_file_read_file_empty.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_write_read_file_empty +@path_002 = "/tmp/hvm4_io_002.txt" +@text_002 = "" +@main = @bind(%write_file(@path_002, @text_002), λx.%read_file(@path_002)) +//!#OK{[]} diff --git a/test/prim_write_file_read_file_roundtrip.hvm4 b/test/prim_write_file_read_file_roundtrip.hvm4 new file mode 100644 index 00000000..028acf81 --- /dev/null +++ b/test/prim_write_file_read_file_roundtrip.hvm4 @@ -0,0 +1,12 @@ +@bind = λr. λk. + λ{ + #OK: λx.k(x) + #ERR: λe.#ERR{e} + &{} + }(r) + +// prim_write_read_file_roundtrip +@path_001 = "/tmp/hvm4_io_001.txt" +@text_001 = "io_001_payload" +@main = @bind(%write_file(@path_001, @text_001), λx.%read_file(@path_001)) +//!#OK{"io_001_payload"}