JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

The x86 backend describes its frames in every build, and converts a u64 to and from a float as LLVM does

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 10:43:20 +07:00
commit 12c3d07acf
6 changed files with 189 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
TODO.org
View File

@ -1099,9 +1099,12 @@ build included, reaches =emit_globals_init= as =Emit.startup_plan='s
straight into their symbol are =Tast.const_init= ones, which neither transfer straight into their symbol are =Tast.const_init= ones, which neither transfer
nor read anything. Nothing to change. nor read anything. Nothing to change.
** TODO A u64 converted to f64 is signed on x86 ** DONE A u64 converted to f64 is signed on x86
=(f64 (u64 18446744073709551615))= prints =1.84467e+19= under LLVM and =-1= under CLOSED: [2026-09-25]
=--x86=, with a literal or a run-time =u64= alike. =--x86= converts =u64= to and from =f64= and =f32= the way LLVM's =uitofp= and
=fptoui= do: the halve-and-double sequence one way, subtract 2^63 and set the top
bit the other, ties rounding to even. =test/programs/u64-float.flan= runs on both
backends. A cast that misses =u64='s range reports it as =[0 18446744073709551615]=.
** DONE An aggregate built in place never reads its own destination ** DONE An aggregate built in place never reads its own destination
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
@ -1130,10 +1133,12 @@ so a =declare-c= wrapper leaning on the courtesy is already backend-dependent as
well as slice-dependent. The contract is pointer and length, and nothing promised well as slice-dependent. The contract is pointer and length, and nothing promised
otherwise. otherwise.
** NEXT Frame descriptions are gated on --debug ** DONE Frame descriptions are gated on --debug
Decided 2026-09-25: emit the x86 backend's =.cfi= directives in every build. No runtime cost; the lane measures the =.eh_frame= size it adds. CLOSED: [2026-09-25]
They are correct in every build and free at runtime, and a release build is where The x86 backend emits its =.cfi= directives in every build, redefinition modules
a crash would most want them. One =if= in three places. included, so an unwinder never has to guess at a Flan frame. Cost: about 40 bytes
of =.eh_frame= and =.eh_frame_hdr= per function, 2 KB on =json.flan='s 210 KB
binary.
** WAIT A !DILexicalBlock per Let ** WAIT A !DILexicalBlock per Let
Decided 2026-09-25: waits until Flan is debugged in gdb or lldb; the break buffer, which reads the shadow stack, already answers correctly. Decided 2026-09-25: waits until Flan is debugged in gdb or lldb; the break buffer, which reads the shadow stack, already answers correctly.

105
lib/x86.ml
View File

