From 7e6470792e65782b86a777b9b64ecdf562e50605 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Sat, 11 Nov 2023 08:12:01 +0100 Subject: [PATCH] Compiler: second attemp --- compiler/lib/parse_bytecode.ml | 116 ++++++++++++++++------------ compiler/tests-compiler/inlining.ml | 10 +-- 2 files changed, 69 insertions(+), 57 deletions(-) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index c6de0d2481..ee87b889ef 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -559,6 +559,7 @@ module State = struct type elt = | Var of Var.t * loc | Dummy + | Unset let elt_to_var e = match e with @@ -568,7 +569,8 @@ module State = struct let print_elt f v = match v with | Var (x, _) -> Format.fprintf f "%a" Var.print x - | Dummy -> Format.fprintf f "???" + | Dummy -> Format.fprintf f "٭" + | Unset -> Format.fprintf f "∅" type handler = { block_pc : Addr.t @@ -618,6 +620,7 @@ module State = struct stack = (match st.accu with | Dummy -> Dummy + | Unset -> Unset | Var (x, _) -> Var (x, loc)) :: st.stack } @@ -632,6 +635,7 @@ module State = struct accu = (match List.nth st.stack n with | Dummy -> Dummy + | Unset -> Unset | Var (x, _) -> Var (x, loc)) } @@ -643,10 +647,12 @@ module State = struct List.fold_left (st.accu :: st.stack) ~init:[] ~f:(fun l e -> match e with | Var (x, _) -> x :: l - | Dummy -> l) + | Dummy | Unset -> l) let set_accu st x loc = { st with accu = Var (x, loc) } + let clear_accu st = { st with accu = Unset } + let peek n st = elt_to_var (List.nth st.stack n) let grab n st = List.map (list_start n st.stack) ~f:elt_to_var, pop n st @@ -659,20 +665,21 @@ module State = struct let assign st n = { st with stack = st_assign st.stack n st.accu } let start_function state env offset = - { state with accu = Dummy; stack = []; env; env_offset = offset; handlers = [] } + { state with accu = Unset; stack = []; env; env_offset = offset; handlers = [] } let start_block current_pc state = let stack = List.fold_right state.stack ~init:[] ~f:(fun e stack -> match e with | Dummy -> Dummy :: stack + | Unset -> Unset :: stack | Var (x, l) -> let y = Var.fork x in Var (y, l) :: stack) in let state = { state with stack; current_pc } in match state.accu with - | Dummy -> state + | Dummy | Unset -> state | Var (x, loc) -> let y, state = fresh_var state loc in Var.propagate_name x y; @@ -691,7 +698,7 @@ module State = struct | x :: _ -> x.block_pc let initial g = - { accu = Dummy + { accu = Unset ; stack = [] ; env = [||] ; env_offset = 0 @@ -855,10 +862,13 @@ let ( ||| ) x y = let rec compile_block blocks debug_data code pc state = match Addr.Map.find_opt pc !tagged_blocks with | Some old_state -> ( + (* Check that the shape of the stack is compatible with the one used to compile the block *) let rec check (xs : State.elt list) (ys : State.elt list) = match xs, ys with | Var _ :: xs, Var _ :: ys -> check xs ys | Dummy :: xs, Dummy :: ys -> check xs ys + | Unset :: _, _ -> assert false + | _, Unset :: _ -> assert false | [], [] -> () | Var _ :: _, Dummy :: _ -> assert false | Dummy :: _, Var _ :: _ -> assert false @@ -869,8 +879,10 @@ let rec compile_block blocks debug_data code pc state = match old_state.State.accu, state.State.accu with | Dummy, Dummy -> () | Var _, Var _ -> () + | Unset, Unset -> () | Var _, Dummy -> assert false - | Dummy, Var _ -> assert false) + | Dummy, Var _ -> assert false + | Unset, _ | _, Unset -> assert false) | None -> ( let limit = Blocks.next blocks pc in assert (limit > pc); @@ -881,16 +893,40 @@ let rec compile_block blocks debug_data code pc state = compile { blocks; code; limit; debug = debug_data } pc state [] in assert (not (Addr.Map.mem pc !compiled_blocks)); + (* When jumping to a block that was already compiled and the + [accu] was [Unset] for that block, we make the current accu + [Unset] *) + let adjust_state pc = + match state', Addr.Map.find_opt pc !compiled_blocks with + | _, None -> state' + | { State.accu = Var _; _ }, Some ({ State.accu = Unset; _ }, _, _) -> + State.clear_accu state' + | _ -> state' + in + let mk_cont pc = + let state = adjust_state pc in + pc, State.stack_vars state + in + let last = + match last with + | Branch (pc, _), loc -> Branch (mk_cont pc), loc + | Cond (x, (pc1, _), (pc2, _)), loc -> Cond (x, mk_cont pc1, mk_cont pc2), loc + | Poptrap (pc, _), loc -> Poptrap (mk_cont pc), loc + | Switch (x, a), loc -> + Switch (x, Array.map a ~f:(fun (pc, _) -> mk_cont pc)), loc + | (Raise _ | Return _ | Stop), _ -> last + | Pushtrap _, _ -> assert false + in compiled_blocks := Addr.Map.add pc (state, List.rev instr, last) !compiled_blocks; match fst last with - | Branch (pc', _) -> compile_block blocks debug_data code pc' state' + | Branch (pc', _) -> compile_block blocks debug_data code pc' (adjust_state pc') | Cond (_, (pc1, _), (pc2, _)) -> - compile_block blocks debug_data code pc1 state'; - compile_block blocks debug_data code pc2 state' + compile_block blocks debug_data code pc1 (adjust_state pc1); + compile_block blocks debug_data code pc2 (adjust_state pc2) | Poptrap (_, _) -> () | Switch (_, _) -> () - | Pushtrap _ -> () - | Raise _ | Return _ | Stop -> ()) + | Raise _ | Return _ | Stop -> () + | Pushtrap _ -> assert false) and compile infos pc state instrs = if debug_parser () then State.print state; @@ -909,9 +945,9 @@ and compile infos pc state instrs = instrs, (Stop, noloc), state) else ( State.name_vars state infos.debug pc; - let stack = State.stack_vars state in - if debug_parser () then Format.eprintf "Branch %d (%a) @." pc Print.var_list stack; - instrs, (Branch (pc, stack), Code.noloc), state) + if debug_parser () + then Format.eprintf "Branch %d (%a) @." pc Print.var_list (State.stack_vars state); + instrs, (Branch (pc, []), Code.noloc), state) else ( if debug_parser () then Format.eprintf "%4d " pc; State.name_vars state infos.debug pc; @@ -1224,9 +1260,7 @@ and compile infos pc state instrs = let state' = State.start_function state env 0 in let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; - (* We can't use [Dummy] here as it breaks the stack shape - invariant. *) - let _dummy, state' = State.fresh_var state' No in + let state' = State.clear_accu state' in compile_block infos.blocks infos.debug code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in @@ -1283,9 +1317,7 @@ and compile infos pc state instrs = let state' = State.start_function state env offset in let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; - (* We can't use [Dummy] here as it breaks the stack - shape invariant. *) - let _dummy, state' = State.fresh_var state' No in + let state' = State.clear_accu state' in compile_block infos.blocks infos.debug code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in @@ -1659,23 +1691,20 @@ and compile infos pc state instrs = | BRANCH -> let offset = gets code (pc + 1) in if debug_parser () then Format.printf "... (branch)@."; - instrs, (Branch (pc + offset + 1, State.stack_vars state), loc), state + instrs, (Branch (pc + offset + 1, []), loc), state | BRANCHIF -> let offset = gets code (pc + 1) in let x, loc_x = State.accu state in let loc = loc ||| loc_x in - let args = State.stack_vars state in - instrs, (Cond (x, (pc + offset + 1, args), (pc + 2, args)), loc), state + instrs, (Cond (x, (pc + offset + 1, []), (pc + 2, [])), loc), state | BRANCHIFNOT -> let offset = gets code (pc + 1) in let x, _ = State.accu state in - let args = State.stack_vars state in - instrs, (Cond (x, (pc + 2, args), (pc + offset + 1, args)), loc), state + instrs, (Cond (x, (pc + 2, []), (pc + offset + 1, [])), loc), state | SWITCH -> ( if debug_parser () then Format.printf "switch ...@."; let sz = getu code (pc + 1) in let x, _ = State.accu state in - let args = State.stack_vars state in let isize = sz land 0XFFFF in let bsize = sz lsr 16 in let base = pc + 2 in @@ -1686,13 +1715,13 @@ and compile infos pc state instrs = Array.iter bt ~f:(fun pc' -> compile_block infos.blocks infos.debug code pc' state); match isize, bsize with - | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, args)), loc), state + | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, [])), loc), state | 0, _ -> let x_tag = Var.fresh () in let instrs = (Let (x_tag, Prim (Extern "%direct_obj_tag", [ Pv x ])), loc) :: instrs in - instrs, (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, args)), loc), state + instrs, (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, [])), loc), state | _, _ -> let isint_branch = pc + 1 in let isblock_branch = pc + 2 in @@ -1725,7 +1754,7 @@ and compile infos pc state instrs = let isint_var = Var.fresh () in let instrs = (Let (isint_var, Prim (IsInt, [ Pv x ])), loc) :: instrs in ( instrs - , (Cond (isint_var, (isint_branch, args), (isblock_branch, args)), loc) + , (Cond (isint_var, (isint_branch, []), (isblock_branch, [])), loc) , state )) | BOOLNOT -> let y, _ = State.accu state in @@ -1771,7 +1800,7 @@ and compile infos pc state instrs = :: State.Dummy :: state.State.stack }; - instrs, (Branch (interm_addr, State.stack_vars state), loc), state + instrs, (Branch (interm_addr, []), loc), state | POPTRAP -> let addr = pc + 1 in let handler_addr = State.addr_of_current_handler state in @@ -1786,7 +1815,7 @@ and compile infos pc state instrs = code addr (State.pop 4 (State.pop_handler state)); - instrs, (Poptrap (addr, State.stack_vars state), loc), state + instrs, (Poptrap (addr, []), loc), state | RERAISE | RAISE_NOTRACE | RAISE -> let x, _ = State.accu state in let kind = @@ -2212,81 +2241,72 @@ and compile infos pc state instrs = let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Eq, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) + , (Cond (y, (pc + offset + 2, []), (pc + 3, [])), loc) , state ) | BNEQ -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Eq, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) + , (Cond (y, (pc + 3, []), (pc + offset + 2, [])), loc) , state ) | BLTINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Lt, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) + , (Cond (y, (pc + offset + 2, []), (pc + 3, [])), loc) , state ) | BLEINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Le, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) + , (Cond (y, (pc + offset + 2, []), (pc + 3, [])), loc) , state ) | BGTINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Le, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) + , (Cond (y, (pc + 3, []), (pc + offset + 2, [])), loc) , state ) | BGEINT -> let n = gets32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Lt, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) + , (Cond (y, (pc + 3, []), (pc + offset + 2, [])), loc) , state ) | BULTINT -> let n = getu32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in ( (Let (y, Prim (Ult, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + offset + 2, args), (pc + 3, args)), loc) + , (Cond (y, (pc + offset + 2, []), (pc + 3, [])), loc) , state ) | BUGEINT -> let n = getu32 code (pc + 1) in let offset = gets code (pc + 2) in let x, _ = State.accu state in - let args = State.stack_vars state in let y = Var.fresh () in - ( (Let (y, Prim (Ult, [ Pc (Int n); Pv x ])), loc) :: instrs - , (Cond (y, (pc + 3, args), (pc + offset + 2, args)), loc) + , (Cond (y, (pc + 3, []), (pc + offset + 2, [])), loc) , state ) | ULTINT -> let y, _ = State.accu state in diff --git a/compiler/tests-compiler/inlining.ml b/compiler/tests-compiler/inlining.ml index 2c041fb4e5..190154630f 100644 --- a/compiler/tests-compiler/inlining.ml +++ b/compiler/tests-compiler/inlining.ml @@ -24,19 +24,11 @@ let%expect_test "inline recursive function" = let rec f () = f () and g () = f () |} in - print_fun_decl program (Some "f$0"); print_fun_decl program (Some "f"); print_fun_decl program (Some "g"); [%expect {| - function f$0(counter, param){ - var _a_ = 0; - if(counter >= 50) return caml_trampoline_return(f$0, [0, _a_]); - var counter$0 = counter + 1 | 0; - return f$0(counter$0, _a_); - } - //end - function f(param){return caml_trampoline(f$0(0, param));} + function f(param){for(;;) ;} //end function g(param){return f(0);} //end |}]