From df0f69119666059ed8cac040c7a5ce640232b672 Mon Sep 17 00:00:00 2001 From: ancavar Date: Thu, 26 Feb 2026 00:28:40 +0300 Subject: [PATCH 1/6] move prefixes out of `SM.ml` --- src/Options.ml | 5 ++- src/SM.ml | 87 ++++++++++++++++++++++++-------------------------- src/X86_32.ml | 65 ++++++++++++++++++++++--------------- src/X86_64.ml | 75 ++++++++++++++++++++++++++----------------- 4 files changed, 130 insertions(+), 102 deletions(-) diff --git a/src/Options.ml b/src/Options.ml index 045f91d9d..fa655ed48 100644 --- a/src/Options.ml +++ b/src/Options.ml @@ -2,6 +2,9 @@ exception Commandline_error of string type os_t = Linux | Darwin +let init_label = "_init" +let labeled_init s = init_label ^ s + class options args = let n = Array.length args in let dump_ast = 0b1 in @@ -187,7 +190,7 @@ class options args = Filename.chop_suffix (Filename.basename self#get_infile) ".lama" method topname = - match !mode with `Compile -> "init" ^ self#basename | _ -> "main" + match !mode with `Compile -> labeled_init self#basename | _ -> "main" method dump_file ext contents = let name = self#basename in diff --git a/src/SM.ml b/src/SM.ml index 223e4f39c..7ad520238 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -14,13 +14,7 @@ type scope = { } [@@deriving gt ~options:{ show }] -let normal_label = "L" -let builtin_label = "B" -let global_label = "global_" -let labeled s = normal_label ^ s -let labeled_builtin s = builtin_label ^ s -let labeled_global s = global_label ^ s -let labeled_scoped i s = labeled s ^ "_" ^ string_of_int i +let labeled_scoped i s = s ^ "_" ^ string_of_int i let show_scope = show scope (* The type for the stack machine instructions *) @@ -88,10 +82,10 @@ type insn = | PATT of patt (* match failure (location, leave a value *) | FAIL of Loc.t * bool - (* external definition *) - | EXTERN of string - (* public definition *) - | PUBLIC of string + (* external definition (name, is_function) *) + | EXTERN of string * bool + (* public definition (name, is_function) *) + | PUBLIC of string * bool (* import clause *) | IMPORT of string (* line info *) @@ -168,19 +162,28 @@ module ByteCode = struct 16 FLABEL *) + (* Public symbol flags *) + let pub_flag_function = 0 + let pub_flag_global = 1 + let compile cmd insns = let code = Buffer.create 256 in let st = StringTab.create () in let lmap = Stdlib.ref M.empty in - let pubs = Stdlib.ref S.empty in + let pubs = Stdlib.ref [] in let imports = Stdlib.ref S.empty in let globals = Stdlib.ref M.empty in let glob_count = Stdlib.ref 0 in let fixups = Stdlib.ref [] in + let func_fixups = Stdlib.ref [] in let add_lab l = lmap := M.add l (Buffer.length code) !lmap in - let add_public l = pubs := S.add l !pubs in + let add_public name is_fun = + let flag = if is_fun then pub_flag_function else pub_flag_global in + pubs := (name, flag) :: !pubs + in let add_import l = imports := S.add l !imports in let add_fixup l = fixups := (Buffer.length code, l) :: !fixups in + let add_func_fixup l = func_fixups := (Buffer.length code, l) :: !func_fixups in let add_bytes = List.iter (fun x -> Buffer.add_char code @@ Char.chr x) in let add_ints = List.iter (fun x -> Buffer.add_int32_ne code @@ Int32.of_int x) @@ -271,13 +274,13 @@ module ByteCode = struct add_fixup s; add_ints [ 0 ] (* 0x70 *) - | CALL (f, _, _) when f = labeled "read" -> add_bytes [ (7 * 16) + 0 ] + | CALL (f, _, _) when f = "read" -> add_bytes [ (7 * 16) + 0 ] (* 0x71 *) - | CALL (f, _, _) when f = labeled "write" -> add_bytes [ (7 * 16) + 1 ] + | CALL (f, _, _) when f = "write" -> add_bytes [ (7 * 16) + 1 ] (* 0x72 *) - | CALL (f, _, _) when f = labeled "length" -> add_bytes [ (7 * 16) + 2 ] + | CALL (f, _, _) when f = "length" -> add_bytes [ (7 * 16) + 2 ] (* 0x73 *) - | CALL (f, _, _) when f = labeled "string" -> add_bytes [ (7 * 16) + 3 ] + | CALL (f, _, _) when f = "string" -> add_bytes [ (7 * 16) + 3 ] (* 0x74 *) | CALL (".array", n, _) -> add_bytes [ (7 * 16) + 4 ]; @@ -293,7 +296,7 @@ module ByteCode = struct (* 0x54 l:32 n:32 d*:32 *) | CLOSURE (s, ds) -> add_bytes [ (5 * 16) + 4 ]; - add_fixup s; + add_func_fixup s; add_ints [ 0; List.length ds ]; add_designations None ds (* 0x55 n:32 *) @@ -303,7 +306,7 @@ module ByteCode = struct (* 0x56 l:32 n:32 *) | CALL (fn, n, _) -> add_bytes [ (5 * 16) + 6 ]; - add_fixup fn; + add_func_fixup fn; add_ints [ 0; n ] (* 0x57 s:32 n:32 *) | TAG (s, n) -> @@ -325,7 +328,7 @@ module ByteCode = struct (* 0x6p *) | PATT p -> add_bytes [ (6 * 16) + enum patt p ] | EXTERN _ -> () - | PUBLIC s -> add_public s + | PUBLIC (name, is_fun) -> add_public name is_fun | IMPORT s -> add_import s | _ -> failwith @@ -344,14 +347,15 @@ module ByteCode = struct failwith (Printf.sprintf "ERROR: undefined label '%s'" l))) !fixups; let pubs = - List.map (fun l -> - ( Int32.of_int @@ StringTab.add st l, + List.map (fun (name, flag) -> + ( Int32.of_int @@ StringTab.add st name, Int32.of_int @@ - try M.find l !lmap + (try M.find name !lmap with Not_found -> - failwith (Printf.sprintf "ERROR: undefined label '%s'" l) )) - @@ S.elements !pubs + failwith (Printf.sprintf "ERROR: undefined label of public '%s'" name)), + flag )) + @@ List.rev !pubs in let st = Buffer.to_bytes st.StringTab.buffer in let file = Buffer.create 1024 in @@ -359,9 +363,10 @@ module ByteCode = struct Buffer.add_int32_ne file (Int32.of_int @@ !glob_count); Buffer.add_int32_ne file (Int32.of_int @@ List.length pubs); List.iter - (fun (n, o) -> + (fun (n, o, f) -> Buffer.add_int32_ne file n; - Buffer.add_int32_ne file o) + Buffer.add_int32_ne file o; + Buffer.add_uint8 file f) pubs; Buffer.add_bytes file st; Buffer.add_bytes file code; @@ -770,11 +775,6 @@ let run p i = inherit indexer p method builtin f args ((cstack, stack, glob, loc, i, o) : config) = - let f = - match f.[0] with - | 'L' -> String.sub f 1 (String.length f - 1) - | _ -> f - in let _, i, o, r = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) @@ -1038,10 +1038,10 @@ class env cmd imports = method global_scope = scope_index = 0 method get_label = - (labeled @@ string_of_int label_index, {}) + (string_of_int label_index, {}) method get_end_label = - let lab = labeled @@ string_of_int label_index in + let lab = string_of_int label_index in (lab, {}) method end_label = end_label @@ -1049,16 +1049,12 @@ class env cmd imports = method nlocals = scope.nlocals method get_decls = - let opt_label = function - | true -> labeled - | _ -> labeled_global - in List.flatten @@ List.map (function - | name, `Extern, f -> [ EXTERN (opt_label f name) ] - | name, `Public, f -> [ PUBLIC (opt_label f name) ] + | name, `Extern, f -> [ EXTERN (name, f) ] + | name, `Public, f -> [ PUBLIC (name, f) ] | name, `PublicExtern, f -> - [ PUBLIC (opt_label f name); EXTERN (opt_label f name) ] + [ PUBLIC (name, f); EXTERN (name, f) ] | _ -> invalid_arg "must not happen") @@ List.filter (function _, `Local, _ -> false | _ -> true) decls @@ -1200,10 +1196,9 @@ class env cmd imports = }>} method fun_internal_name (name : string) = - (match scope.st with - | State.G _ -> labeled - | _ -> labeled_scoped scope_index) - name + match scope.st with + | State.G _ -> name + | _ -> labeled_scoped scope_index name method add_fun_name (name : string) (m : [ `Local | `Extern | `Public | `PublicExtern ]) = @@ -1668,7 +1663,7 @@ let compile cmd ((imports, _), p) = in let prg = List.map (fun i -> IMPORT i) imports - @ [ PUBLIC topname ] @ env#get_decls @ List.flatten prg + @ [ PUBLIC (topname, true) ] @ env#get_decls @ List.flatten prg in (*Printf.eprintf "Before propagating closures:\n"; Printf.eprintf "%s\n%!" env#show_funinfo; diff --git a/src/X86_32.ml b/src/X86_32.ml index 46bb29861..7e0b1e8db 100644 --- a/src/X86_32.ml +++ b/src/X86_32.ml @@ -112,6 +112,13 @@ let show instr = (* Opening stack machine to use instructions without fully qualified names *) open SM +let normal_label = "L" +let builtin_label = "B" +let global_label = "global_" +let labeled s = normal_label ^ s +let labeled_builtin s = builtin_label ^ s +let labeled_global s = global_label ^ s + (* Symbolic stack machine evaluator compile : env -> prg -> env * instr list @@ -183,7 +190,7 @@ let compile cmd env imports code = let call env f n tail = let tail = tail && env#nargs = n && f.[0] <> '.' in let f = - match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f + match f.[0] with '.' -> labeled_builtin (String.sub f 1 (String.length f - 1)) | _ -> env#asm_fun_name f in if tail then ( @@ -230,17 +237,22 @@ let compile cmd env imports code = let env', code' = if env#is_barrier then match instr with - | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label s] else env#drop_stack, [] - | FLABEL s -> env#drop_barrier, [Label s] - | SLABEL s -> env, [Label s] + | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label (env#asm_fun_name s)] else env#drop_stack, [] + | FLABEL s -> env#drop_barrier, [Label (env#asm_fun_name s)] + | SLABEL s -> env, [Label (env#asm_fun_name s)] | _ -> env, [] else match instr with - | PUBLIC name -> env#register_public name, [] - | EXTERN name -> env#register_extern name, [] + | PUBLIC (name, is_fun) -> + let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + env#register_public asm_name, [] + | EXTERN (name, is_fun) -> + let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + env#register_extern asm_name, [] | IMPORT _name -> env, [] | CLOSURE (name, closure) -> + let asm_name = env#asm_fun_name name in let pushr, popr = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) in @@ -252,7 +264,7 @@ let compile cmd env imports code = (env, pushr @ push_closure @ - [Push (M ("$" ^ name)); + [Push (M ("$" ^ asm_name)); Push (L (box closure_len)); Call "Bclosure"; Binop ("+", L (word_size * (closure_len + 2)), esp); @@ -395,15 +407,16 @@ let compile cmd env imports code = | LABEL s | FLABEL s - | SLABEL s -> env, [Label s] + | SLABEL s -> env, [Label (env#asm_fun_name s)] - | JMP l -> (env#set_stack l)#set_barrier, [Jmp l] + | JMP l -> (env#set_stack l)#set_barrier, [Jmp (env#asm_fun_name l)] | CJMP (s, l) -> let x, env = env#pop in - env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] + env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_fun_name l)] | BEGIN (f, nargs, nlocals, closure, args, scopes) -> + let asm_f = env#asm_fun_name f in let rec stabs_scope scope = let names = List.map @@ -413,21 +426,18 @@ let compile cmd env imports code = scope.names in names @ - (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f)]) @ + (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 192,0,0,%s-%s" (labeled scope.blab) asm_f)]) @ (List.flatten @@ List.map stabs_scope scope.subs) @ - (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f)]) - in - let name = - if f.[0] = 'L' then String.sub f 1 (String.length f - 1) else f + (if names = [] then [] else [Meta (Printf.sprintf "\t.stabn 224,0,0,%s-%s" (labeled scope.elab) asm_f)]) in env#assert_empty_stack; let has_closure = closure <> [] in - let env = env#enter f nargs nlocals has_closure in - env, [Meta (Printf.sprintf "\t.type %s, @function" name)] @ + let env = env#enter asm_f nargs nlocals has_closure in + env, [Meta (Printf.sprintf "\t.type %s, @function" asm_f)] @ (if f = "main" then [] else - [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name f)] @ + [Meta (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" f asm_f)] @ (List.mapi (fun i a -> Meta (Printf.sprintf "\t.stabs \"%s:p1\",160,0,0,%d" a ((i*4) + 8))) args) @ (List.flatten @@ List.map stabs_scope scopes) ) @@ -461,7 +471,9 @@ let compile cmd env imports code = else [] ) @ (if f = cmd#topname - then List.map (fun i -> Call ("init" ^ i)) (List.filter (fun i -> i <> "Std") imports) + then + let open Options in + List.map (fun i -> Call (labeled_init i)) (List.filter (fun i -> i <> "Std") imports) else [] ) @@ -559,7 +571,7 @@ module S = Set.Make (String) module M = Map.Make (String) (* Environment implementation *) -class env prg = +class env prg topname = let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" in (* let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in *) (* let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in *) @@ -649,11 +661,14 @@ class env prg = method has_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) M.mem l stackmap + (* prefixes the name for a function *) + method asm_fun_name name = if name = topname then name else labeled name + (* gets a name for a global variable *) method loc x = match x with - | Value.Global name -> M ("global_" ^ name) - | Value.Fun name -> M ("$" ^ name) + | Value.Global name -> M (labeled_global name) + | Value.Fun name -> M ("$" ^ self#asm_fun_name name) | Value.Local i -> S i | Value.Arg i -> S (- (i + if has_closure then 2 else 1)) | Value.Access i -> I (word_size * (i+1), edx) @@ -697,7 +712,7 @@ class env prg = (* registers a variable in the environment *) method variable x = match x with - | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >} + | Value.Global name -> {< globals = S.add (labeled_global name) globals >} | _ -> self (* registers a string constant *) @@ -799,7 +814,7 @@ class env prg = *) let genasm cmd prog = let sm = SM.compile cmd prog in - let env, code = compile cmd (new env sm) (fst (fst prog)) sm in + let env, code = compile cmd (new env sm cmd#topname) (fst (fst prog)) sm in let globals = List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) env#publics in @@ -810,7 +825,7 @@ let genasm cmd prog = Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size)] @ (List.concat @@ List.map - (fun s -> [Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" (String.sub s (String.length "global_") (String.length s - String.length "global_")) s); + (fun s -> [Meta (Printf.sprintf "\t.stabs \"%s:S1\",40,0,0,%s" (String.sub s (String.length global_label) (String.length s - String.length global_label)) s); Meta (Printf.sprintf "%s:\t.int\t1" s)]) env#globals ) diff --git a/src/X86_64.ml b/src/X86_64.ml index b502e55ce..cbf09d4e4 100644 --- a/src/X86_64.ml +++ b/src/X86_64.ml @@ -422,6 +422,13 @@ let compile_binop env op = | _ -> failwith (Printf.sprintf "Unexpected pattern: %s: %d" __FILE__ __LINE__) +let normal_label = "L" +let builtin_label = "B" +let global_label = "global_" +let labeled s = normal_label ^ s +let labeled_builtin s = builtin_label ^ s +let labeled_global s = global_label ^ s + (* For pointers to be marked by GC as alive they have to be located on the stack. As we do not have control where does the C compiler locate them in the moment of GC, we have to explicitly locate them on the stack. @@ -667,19 +674,24 @@ let compile cmd env imports code = match instr with | LABEL s -> if env#has_stack s then - (env#drop_barrier#retrieve_stack s, [ Label s ]) + (env#drop_barrier#retrieve_stack s, [ Label (env#asm_fun_name s) ]) else (env#drop_stack, []) - | FLABEL s -> (env#drop_barrier, [ Label s ]) - | SLABEL s -> (env, [ Label s ]) + | FLABEL s -> (env#drop_barrier, [ Label (env#asm_fun_name s) ]) + | SLABEL s -> (env, [ Label (env#asm_fun_name s) ]) | _ -> (env, []) else match instr with - | PUBLIC name -> (env#register_public name, []) - | EXTERN name -> (env#register_extern name, []) + | PUBLIC (name, is_fun) -> + let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + (env#register_public asm_name, []) + | EXTERN (name, is_fun) -> + let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + (env#register_extern asm_name, []) | IMPORT _ -> (env, []) | CLOSURE (name, closure) -> - let ext = if env#is_external name then E else I in - let address = M (F, ext, A, name) in + let asm_name = env#asm_fun_name name in + let ext = if env#is_external asm_name then E else I in + let address = M (F, ext, A, asm_name) in let l, env = env#allocate in let env, push_closure_code = List.fold_left @@ -752,17 +764,18 @@ let compile cmd env imports code = ] | _ -> [ Mov (v, rax); Mov (rax, I (0, x)); Mov (rax, x) ] )*) | BINOP op -> compile_binop env op - | LABEL s | FLABEL s | SLABEL s -> (env, [ Label s ]) - | JMP l -> ((env#set_stack l)#set_barrier, [ Jmp l ]) + | LABEL s | FLABEL s | SLABEL s -> (env, [ Label (env#asm_fun_name s) ]) + | JMP l -> ((env#set_stack l)#set_barrier, [ Jmp (env#asm_fun_name l) ]) | CJMP (s, l) -> let x, env = env#pop in ( env#set_stack l, - [ Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l) ] ) + [ Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_fun_name l) ] ) | BEGIN (f, nargs, nlocals, closure, _args, scopes) -> + let asm_f = env#asm_fun_name f in let _ = - let is_safepoint = List.mem f safepoint_functions in + let is_safepoint = List.mem asm_f safepoint_functions in let is_vararg = - Option.is_some @@ List.assoc_opt f vararg_functions + Option.is_some @@ List.assoc_opt asm_f vararg_functions in if is_safepoint || is_vararg then raise @@ -787,18 +800,14 @@ let compile cmd env imports code = names @ [ Meta - (Printf.sprintf "\t.stabn 192,0,0,%s-%s" scope.blab f); + (Printf.sprintf "\t.stabn 192,0,0,%s-%s" (labeled scope.blab) asm_f); ] @ sub_stabs @ [ Meta - (Printf.sprintf "\t.stabn 224,0,0,%s-%s" scope.elab f); + (Printf.sprintf "\t.stabn 224,0,0,%s-%s" (labeled scope.elab) asm_f); ] in - let name = - if f.[0] = 'L' then String.sub f 1 (String.length f - 1) - else f - in let stabs = opt_stabs env (if f = "main" then @@ -806,10 +815,10 @@ let compile cmd env imports code = else let func = [ - Meta (Printf.sprintf "\t.type %s, @function" name); + Meta (Printf.sprintf "\t.type %s, @function" asm_f); Meta - (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" name - f); + (Printf.sprintf "\t.stabs \"%s:F1\",36,0,0,%s" f + asm_f); ] in let arguments = @@ -823,13 +832,13 @@ let compile cmd env imports code = let env, check_argc = if f = cmd#topname then (env, []) else - let argc_correct_label = f ^ "_argc_correct" in + let argc_correct_label = asm_f ^ "_argc_correct" in let pat_addr, env = env#string "Function %s called with incorrect arguments count. \ Expected: %d. Actual: %d\\n" in - let name_addr, env = env#string name in + let name_addr, env = env#string f in let pat_loc, env = env#allocate in let name_loc, env = env#allocate in let expected_loc, env = env#allocate in @@ -853,7 +862,7 @@ let compile cmd env imports code = in env#assert_empty_stack; let has_closure = closure <> [] in - let env = env#enter f nargs nlocals has_closure in + let env = env#enter asm_f nargs nlocals has_closure in ( env, stabs @ [ Meta "\t.cfi_startproc" ] @@ -911,7 +920,7 @@ let compile cmd env imports code = @ if f = cmd#topname then List.map - (fun i -> Call ("init" ^ i)) + (fun i -> Call (labeled_init i)) (List.filter (fun i -> i <> "Std") imports) else [] @ check_argc ) | END -> @@ -954,7 +963,9 @@ let compile cmd env imports code = let x = env#peek in (env, [ Mov (x, rax); Jmp env#epilogue ]) | ELEM -> compile_call env ~fname:".elem" 2 false - | CALL (fname, n, tail) -> compile_call env ~fname n tail + | CALL (fname, n, tail) -> + let asm_fname = match fname.[0] with '.' -> fname | _ -> env#asm_fun_name fname in + compile_call env ~fname:asm_fname n tail | CALLC (n, tail) -> compile_call env n tail | SEXP (t, n) -> let s, env = env#allocate in @@ -1148,7 +1159,7 @@ module S = Set.Make (String) module M = Map.Make (String) (* Environment implementation *) -class env prg mode = +class env prg mode topname = let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'" in @@ -1236,6 +1247,9 @@ class env prg mode = method has_stack l = M.mem l stackmap method is_external name = S.mem name externs + (* prefixes the name for a function *) + method asm_fun_name name = if name = topname then name else labeled name + (* gets a location for a variable *) method loc x = match x with @@ -1244,8 +1258,9 @@ class env prg mode = let ext = if self#is_external name then E else I in M (D, ext, V, loc_name) | Value.Fun name -> - let ext = if self#is_external name then E else I in - M (F, ext, A, name) + let asm_name = self#asm_fun_name name in + let ext = if self#is_external asm_name then E else I in + M (F, ext, A, asm_name) | Value.Local i -> S i | Value.Arg i when i < argument_registers_size -> argument_registers.(i) | Value.Arg i -> S (-(i - argument_registers_size) - 1) @@ -1410,7 +1425,7 @@ class env prg mode = let genasm cmd prog = let mode = { is_debug = cmd#is_debug; target_os = cmd#target_os } in let sm = SM.compile cmd prog in - let env, code = compile cmd (new env sm mode) (fst (fst prog)) sm in + let env, code = compile cmd (new env sm mode cmd#topname) (fst (fst prog)) sm in let globals = List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" (env#prefixed s))) From c68cb1e28667fdb36abc71dbe7c0d03d6739c85d Mon Sep 17 00:00:00 2001 From: ancavar Date: Thu, 26 Feb 2026 19:56:59 +0300 Subject: [PATCH 2/6] clarify name --- src/X86_32.ml | 28 ++++++++++++++-------------- src/X86_64.ml | 28 ++++++++++++++-------------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/src/X86_32.ml b/src/X86_32.ml index 7e0b1e8db..0fcf53770 100644 --- a/src/X86_32.ml +++ b/src/X86_32.ml @@ -190,7 +190,7 @@ let compile cmd env imports code = let call env f n tail = let tail = tail && env#nargs = n && f.[0] <> '.' in let f = - match f.[0] with '.' -> labeled_builtin (String.sub f 1 (String.length f - 1)) | _ -> env#asm_fun_name f + match f.[0] with '.' -> labeled_builtin (String.sub f 1 (String.length f - 1)) | _ -> env#asm_name f in if tail then ( @@ -237,22 +237,22 @@ let compile cmd env imports code = let env', code' = if env#is_barrier then match instr with - | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label (env#asm_fun_name s)] else env#drop_stack, [] - | FLABEL s -> env#drop_barrier, [Label (env#asm_fun_name s)] - | SLABEL s -> env, [Label (env#asm_fun_name s)] + | LABEL s -> if env#has_stack s then (env#drop_barrier)#retrieve_stack s, [Label (env#asm_name s)] else env#drop_stack, [] + | FLABEL s -> env#drop_barrier, [Label (env#asm_name s)] + | SLABEL s -> env, [Label (env#asm_name s)] | _ -> env, [] else match instr with | PUBLIC (name, is_fun) -> - let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + let asm_name = if is_fun then env#asm_name name else labeled_global name in env#register_public asm_name, [] | EXTERN (name, is_fun) -> - let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + let asm_name = if is_fun then env#asm_name name else labeled_global name in env#register_extern asm_name, [] | IMPORT _name -> env, [] | CLOSURE (name, closure) -> - let asm_name = env#asm_fun_name name in + let asm_name = env#asm_name name in let pushr, popr = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) in @@ -407,16 +407,16 @@ let compile cmd env imports code = | LABEL s | FLABEL s - | SLABEL s -> env, [Label (env#asm_fun_name s)] + | SLABEL s -> env, [Label (env#asm_name s)] - | JMP l -> (env#set_stack l)#set_barrier, [Jmp (env#asm_fun_name l)] + | JMP l -> (env#set_stack l)#set_barrier, [Jmp (env#asm_name l)] | CJMP (s, l) -> let x, env = env#pop in - env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_fun_name l)] + env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_name l)] | BEGIN (f, nargs, nlocals, closure, args, scopes) -> - let asm_f = env#asm_fun_name f in + let asm_f = env#asm_name f in let rec stabs_scope scope = let names = List.map @@ -661,14 +661,14 @@ class env prg topname = method has_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) M.mem l stackmap - (* prefixes the name for a function *) - method asm_fun_name name = if name = topname then name else labeled name + (* prefixes a function name or a label *) + method asm_name name = if name = topname then name else labeled name (* gets a name for a global variable *) method loc x = match x with | Value.Global name -> M (labeled_global name) - | Value.Fun name -> M ("$" ^ self#asm_fun_name name) + | Value.Fun name -> M ("$" ^ self#asm_name name) | Value.Local i -> S i | Value.Arg i -> S (- (i + if has_closure then 2 else 1)) | Value.Access i -> I (word_size * (i+1), edx) diff --git a/src/X86_64.ml b/src/X86_64.ml index cbf09d4e4..d24781c9f 100644 --- a/src/X86_64.ml +++ b/src/X86_64.ml @@ -674,22 +674,22 @@ let compile cmd env imports code = match instr with | LABEL s -> if env#has_stack s then - (env#drop_barrier#retrieve_stack s, [ Label (env#asm_fun_name s) ]) + (env#drop_barrier#retrieve_stack s, [ Label (env#asm_name s) ]) else (env#drop_stack, []) - | FLABEL s -> (env#drop_barrier, [ Label (env#asm_fun_name s) ]) - | SLABEL s -> (env, [ Label (env#asm_fun_name s) ]) + | FLABEL s -> (env#drop_barrier, [ Label (env#asm_name s) ]) + | SLABEL s -> (env, [ Label (env#asm_name s) ]) | _ -> (env, []) else match instr with | PUBLIC (name, is_fun) -> - let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + let asm_name = if is_fun then env#asm_name name else labeled_global name in (env#register_public asm_name, []) | EXTERN (name, is_fun) -> - let asm_name = if is_fun then env#asm_fun_name name else labeled_global name in + let asm_name = if is_fun then env#asm_name name else labeled_global name in (env#register_extern asm_name, []) | IMPORT _ -> (env, []) | CLOSURE (name, closure) -> - let asm_name = env#asm_fun_name name in + let asm_name = env#asm_name name in let ext = if env#is_external asm_name then E else I in let address = M (F, ext, A, asm_name) in let l, env = env#allocate in @@ -764,14 +764,14 @@ let compile cmd env imports code = ] | _ -> [ Mov (v, rax); Mov (rax, I (0, x)); Mov (rax, x) ] )*) | BINOP op -> compile_binop env op - | LABEL s | FLABEL s | SLABEL s -> (env, [ Label (env#asm_fun_name s) ]) - | JMP l -> ((env#set_stack l)#set_barrier, [ Jmp (env#asm_fun_name l) ]) + | LABEL s | FLABEL s | SLABEL s -> (env, [ Label (env#asm_name s) ]) + | JMP l -> ((env#set_stack l)#set_barrier, [ Jmp (env#asm_name l) ]) | CJMP (s, l) -> let x, env = env#pop in ( env#set_stack l, - [ Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_fun_name l) ] ) + [ Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, env#asm_name l) ] ) | BEGIN (f, nargs, nlocals, closure, _args, scopes) -> - let asm_f = env#asm_fun_name f in + let asm_f = env#asm_name f in let _ = let is_safepoint = List.mem asm_f safepoint_functions in let is_vararg = @@ -964,7 +964,7 @@ let compile cmd env imports code = (env, [ Mov (x, rax); Jmp env#epilogue ]) | ELEM -> compile_call env ~fname:".elem" 2 false | CALL (fname, n, tail) -> - let asm_fname = match fname.[0] with '.' -> fname | _ -> env#asm_fun_name fname in + let asm_fname = match fname.[0] with '.' -> fname | _ -> env#asm_name fname in compile_call env ~fname:asm_fname n tail | CALLC (n, tail) -> compile_call env n tail | SEXP (t, n) -> @@ -1247,8 +1247,8 @@ class env prg mode topname = method has_stack l = M.mem l stackmap method is_external name = S.mem name externs - (* prefixes the name for a function *) - method asm_fun_name name = if name = topname then name else labeled name + (* prefixes a function name or a label *) + method asm_name name = if name = topname then name else labeled name (* gets a location for a variable *) method loc x = @@ -1258,7 +1258,7 @@ class env prg mode topname = let ext = if self#is_external name then E else I in M (D, ext, V, loc_name) | Value.Fun name -> - let asm_name = self#asm_fun_name name in + let asm_name = self#asm_name name in let ext = if self#is_external asm_name then E else I in M (F, ext, A, asm_name) | Value.Local i -> S i From 8ff71be3de811517ed35503bda3f5e249eb26b0d Mon Sep 17 00:00:00 2001 From: ancavar Date: Fri, 27 Feb 2026 19:38:11 +0300 Subject: [PATCH 3/6] fix --- src/Options.ml | 2 +- src/SM.ml | 16 ++++++---------- src/X86_32.ml | 23 +++++++++++++++++------ 3 files changed, 24 insertions(+), 17 deletions(-) diff --git a/src/Options.ml b/src/Options.ml index fa655ed48..3823786bd 100644 --- a/src/Options.ml +++ b/src/Options.ml @@ -2,7 +2,7 @@ exception Commandline_error of string type os_t = Linux | Darwin -let init_label = "_init" +let init_label = "Init" let labeled_init s = init_label ^ s class options args = diff --git a/src/SM.ml b/src/SM.ml index 7ad520238..cb90393f4 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -14,7 +14,7 @@ type scope = { } [@@deriving gt ~options:{ show }] -let labeled_scoped i s = s ^ "_" ^ string_of_int i +let scoped i s = s ^ "_" ^ string_of_int i let show_scope = show scope (* The type for the stack machine instructions *) @@ -175,7 +175,6 @@ module ByteCode = struct let globals = Stdlib.ref M.empty in let glob_count = Stdlib.ref 0 in let fixups = Stdlib.ref [] in - let func_fixups = Stdlib.ref [] in let add_lab l = lmap := M.add l (Buffer.length code) !lmap in let add_public name is_fun = let flag = if is_fun then pub_flag_function else pub_flag_global in @@ -183,7 +182,6 @@ module ByteCode = struct in let add_import l = imports := S.add l !imports in let add_fixup l = fixups := (Buffer.length code, l) :: !fixups in - let add_func_fixup l = func_fixups := (Buffer.length code, l) :: !func_fixups in let add_bytes = List.iter (fun x -> Buffer.add_char code @@ Char.chr x) in let add_ints = List.iter (fun x -> Buffer.add_int32_ne code @@ Int32.of_int x) @@ -274,13 +272,13 @@ module ByteCode = struct add_fixup s; add_ints [ 0 ] (* 0x70 *) - | CALL (f, _, _) when f = "read" -> add_bytes [ (7 * 16) + 0 ] + | CALL ("read", _, _) -> add_bytes [ (7 * 16) + 0 ] (* 0x71 *) - | CALL (f, _, _) when f = "write" -> add_bytes [ (7 * 16) + 1 ] + | CALL ("write", _, _) -> add_bytes [ (7 * 16) + 1 ] (* 0x72 *) - | CALL (f, _, _) when f = "length" -> add_bytes [ (7 * 16) + 2 ] + | CALL ("length", _, _) -> add_bytes [ (7 * 16) + 2 ] (* 0x73 *) - | CALL (f, _, _) when f = "string" -> add_bytes [ (7 * 16) + 3 ] + | CALL ("string", _, _) -> add_bytes [ (7 * 16) + 3 ] (* 0x74 *) | CALL (".array", n, _) -> add_bytes [ (7 * 16) + 4 ]; @@ -296,7 +294,6 @@ module ByteCode = struct (* 0x54 l:32 n:32 d*:32 *) | CLOSURE (s, ds) -> add_bytes [ (5 * 16) + 4 ]; - add_func_fixup s; add_ints [ 0; List.length ds ]; add_designations None ds (* 0x55 n:32 *) @@ -306,7 +303,6 @@ module ByteCode = struct (* 0x56 l:32 n:32 *) | CALL (fn, n, _) -> add_bytes [ (5 * 16) + 6 ]; - add_func_fixup fn; add_ints [ 0; n ] (* 0x57 s:32 n:32 *) | TAG (s, n) -> @@ -1198,7 +1194,7 @@ class env cmd imports = method fun_internal_name (name : string) = match scope.st with | State.G _ -> name - | _ -> labeled_scoped scope_index name + | _ -> scoped scope_index name method add_fun_name (name : string) (m : [ `Local | `Extern | `Public | `PublicExtern ]) = diff --git a/src/X86_32.ml b/src/X86_32.ml index 0fcf53770..16be44f19 100644 --- a/src/X86_32.ml +++ b/src/X86_32.ml @@ -279,7 +279,7 @@ let compile cmd env imports code = let s, env = env#string s in let l, env = env#allocate in let env, call = call env ".string" 1 false in - (env, Mov (M ("$" ^ s), l) :: call) + (env, Mov (s, l) :: call) | LDA x -> let s, env' = (env #variable x)#allocate in @@ -552,9 +552,20 @@ let compile cmd env imports code = env#gen_line line | FAIL ((line, col), value) -> - let v, env = if value then env#peek, env else env#pop in - let s, env = env#string cmd#get_infile in - env, [Push (L (box col)); Push (L (box line)); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop ("+", L (4 * word_size), esp)] + let value, env = if value then (env#peek, env) else env#pop in + let msg_addr, env = env#string cmd#get_infile in + let value_arg_addr, env = env#allocate in + let msg_arg_addr, env = env#allocate in + let line_arg_addr, env = env#allocate in + let col_arg_addr, env = env#allocate in + let env, code = + call env ".match_failure" 4 false + in + let _, env = env#pop in + ( env, + mov (L (box col)) col_arg_addr @ mov (L (box line)) line_arg_addr + @ mov msg_addr msg_arg_addr @ mov value value_arg_addr @ code + ) | i -> invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) @@ -757,11 +768,11 @@ class env prg topname = Buffer.contents buf in let x = escape x in - try M.find x stringm, self + try M ("$" ^ M.find x stringm), self with Not_found -> let y = Printf.sprintf "string_%d" scount in let m = M.add x y stringm in - y, {< scount = scount + 1; stringm = m>} + M ("$" ^ y), {< scount = scount + 1; stringm = m>} (* gets number of arguments in the current function *) method nargs = nargs From b96bc33157d694a7c2f3661dfc922a247baf7735 Mon Sep 17 00:00:00 2001 From: ancavar Date: Sat, 28 Feb 2026 22:28:28 +0300 Subject: [PATCH 4/6] fix --- src/SM.ml | 46 ++++++++++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 20 deletions(-) diff --git a/src/SM.ml b/src/SM.ml index cb90393f4..34463e32c 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -169,18 +169,18 @@ module ByteCode = struct let compile cmd insns = let code = Buffer.create 256 in let st = StringTab.create () in - let lmap = Stdlib.ref M.empty in + let lmap = Hashtbl.create 32 in let pubs = Stdlib.ref [] in - let imports = Stdlib.ref S.empty in - let globals = Stdlib.ref M.empty in + let imports = Stdlib.ref [] in + let globals = Hashtbl.create 16 in let glob_count = Stdlib.ref 0 in let fixups = Stdlib.ref [] in - let add_lab l = lmap := M.add l (Buffer.length code) !lmap in + let add_lab l = Hashtbl.replace lmap l (Buffer.length code) in let add_public name is_fun = let flag = if is_fun then pub_flag_function else pub_flag_global in pubs := (name, flag) :: !pubs in - let add_import l = imports := S.add l !imports in + let add_import l = imports := l :: !imports in let add_fixup l = fixups := (Buffer.length code, l) :: !fixups in let add_bytes = List.iter (fun x -> Buffer.add_char code @@ Char.chr x) in let add_ints = @@ -195,11 +195,11 @@ module ByteCode = struct List.iter (function | Value.Global s -> let i = - try M.find s !globals + try Hashtbl.find globals s with Not_found -> let i = !glob_count in incr glob_count; - globals := M.add s i !globals; + Hashtbl.add globals s i; i in add_bytes [ b 0 ]; @@ -294,6 +294,7 @@ module ByteCode = struct (* 0x54 l:32 n:32 d*:32 *) | CLOSURE (s, ds) -> add_bytes [ (5 * 16) + 4 ]; + add_fixup s; add_ints [ 0; List.length ds ]; add_designations None ds (* 0x55 n:32 *) @@ -303,6 +304,7 @@ module ByteCode = struct (* 0x56 l:32 n:32 *) | CALL (fn, n, _) -> add_bytes [ (5 * 16) + 6 ]; + add_fixup fn; add_ints [ 0; n ] (* 0x57 s:32 n:32 *) | TAG (s, n) -> @@ -338,32 +340,36 @@ module ByteCode = struct Bytes.set_int32_ne code ofs (Int32.of_int @@ - try M.find l !lmap + try Hashtbl.find lmap l with Not_found -> failwith (Printf.sprintf "ERROR: undefined label '%s'" l))) !fixups; - let pubs = - List.map (fun (name, flag) -> - ( Int32.of_int @@ StringTab.add st name, - Int32.of_int - @@ - (try M.find name !lmap - with Not_found -> - failwith (Printf.sprintf "ERROR: undefined label of public '%s'" name)), - flag )) - @@ List.rev !pubs + let pubs_resolved = + List.rev_map (fun (name, flag) -> + let pos = + if flag = pub_flag_global then + try Hashtbl.find globals name + with Not_found -> + failwith (Printf.sprintf "ERROR: undefined global variable '%s'" name) + else + try Hashtbl.find lmap name + with Not_found -> + failwith (Printf.sprintf "ERROR: undefined label of public '%s'" name) + in + (Int32.of_int @@ StringTab.add st name, Int32.of_int pos, flag)) + !pubs in let st = Buffer.to_bytes st.StringTab.buffer in let file = Buffer.create 1024 in Buffer.add_int32_ne file (Int32.of_int @@ Bytes.length st); Buffer.add_int32_ne file (Int32.of_int @@ !glob_count); - Buffer.add_int32_ne file (Int32.of_int @@ List.length pubs); + Buffer.add_int32_ne file (Int32.of_int @@ List.length pubs_resolved); List.iter (fun (n, o, f) -> Buffer.add_int32_ne file n; Buffer.add_int32_ne file o; Buffer.add_uint8 file f) - pubs; + pubs_resolved; Buffer.add_bytes file st; Buffer.add_bytes file code; let f = open_out_bin (Printf.sprintf "%s.bc" cmd#basename) in From a02991132005390f31fbd169f6c497ab90d24134 Mon Sep 17 00:00:00 2001 From: ancavar Date: Mon, 2 Mar 2026 03:36:51 +0300 Subject: [PATCH 5/6] rollback --- src/X86_32.ml | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/src/X86_32.ml b/src/X86_32.ml index 16be44f19..a66f89860 100644 --- a/src/X86_32.ml +++ b/src/X86_32.ml @@ -552,20 +552,9 @@ let compile cmd env imports code = env#gen_line line | FAIL ((line, col), value) -> - let value, env = if value then (env#peek, env) else env#pop in - let msg_addr, env = env#string cmd#get_infile in - let value_arg_addr, env = env#allocate in - let msg_arg_addr, env = env#allocate in - let line_arg_addr, env = env#allocate in - let col_arg_addr, env = env#allocate in - let env, code = - call env ".match_failure" 4 false - in - let _, env = env#pop in - ( env, - mov (L (box col)) col_arg_addr @ mov (L (box line)) line_arg_addr - @ mov msg_addr msg_arg_addr @ mov value value_arg_addr @ code - ) + let v, env = if value then env#peek, env else env#pop in + let s, env = env#string cmd#get_infile in + env, [Push (L (box col)); Push (L (box line)); Push s; Push v; Call "Bmatch_failure"; Binop ("+", L (4 * word_size), esp)] | i -> invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) From 5a97d706e5a59524ecfdc555bb0218af0205db19 Mon Sep 17 00:00:00 2001 From: ancavar Date: Thu, 12 Mar 2026 21:00:21 +0300 Subject: [PATCH 6/6] update `byterun.c` to the new format --- byterun/byterun.c | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/byterun/byterun.c b/byterun/byterun.c index 00b74e4aa..adb86afb9 100644 --- a/byterun/byterun.c +++ b/byterun/byterun.c @@ -13,7 +13,7 @@ void *__stop_custom_data; typedef struct { char *string_ptr; /* A pointer to the beginning of the string table */ - int *public_ptr; /* A pointer to the beginning of publics table */ + char *public_ptr; /* A pointer to the beginning of publics table */ char *code_ptr; /* A pointer to the bytecode itself */ int *global_ptr; /* A pointer to the global area */ int stringtab_size; /* The size (in bytes) of the string table */ @@ -28,16 +28,25 @@ char *get_string(bytefile *f, int pos) return &f->string_ptr[pos]; } +/* Each public symbol entry: int32 name_offset, int32 code_offset, uint8 flag */ +#define PUBLIC_ENTRY_SIZE 9 + /* Gets a name for a public symbol */ char *get_public_name(bytefile *f, int i) { - return get_string(f, f->public_ptr[i * 2]); + return get_string(f, *(int *)(f->public_ptr + i * PUBLIC_ENTRY_SIZE)); } -/* Gets an offset for a publie symbol */ +/* Gets an offset for a public symbol */ int get_public_offset(bytefile *f, int i) { - return f->public_ptr[i * 2 + 1]; + return *(int *)(f->public_ptr + i * PUBLIC_ENTRY_SIZE + sizeof(int)); +} + +/* Gets a flag for a public symbol (0 = function, 1 = global) */ +char get_public_flag(bytefile *f, int i) +{ + return f->public_ptr[i * PUBLIC_ENTRY_SIZE + 2 * sizeof(int)]; } /* Reads a binary bytecode file by name and unpacks it */ @@ -57,7 +66,7 @@ bytefile *read_file(char *fname) failure("%s\n", strerror(errno)); } - file = (bytefile *)malloc(sizeof(int) * 4 + (size = ftell(f))); + file = (bytefile *)malloc(sizeof(void *) * 4 + (size = ftell(f))); if (file == 0) { @@ -73,8 +82,8 @@ bytefile *read_file(char *fname) fclose(f); - file->string_ptr = &file->buffer[file->public_symbols_number * 2 * sizeof(int)]; - file->public_ptr = (int *)file->buffer; + file->string_ptr = &file->buffer[file->public_symbols_number * PUBLIC_ENTRY_SIZE]; + file->public_ptr = file->buffer; file->code_ptr = &file->string_ptr[file->stringtab_size]; file->global_ptr = (int *)malloc(file->global_area_size * sizeof(int)); @@ -281,23 +290,23 @@ void disassemble(FILE *f, bytefile *bf) switch (l) { case 0: - fprintf(f, "CALL\tLread"); + fprintf(f, "CALL\tread"); break; case 1: - fprintf(f, "CALL\tLwrite"); + fprintf(f, "CALL\twrite"); break; case 2: - fprintf(f, "CALL\tLlength"); + fprintf(f, "CALL\tlength"); break; case 3: - fprintf(f, "CALL\tLstring"); + fprintf(f, "CALL\tstring"); break; case 4: - fprintf(f, "CALL\tBarray\t%d", INT); + fprintf(f, "CALL\t.array\t%d", INT); break; default: @@ -327,7 +336,8 @@ void dump_file(FILE *f, bytefile *bf) fprintf(f, "Public symbols :\n"); for (i = 0; i < bf->public_symbols_number; i++) - fprintf(f, " 0x%.8x: %s\n", get_public_offset(bf, i), get_public_name(bf, i)); + fprintf(f, " 0x%.8x: %s (%s)\n", get_public_offset(bf, i), get_public_name(bf, i), + get_public_flag(bf, i) == 0 ? "function" : "global"); fprintf(f, "Code:\n"); disassemble(f, bf);