@ -1333,6 +1333,7 @@ let option_lay f (t : Types.t) =
let cc_e = 4 and cc_ne = 5 let cc_e = 4 and cc_ne = 5
let cc_b = 2 and cc_ae = 3 and cc_be = 6 and cc_a = 7 let cc_b = 2 and cc_ae = 3 and cc_be = 6 and cc_a = 7
let cc_l = 12 and cc_ge = 13 and cc_le = 14 and cc_g = 15 let cc_l = 12 and cc_ge = 13 and cc_le = 14 and cc_g = 15
let cc_s = 8
let int_cc ~signed (p : Tast.prim) = let int_cc ~signed (p : Tast.prim) =
match p, signed with match p, signed with
@ -3419,9 +3420,29 @@ and cast f (a : Tast.expr) (target : Types.t) dst =
cvtss2sd f.b ~dst:xmm0 ~src:xmm0; cvtss2sd f.b ~dst:xmm0 ~src:xmm0;
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t)
| false, true -> | false, true ->
let f64 = f64_of dst_t in
load_loc f ~reg:rax l src_t; load_loc f ~reg:rax l src_t;
cvtsi2f f.b ~f64:(f64_of dst_t) ~dst:xmm0 ~src:rax; if src_t = Types.Int Types.U64 then begin
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64:(f64_of dst_t) (* [cvtsi2sd] reads the register as signed, so a u64 with the top bit
set is halved first and doubled after. The bit shifted out is ORed
back into the lowest one, which keeps the halved value from landing
exactly on a tie it was not on, so the one rounding the conversion
does is the rounding of the whole value. *)
let big = new_label f "u2fbig" and done_ = new_label f "u2fdone" in
test_rr f.b ~a:rax ~c:rax;
jcc_lbl f.b ~cc:cc_s big;
cvtsi2f f.b ~f64 ~dst:xmm0 ~src:rax;
jmp_lbl f.b done_;
lbl f.b big;
mov_rr f.b ~dst:rcx ~src:rax;
shr_imm f.b ~dst:rcx ~n:1;
and_imm f.b ~dst:rax 1;
or_rr f.b ~dst:rcx ~src:rax;
cvtsi2f f.b ~f64 ~dst:xmm0 ~src:rcx;
farith f.b ~op:0x58 ~f64 ~dst:xmm0 ~src:xmm0;
lbl f.b done_
end else cvtsi2f f.b ~f64 ~dst:xmm0 ~src:rax;
fstore f.b ~src:xmm0 ~mm:(lmem f dst ~scratch:r11) ~f64
| true, false -> | true, false ->
fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t); fload f.b ~dst:xmm0 ~mm:(lmem f l ~scratch:r11) ~f64:(f64_of src_t);
(* [cvttsd2si] answers a fixed "integer indefinite" for a value out of (* [cvttsd2si] answers a fixed "integer indefinite" for a value out of
@ -3431,7 +3452,24 @@ and cast f (a : Tast.expr) (target : Types.t) dst =
(match src_t, dst_t with (match src_t, dst_t with
| Types.Float sk, Types.Int k -> check_cast f a.Tast.loc sk k | Types.Float sk, Types.Int k -> check_cast f a.Tast.loc sk k
| _ -> ()); | _ -> ());
cvttf2si f.b ~f64:(f64_of src_t) ~dst:rax ~src:xmm0; let f64 = f64_of src_t in
if dst_t = Types.Int Types.U64 then begin
(* [cvttsd2si] answers only for the signed range, so a value at 2^63 or
above has 2^63 taken off before the conversion and the top bit set
after it. A NaN compares unordered and takes the first branch. *)
let big = new_label f "f2ubig" and done_ = new_label f "f2udone" in
fload f.b ~dst:1 ~mm:(Sym (float_const f (ldexp 1.0 63) ~f64, 0)) ~f64;
ucomis f.b ~f64 ~a:xmm0 ~c:1;
jcc_lbl f.b ~cc:cc_ae big;
cvttf2si f.b ~f64 ~dst:rax ~src:xmm0;
jmp_lbl f.b done_;
lbl f.b big;
farith f.b ~op:0x5c ~f64 ~dst:xmm0 ~src:1;
cvttf2si f.b ~f64 ~dst:rax ~src:xmm0;
imm_into f ~reg:rcx Int64.min_int;
xor_rr f.b ~dst:rax ~src:rcx;
lbl f.b done_
end else cvttf2si f.b ~f64 ~dst:rax ~src:xmm0;
store_loc f ~reg:rax dst dst_t store_loc f ~reg:rax dst dst_t
(* ── Call frame information ──────────────────────────────────────────── *) (* ── Call frame information ──────────────────────────────────────────── *)
@ -3454,12 +3492,8 @@ and cast f (a : Tast.expr) (target : Types.t) dst =
the return address is column 16 and the CIE already says it is at the return address is column 16 and the CIE already says it is at
[cfa-8]. [cfa-8].
Emitted only in a [--debug] build, so that a release build's assembly stays Emitted in every build, [--debug] or not. It costs nothing at run time,
byte-for-byte what it was. That is a conservative call rather than a and a release build is where an unwind through a crash most wants it. *)
principled one: this description is correct in every build, and a release
build is where an unwind through a crash would most want it. What stops it
from being unconditional today is only that nothing measures the [.eh_frame]
it would add. *)
let cfi_after_push b = text b "\t.cfi_def_cfa_offset 16\n\t.cfi_offset 6, -16\n" let cfi_after_push b = text b "\t.cfi_def_cfa_offset 16\n\t.cfi_offset 6, -16\n"
let cfi_after_mov b = text b "\t.cfi_def_cfa_register 6\n" let cfi_after_mov b = text b "\t.cfi_def_cfa_register 6\n"
let cfi_after_leave b = text b "\t.cfi_def_cfa 7, 8\n" let cfi_after_leave b = text b "\t.cfi_def_cfa 7, 8\n"
@ -3711,7 +3745,6 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
column even when it is on the same line, so it gets a row of its own, and column even when it is on the same line, so it gets a row of its own, and
two rows are what let a debugger put a breakpoint after the prologue two rows are what let a debugger put a breakpoint after the prologue
rather than on it. *) rather than on it. *)
let cfi = match dw with None -> false | Some _ -> true in
let sub = let sub =
match dw with match dw with
| None -> None | None -> None
@ -4069,9 +4102,9 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
% 16 == 0 at every call site below is a property of that one rounded sub rather \ % 16 == 0 at every call site below is a property of that one rounded sub rather \
than an invariant each case has to keep."; than an invariant each case has to keep.";
push_r pb rbp; push_r pb rbp;
if cfi then cfi_after_push pb; cfi_after_push pb;
mov_rr pb ~dst:rbp ~src:rsp; mov_rr pb ~dst:rbp ~src:rsp;
if cfi then cfi_after_mov pb; cfi_after_mov pb;
let n = frame_bytes f in let n = frame_bytes f in
if n > 0 then sub_imm pb ~dst:rsp n; if n > 0 then sub_imm pb ~dst:rsp n;
(match sret_at with (match sret_at with
@ -4184,7 +4217,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax) load_scalar f ~reg:(if is_float fn.Tast.ret then xmm0 else rax)
~off:f.retval fn.Tast.ret; ~off:f.retval fn.Tast.ret;
leave f.b; leave f.b;
if cfi then cfi_after_leave f.b; cfi_after_leave f.b;
ret f.b; ret f.b;
flush pb; flush pb;
flush f.b; flush f.b;
@ -4206,7 +4239,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
if hidden then Buffer.add_string out (Printf.sprintf "\t.hidden\t%s\n" sym); if hidden then Buffer.add_string out (Printf.sprintf "\t.hidden\t%s\n" sym);
Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym); Buffer.add_string out (Printf.sprintf "\t.type\t%s, @function\n" sym);
Buffer.add_string out (sym ^ ":\n"); Buffer.add_string out (sym ^ ":\n");
if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out "\t.cfi_startproc\n";
Buffer.add_string out (Buffer.contents pb.out); Buffer.add_string out (Buffer.contents pb.out);
Buffer.add_string out (Buffer.contents f.b.out); Buffer.add_string out (Buffer.contents f.b.out);
(* One past the last byte, which is what [DW_AT_high_pc] and the line (* One past the last byte, which is what [DW_AT_high_pc] and the line
@ -4217,7 +4250,7 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
| Some s -> Buffer.add_string out (s.send ^ ":\n") | Some s -> Buffer.add_string out (s.send ^ ":\n")
| None -> ()); | None -> ());
(match dw with Some d -> d.dcur <- None | None -> ()); (match dw with Some d -> d.dcur <- None | None -> ());
if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out "\t.cfi_endproc\n";
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym); Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
Buffer.contents out, Buffer.contents f.rodata Buffer.contents out, Buffer.contents f.rodata
@ -4254,7 +4287,7 @@ let init_sym = asm_sym (Mangle.sym ".init-globals")
the loader put them in, the program's own end of the transfer channel is a the loader put them in, the program's own end of the transfer channel is a
null cell on this frame, and the exit goes through [flan_exit] because null cell on this frame, and the exit goes through [flan_exit] because
stdout is a FILE* and something has to flush it. *) stdout is a FILE* and something has to flush it. *)
let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false) let emit_main ?(ann = false) ?(startup = false) ?(gc = false)
?(dyn_globals = []) (md : Emit.m) (fn : Tast.fn) = ?(dyn_globals = []) (md : Emit.m) (fn : Tast.fn) =
let b = create () in let b = create () in
bnote ann b bnote ann b
@ -4266,9 +4299,9 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
and something has to flush it. The ud2 at the end is unreachable — flan_exit does \ and something has to flush it. The ud2 at the end is unreachable — flan_exit does \
not return."; not return.";
push_r b rbp; push_r b rbp;
if cfi then cfi_after_push b; cfi_after_push b;
mov_rr b ~dst:rbp ~src:rsp; mov_rr b ~dst:rbp ~src:rsp;
if cfi then cfi_after_mov b; cfi_after_mov b;
sub_imm b ~dst:rsp 48; sub_imm b ~dst:rsp 48;
(* [al] is zero at every call this backend makes, variadic or not — see (* [al] is zero at every call this backend makes, variadic or not — see
[call_native]. Setting it here too costs two bytes and keeps the rule [call_native]. Setting it here too costs two bytes and keeps the rule
@ -4380,9 +4413,9 @@ let emit_main ?(cfi = false) ?(ann = false) ?(startup = false) ?(gc = false)
it leaves through [flan_exit] and the [ud2] after that is unreachable. it leaves through [flan_exit] and the [ud2] after that is unreachable.
The rbp rule therefore holds to the last byte, which is what a backtrace The rbp rule therefore holds to the last byte, which is what a backtrace
out of anything [main] called needs. *) out of anything [main] called needs. *)
if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out "\t.cfi_startproc\n";
Buffer.add_string out (Buffer.contents b.out); Buffer.add_string out (Buffer.contents b.out);
if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out "\t.cfi_endproc\n";
Buffer.add_string out "\t.size\tmain, . - main\n\n"; Buffer.add_string out "\t.size\tmain, . - main\n\n";
Buffer.contents out Buffer.contents out
@ -4409,7 +4442,7 @@ let emit_globals_data (md : Emit.m) (globals : Tast.global list) =
Buffer.contents out Buffer.contents out
let emit_globals_init ?(cfi = false) ?(ann = false) ?body ~sym (md : Emit.m) ~externs ~fns let emit_globals_init ?(ann = false) ?body ~sym (md : Emit.m) ~externs ~fns
(globals : Tast.global list) = (globals : Tast.global list) =
let b = create () in let b = create () in
let f = let f =
@ -4454,9 +4487,9 @@ let emit_globals_init ?(cfi = false) ?(ann = false) ?body ~sym (md : Emit.m) ~ex
end; end;
let pb = create () in let pb = create () in
push_r pb rbp; push_r pb rbp;
if cfi then cfi_after_push pb; cfi_after_push pb;
mov_rr pb ~dst:rbp ~src:rsp; mov_rr pb ~dst:rbp ~src:rsp;
if cfi then cfi_after_mov pb; cfi_after_mov pb;
let n = frame_bytes f in let n = frame_bytes f in
if n > 0 then sub_imm pb ~dst:rsp n; if n > 0 then sub_imm pb ~dst:rsp n;
(* No caller hands this one a channel, so it gets a null cell of its own and (* No caller hands this one a channel, so it gets a null cell of its own and
@ -4467,16 +4500,16 @@ let emit_globals_init ?(cfi = false) ?(ann = false) ?body ~sym (md : Emit.m) ~ex
store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8; store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8;
lbl f.b f.retlbl; lbl f.b f.retlbl;
leave f.b; leave f.b;
if cfi then cfi_after_leave f.b; cfi_after_leave f.b;
ret f.b; ret f.b;
flush pb; flush f.b; flush pb; flush f.b;
let out = Buffer.create 512 in let out = Buffer.create 512 in
Buffer.add_string out Buffer.add_string out
(Printf.sprintf "\t.type\t%s, @function\n%s:\n" sym sym); (Printf.sprintf "\t.type\t%s, @function\n%s:\n" sym sym);
if cfi then Buffer.add_string out "\t.cfi_startproc\n"; Buffer.add_string out "\t.cfi_startproc\n";
Buffer.add_string out (Buffer.contents pb.out); Buffer.add_string out (Buffer.contents pb.out);
Buffer.add_string out (Buffer.contents f.b.out); Buffer.add_string out (Buffer.contents f.b.out);
if cfi then Buffer.add_string out "\t.cfi_endproc\n"; Buffer.add_string out "\t.cfi_endproc\n";
Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym); Buffer.add_string out (Printf.sprintf "\t.size\t%s, . - %s\n\n" sym sym);
Buffer.contents out, Buffer.contents f.rodata Buffer.contents out, Buffer.contents f.rodata
@ -4832,7 +4865,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
in in
let computed, init_flags, init_body = Emit.startup_plan md p.Tast.globals in let computed, init_flags, init_body = Emit.startup_plan md p.Tast.globals in
let ginit, gr = let ginit, gr =
emit_globals_init ~cfi:debug ~ann:annotate ~sym:data_sym md ~externs ~fns emit_globals_init ~ann:annotate ~sym:data_sym md ~externs ~fns
constants constants
in in
Buffer.add_string text ginit; Buffer.add_string text ginit;
@ -4840,7 +4873,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
let startup = computed <> [] in let startup = computed <> [] in
if startup then begin if startup then begin
let t, r = let t, r =
emit_globals_init ~cfi:debug ~ann:annotate ~body:init_body ~sym:init_sym emit_globals_init ~ann:annotate ~body:init_body ~sym:init_sym
md ~externs ~fns computed md ~externs ~fns computed
in in
Buffer.add_string text t; Buffer.add_string text t;
@ -4849,7 +4882,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false)
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with (match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "main") p.Tast.fns with
| Some fn -> | Some fn ->
Buffer.add_string text Buffer.add_string text
(emit_main ~cfi:debug ~ann:annotate ~startup ~gc:(Emit.uses_dyn p) (emit_main ~ann:annotate ~startup ~gc:(Emit.uses_dyn p)
~dyn_globals: ~dyn_globals:
(List.filter_map (List.filter_map
(fun (g : Tast.global) -> (fun (g : Tast.global) ->
@ -5217,7 +5250,9 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
end; end;
let pb = create () in let pb = create () in
push_r pb rbp; push_r pb rbp;
cfi_after_push pb;
mov_rr pb ~dst:rbp ~src:rsp; mov_rr pb ~dst:rbp ~src:rsp;
cfi_after_mov pb;
let n = frame_bytes f in let n = frame_bytes f in
if n > 0 then sub_imm pb ~dst:rsp n; if n > 0 then sub_imm pb ~dst:rsp n;
xor_rr pb ~dst:rax ~src:rax; xor_rr pb ~dst:rax ~src:rax;
@ -5226,17 +5261,18 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8; store_int pb ~src:rax ~mm:(Frame f.xfer_off) ~size:8;
lbl f.b f.retlbl; lbl f.b f.retlbl;
leave f.b; leave f.b;
cfi_after_leave f.b;
ret f.b; ret f.b;
flush pb; flush pb;
flush f.b; flush f.b;
Buffer.add_string text Buffer.add_string text
"\t.globl\tflan_reload_install\n\ "\t.globl\tflan_reload_install\n\
\t.type\tflan_reload_install, @function\n\ \t.type\tflan_reload_install, @function\n\
flan_reload_install:\n"; flan_reload_install:\n\t.cfi_startproc\n";
Buffer.add_buffer text pb.out; Buffer.add_buffer text pb.out;
Buffer.add_buffer text f.b.out; Buffer.add_buffer text f.b.out;
Buffer.add_string text Buffer.add_string text
"\t.size\tflan_reload_install, . - flan_reload_install\n\n"; "\t.cfi_endproc\n\t.size\tflan_reload_install, . - flan_reload_install\n\n";
(* An expression evaluation compiles to a function with nowhere to be called (* An expression evaluation compiles to a function with nowhere to be called
from, so the module says so and the agent runs it once -- after the from, so the module says so and the agent runs it once -- after the
install, on the game thread, so it sees both the bodies this module just install, on the game thread, so it sees both the bodies this module just
@ -5252,7 +5288,9 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
| Some fn -> | Some fn ->
let cb = create () in let cb = create () in
push_r cb rbp; push_r cb rbp;
cfi_after_push cb;
mov_rr cb ~dst:rbp ~src:rsp; mov_rr cb ~dst:rbp ~src:rsp;
cfi_after_mov cb;
sub_imm cb ~dst:rsp 16; sub_imm cb ~dst:rsp 16;
xor_rr cb ~dst:rax ~src:rax; xor_rr cb ~dst:rax ~src:rax;
store_int cb ~src:rax ~mm:(Frame (-8)) ~size:8; store_int cb ~src:rax ~mm:(Frame (-8)) ~size:8;
@ -5260,15 +5298,16 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true)
xor_rr cb ~dst:rax ~src:rax; xor_rr cb ~dst:rax ~src:rax;
call_sym cb (fsym fn); call_sym cb (fsym fn);
leave cb; leave cb;
cfi_after_leave cb;
ret cb; ret cb;
flush cb; flush cb;
Buffer.add_string text Buffer.add_string text
"\t.globl\tflan_reload_call\n\ "\t.globl\tflan_reload_call\n\
\t.type\tflan_reload_call, @function\n\ \t.type\tflan_reload_call, @function\n\
flan_reload_call:\n"; flan_reload_call:\n\t.cfi_startproc\n";
Buffer.add_buffer text cb.out; Buffer.add_buffer text cb.out;
Buffer.add_string text Buffer.add_string text
"\t.size\tflan_reload_call, . - flan_reload_call\n\n"); "\t.cfi_endproc\n\t.size\tflan_reload_call, . - flan_reload_call\n\n");
Buffer.add_buffer rodata f.rodata; Buffer.add_buffer rodata f.rodata;
let out = Buffer.create 8192 in let out = Buffer.create 8192 in
Buffer.add_buffer out text; Buffer.add_buffer out text;

16
runtime/flan_rt.c
View File

@ -1020,11 +1020,19 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
"to\n", "to\n",
(int)loclen, (const char *)loc); (int)loclen, (const char *)loc);
break; break;
/* An unsigned type's range starts at zero and a signed one's below it, so
* the lower bound says how to read the upper one: u64's is all ones. */
default: default:
fprintf(stderr, if (lhs == 0)
"%.*s: this value does not fit the integer type it is cast to, " fprintf(stderr,
"which holds [%lld %lld]\n", "%.*s: this value does not fit the integer type it is cast to, "
(int)loclen, (const char *)loc, (long long)lhs, (long long)rhs); "which holds [0 %llu]\n",
(int)loclen, (const char *)loc, (unsigned long long)rhs);
else
fprintf(stderr,
"%.*s: this value does not fit the integer type it is cast to, "
"which holds [%lld %lld]\n",
(int)loclen, (const char *)loc, (long long)lhs, (long long)rhs);
break; break;
} }
rt_die(); rt_die();

3
test/programs/arith.flan
View File

@ -82,6 +82,9 @@
(= n 10) (print (i32 (/ (f64 1.0) (f64 0.0)))) (= n 10) (print (i32 (/ (f64 1.0) (f64 0.0))))
(= n 11) (print (u8 (/ (f32 -1.0) (f32 0.0)))) (= n 11) (print (u8 (/ (f32 -1.0) (f32 0.0))))
(= n 12) (print (i32 (/ (f32 0.0) (f32 0.0)))) (= n 12) (print (i32 (/ (f32 0.0) (f32 0.0))))
;; A u64 destination, whose upper bound is all ones and is printed as
;; the unsigned number it is.
(= n 13) (print (u64 (* huge 1e-280)))
:else (println "?")) :else (println "?"))
0)) 0))

