Skip to content

Commit

Permalink
Compiler: second attemp
Browse files Browse the repository at this point in the history
  • Loading branch information
@hhugo
hhugo committed Nov 11, 2023
1 parent b763c20 commit 7e64707
Show file tree
Hide file tree
Showing 2 changed files with 69 additions and 57 deletions.
116 changes: 68 additions & 48 deletions compiler/lib/parse_bytecode.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -559,6 +559,7 @@ module State = struct
type elt =
| Var of Var.t * loc
| Dummy
| Unset

let elt_to_var e =
match e with
Expand All @@ -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
Expand Down Expand Up @@ -618,6 +620,7 @@ module State = struct
stack =
(match st.accu with
| Dummy -> Dummy
| Unset -> Unset
| Var (x, _) -> Var (x, loc))
:: st.stack
}
Expand All @@ -632,6 +635,7 @@ module State = struct
accu =
(match List.nth st.stack n with
| Dummy -> Dummy
| Unset -> Unset
| Var (x, _) -> Var (x, loc))
}

Expand All @@ -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
Expand All @@ -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;
Expand All @@ -691,7 +698,7 @@ module State = struct
| x :: _ -> x.block_pc

let initial g =
{ accu = Dummy
{ accu = Unset
; stack = []
; env = [||]
; env_offset = 0
Expand Down Expand Up @@ -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
Expand All @@ -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);
Expand All @@ -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;
Expand All @@ -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;
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand Down Expand Up @@ -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
Expand Down
10 changes: 1 addition & 9 deletions compiler/tests-compiler/inlining.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 |}]

0 comments on commit 7e64707

Please sign in to comment.