65
test/programs/u64-float.flan Normal file
View File

@ -0,0 +1,65 @@
;;;; Conversions between the unsigned integers and the floats, across the top
;;;; half of u64's range, where the value does not fit a signed register. Both
;;;; backends print the same lines. Each case is written twice: once through a
;;;; global, so the conversion happens at run time, and once on a literal.
;;;;
;;;; A float is printed by converting it back to an integer, because the
;;;; printed float has six digits and every case here differs past the sixth.
(defonce top u64 18446744073709551615) ; 2^64 - 1
(defonce half1 u64 9223372036854775809) ; 2^63 + 1
(defonce tie0 u64 9223372036854776832) ; 2^63 + 1024, a tie that rounds down to even
(defonce tie1 u64 9223372036854778880) ; 2^63 + 3072, a tie that rounds up to even
(defonce above u64 9223372036854776833) ; 2^63 + 1025, just past a tie
(defonce small u64 12345)
(defonce ftie0 u64 9223372586610589696) ; 2^63 + 2^39, an f32 tie that rounds down
(defonce fup u64 9223372586610589697) ; 2^63 + 2^39 + 1
(defonce ftie1 u64 9223373686122217472) ; 2^63 + 3*2^39, an f32 tie that rounds up
(defonce u32top u32 4294967295)
(defonce d63 f64 9223372036854775808.0) ; 2^63
(defonce dmax f64 18446744073709549568.0) ; the largest f64 below 2^64
(defonce dbelow f64 9223372036854774784.0) ; the largest f64 below 2^63
(defonce d15 f64 1.5e19)
(defonce dsmall f64 7.9)
(defonce s63 f32 9223372036854775808.0)
(defonce smax f32 18446742974197923840.0) ; the largest f32 below 2^64
(defonce d32 f64 4294967295.0)
(defonce d3e9 f64 3e9)
(defn main [] i32
;; u64 to f64.
(println (f64 top))
(println (u64 (* (f64 top) 0.5)))
(println (u64 (f64 half1)))
(println (u64 (f64 tie0)))
(println (u64 (f64 tie1)))
(println (u64 (f64 above)))
(println (u64 (f64 small)))
(println (f64 (u64 18446744073709551615)))
(println (u64 (f64 (u64 9223372036854778880))))
;; u64 to f32.
(println (u64 (* (f32 top) (f32 0.5))))
(println (u64 (f32 ftie0)))
(println (u64 (f32 fup)))
(println (u64 (f32 ftie1)))
(println (u64 (f32 small)))
(println (u64 (f32 (u64 9223372586610589697))))
;; u32 to both.
(println (u64 (f64 u32top)))
(println (u64 (f32 u32top)))
;; f64 and f32 to u64.
(println (u64 d63))
(println (u64 dmax))
(println (u64 dbelow))
(println (u64 d15))
(println (u64 dsmall))
(println (u64 s63))
(println (u64 smax))
(println (u64 18446744073709549568.0))
(println (u64 (f32 1.5e19)))
;; f64 to u32.
(println (u32 d32))
(println (u32 d3e9))
(println (u32 4294967295.0))
0)

25
test/test_acceptance.ml
View File

@ -2639,6 +2639,8 @@ let () =
"this value is infinite, which has no integer value to cast to"; "this value is infinite, which has no integer value to cast to";
traps "an f32 NaN cast to an integer" "12" traps "an f32 NaN cast to an integer" "12"
"this value is NaN, which has no integer value to cast to"; "this value is NaN, which has no integer value to cast to";
traps "a float too large for a u64" "13"
"which holds [0 18446744073709551615]";
(try Sys.remove exe with Sys_error _ -> ()) (try Sys.remove exe with Sys_error _ -> ())
in in
arith (); arith ();
@ -2772,6 +2774,29 @@ let () =
outputs ~x86:true outputs ~x86:true
"an aggregate that reads its destination sees the old value, --x86" "an aggregate that reads its destination sees the old value, --x86"
"programs/self-read.flan" self_read_out; "programs/self-read.flan" self_read_out;
(* Conversions between u64 and the floats across the top half of u64's
range, where [cvtsi2sd] and [cvttsd2si] read the register as signed:
x86 answered -1 for (f64 (u64 18446744073709551615)). The expected
lines are what LLVM's [uitofp] and [fptoui] give, ties included. *)
let u64_float_out =
"1.84467e+19\n9223372036854775808\n9223372036854775808\n\
9223372036854775808\n9223372036854779904\n9223372036854777856\n\
12345\n1.84467e+19\n9223372036854779904\n9223372036854775808\n\
9223372036854775808\n9223373136366403584\n9223374235878031360\n\
12345\n9223373136366403584\n4294967295\n4294967296\n\
9223372036854775808\n18446744073709549568\n9223372036854774784\n\
15000000000000000000\n7\n9223372036854775808\n\
18446742974197923840\n18446744073709549568\n15000000520515485696\n\
4294967295\n3000000000\n4294967295\n"
in
outputs "u64 and the floats convert across the whole range"
"programs/u64-float.flan" u64_float_out;
outputs ~opt:"-O0"
"u64 and the floats convert across the whole range, -O0"
"programs/u64-float.flan" u64_float_out;
outputs ~x86:true
"u64 and the floats convert across the whole range, --x86"
"programs/u64-float.flan" u64_float_out;
(* ── Packages: the link follows the program ──────────────────────── (* ── Packages: the link follows the program ────────────────────────
A package's C and linker arguments used to come with the import, A package's C and linker arguments used to come with the import,