Skip to content

Commit 64e005f

Browse files
hhugohhugo
committed
WIP
1 parent bbf35fc commit 64e005f

26 files changed

+974
-879
lines changed

‎compiler/bin-js_of_ocaml/compile.ml

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -162,12 +162,11 @@ let run
162162
let var_k = Code.Var.fresh () in
163163
let var_v = Code.Var.fresh () in
164164
Code.
165-
[ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ]), -1)
166-
; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ]), -1)
167-
; Let
168-
( Var.fresh ()
169-
, Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ])
170-
, -1 )
165+
[ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ])), noloc
166+
; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ])), noloc
167+
; ( Let
168+
(Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
169+
, noloc )
171170
])
172171
in
173172
let output (one : Parse_bytecode.one) ~source_map ~linkall ~standalone output_file =

‎compiler/lib/code.ml

Lines changed: 61 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -326,7 +326,10 @@ let rec constant_equal a b =
326326
| Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
327327
Some false
328328

329-
type loc = Addr.t
329+
type loc =
330+
| No
331+
| Before of Addr.t
332+
| After of Addr.t
330333

331334
type prim_arg =
332335
| Pv of Var.t
@@ -345,26 +348,26 @@ type expr =
345348
| Prim of prim * prim_arg list
346349

347350
type instr =
348-
| Let of Var.t * expr * loc
349-
| Assign of Var.t * Var.t * loc
350-
| Set_field of Var.t * int * Var.t * loc
351-
| Offset_ref of Var.t * int * loc
352-
| Array_set of Var.t * Var.t * Var.t * loc
351+
| Let of Var.t * expr
352+
| Assign of Var.t * Var.t
353+
| Set_field of Var.t * int * Var.t
354+
| Offset_ref of Var.t * int
355+
| Array_set of Var.t * Var.t * Var.t
353356

354357
type last =
355-
| Return of Var.t * loc
356-
| Raise of Var.t * [ `Normal | `Notrace | `Reraise ] * loc
357-
| Stop of loc
358+
| Return of Var.t
359+
| Raise of Var.t * [ `Normal | `Notrace | `Reraise ]
360+
| Stop
358361
| Branch of cont
359-
| Cond of Var.t * cont * cont * loc
360-
| Switch of Var.t * cont array * cont array * loc
361-
| Pushtrap of cont * Var.t * cont * Addr.Set.t * loc
362+
| Cond of Var.t * cont * cont
363+
| Switch of Var.t * cont array * cont array
364+
| Pushtrap of cont * Var.t * cont * Addr.Set.t
362365
| Poptrap of cont
363366

364367
type block =
365368
{ params : Var.t list
366-
; body : instr list
367-
; branch : last
369+
; body : (instr * loc) list
370+
; branch : last * loc
368371
}
369372

370373
type program =
@@ -373,6 +376,9 @@ type program =
373376
; free_pc : Addr.t
374377
}
375378

379+
let noloc = No
380+
381+
let location_of_pc pc = Before pc
376382
(****)
377383

378384
module Print = struct
@@ -480,31 +486,31 @@ module Print = struct
480486
| Constant c -> Format.fprintf f "CONST{%a}" constant c
481487
| Prim (p, l) -> prim f p l
482488

483-
let instr f i =
489+
let instr f (i, _loc) =
484490
match i with
485-
| Let (x, e, _) -> Format.fprintf f "%a = %a" Var.print x expr e
486-
| Assign (x, y, _) -> Format.fprintf f "(assign) %a = %a" Var.print x Var.print y
487-
| Set_field (x, i, y, _) -> Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y
488-
| Offset_ref (x, i, _) -> Format.fprintf f "%a[0] += %d" Var.print x i
489-
| Array_set (x, y, z, _) ->
491+
| Let (x, e) -> Format.fprintf f "%a = %a" Var.print x expr e
492+
| Assign (x, y) -> Format.fprintf f "(assign) %a = %a" Var.print x Var.print y
493+
| Set_field (x, i, y) -> Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y
494+
| Offset_ref (x, i) -> Format.fprintf f "%a[0] += %d" Var.print x i
495+
| Array_set (x, y, z) ->
490496
Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z
491497

492-
let last f l =
498+
let last f (l, _loc) =
493499
match l with
494-
| Return (x, _) -> Format.fprintf f "return %a" Var.print x
495-
| Raise (x, `Normal, _) -> Format.fprintf f "raise %a" Var.print x
496-
| Raise (x, `Reraise, _) -> Format.fprintf f "reraise %a" Var.print x
497-
| Raise (x, `Notrace, _) -> Format.fprintf f "raise_notrace %a" Var.print x
498-
| Stop _ -> Format.fprintf f "stop"
500+
| Return x -> Format.fprintf f "return %a" Var.print x
501+
| Raise (x, `Normal) -> Format.fprintf f "raise %a" Var.print x
502+
| Raise (x, `Reraise) -> Format.fprintf f "reraise %a" Var.print x
503+
| Raise (x, `Notrace) -> Format.fprintf f "raise_notrace %a" Var.print x
504+
| Stop -> Format.fprintf f "stop"
499505
| Branch c -> Format.fprintf f "branch %a" cont c
500-
| Cond (x, cont1, cont2, _) ->
506+
| Cond (x, cont1, cont2) ->
501507
Format.fprintf f "if %a then %a else %a" Var.print x cont cont1 cont cont2
502-
| Switch (x, a1, a2, _) ->
508+
| Switch (x, a1, a2) ->
503509
Format.fprintf f "switch %a {" Var.print x;
504510
Array.iteri a1 ~f:(fun i c -> Format.fprintf f "int %d -> %a; " i cont c);
505511
Array.iteri a2 ~f:(fun i c -> Format.fprintf f "tag %d -> %a; " i cont c);
506512
Format.fprintf f "}"
507-
| Pushtrap (cont1, x, cont2, pcs, _) ->
513+
| Pushtrap (cont1, x, cont2, pcs) ->
508514
Format.fprintf
509515
f
510516
"pushtrap %a handler %a => %a continuation %s"
@@ -518,8 +524,8 @@ module Print = struct
518524
| Poptrap c -> Format.fprintf f "poptrap %a" cont c
519525

520526
type xinstr =
521-
| Instr of instr
522-
| Last of last
527+
| Instr of (instr * loc)
528+
| Last of (last * loc)
523529

524530
let block annot pc block =
525531
Format.eprintf "==== %d (%a) ====@." pc var_list block.params;
@@ -538,9 +544,9 @@ end
538544
let fold_closures p f accu =
539545
Addr.Map.fold
540546
(fun _ block accu ->
541-
List.fold_left block.body ~init:accu ~f:(fun accu i ->
547+
List.fold_left block.body ~init:accu ~f:(fun accu (i, _loc) ->
542548
match i with
543-
| Let (x, Closure (params, cont), _) -> f (Some x) params cont accu
549+
| Let (x, Closure (params, cont)) -> f (Some x) params cont accu
544550
| _ -> accu))
545551
p.blocks
546552
(f None [] (p.start, []) accu)
@@ -559,12 +565,12 @@ let prepend ({ start; blocks; free_pc } as p) body =
559565
| exception Not_found ->
560566
let new_start = free_pc in
561567
let blocks =
562-
Addr.Map.add new_start { params = []; body; branch = Stop (-1) } blocks
568+
Addr.Map.add new_start { params = []; body; branch = Stop, noloc } blocks
563569
in
564570
let free_pc = free_pc + 1 in
565571
{ start = new_start; blocks; free_pc })
566572

567-
let empty_block = { params = []; body = []; branch = Stop (-1) }
573+
let empty_block = { params = []; body = []; branch = Stop, noloc }
568574

569575
let empty =
570576
let start = 0 in
@@ -577,28 +583,28 @@ let is_empty p =
577583
| 1 -> (
578584
let _, v = Addr.Map.choose p.blocks in
579585
match v with
580-
| { body; branch = Stop _; params = _ } -> (
586+
| { body; branch = Stop, _; params = _ } -> (
581587
match body with
582-
| ([] | [ Let (_, Prim (Extern "caml_get_global_data", _), _) ]) when true ->
588+
| ([] | [ (Let (_, Prim (Extern "caml_get_global_data", _)), _) ]) when true ->
583589
true
584590
| _ -> false)
585591
| _ -> false)
586592
| _ -> false
587593

588594
let fold_children blocks pc f accu =
589595
let block = Addr.Map.find pc blocks in
590-
match block.branch with
591-
| Return _ | Raise _ | Stop _ -> accu
596+
match fst block.branch with
597+
| Return _ | Raise _ | Stop -> accu
592598
| Branch (pc', _) | Poptrap (pc', _) -> f pc' accu
593-
| Pushtrap ((pc', _), _, (pc_h, _), _, _) ->
599+
| Pushtrap ((pc', _), _, (pc_h, _), _) ->
594600
let accu = f pc' accu in
595601
let accu = f pc_h accu in
596602
accu
597-
| Cond (_, (pc1, _), (pc2, _), _) ->
603+
| Cond (_, (pc1, _), (pc2, _)) ->
598604
let accu = f pc1 accu in
599605
let accu = f pc2 accu in
600606
accu
601-
| Switch (_, a1, a2, _) ->
607+
| Switch (_, a1, a2) ->
602608
let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a1 in
603609
let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a2 in
604610
accu
@@ -651,7 +657,7 @@ let fold_closures_innermost_first { start; blocks; _ } f accu =
651657
let block = Addr.Map.find pc blocks in
652658
List.fold_left block.body ~init:accu ~f:(fun accu i ->
653659
match i with
654-
| Let (x, Closure (params, cont), _) ->
660+
| Let (x, Closure (params, cont)), _ ->
655661
let accu = visit blocks (fst cont) f accu in
656662
f (Some x) params cont accu
657663
| _ -> accu))
@@ -707,27 +713,29 @@ let invariant { blocks; start; _ } =
707713
| Constant _ -> ()
708714
| Prim (_, _) -> ()
709715
in
710-
let check_instr = function
711-
| Let (x, e, _) ->
716+
let check_instr (i, _loc) =
717+
match i with
718+
| Let (x, e) ->
712719
define x;
713720
check_expr e
714721
| Assign _ -> ()
715-
| Set_field (_, _i, _, _) -> ()
716-
| Offset_ref (_x, _i, _) -> ()
717-
| Array_set (_x, _y, _z, _) -> ()
722+
| Set_field (_, _i, _) -> ()
723+
| Offset_ref (_x, _i) -> ()
724+
| Array_set (_x, _y, _z) -> ()
718725
in
719-
let check_last = function
726+
let check_last (l, _loc) =
727+
match l with
720728
| Return _ -> ()
721729
| Raise _ -> ()
722-
| Stop _ -> ()
730+
| Stop -> ()
723731
| Branch cont -> check_cont cont
724-
| Cond (_x, cont1, cont2, _) ->
732+
| Cond (_x, cont1, cont2) ->
725733
check_cont cont1;
726734
check_cont cont2
727-
| Switch (_x, a1, a2, _) ->
735+
| Switch (_x, a1, a2) ->
728736
Array.iteri a1 ~f:(fun _ cont -> check_cont cont);
729737
Array.iteri a2 ~f:(fun _ cont -> check_cont cont)
730-
| Pushtrap (cont1, _x, cont2, _pcs, _) ->
738+
| Pushtrap (cont1, _x, cont2, _pcs) ->
731739
check_cont cont1;
732740
check_cont cont2
733741
| Poptrap cont -> check_cont cont

‎compiler/lib/code.mli

Lines changed: 26 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -163,7 +163,14 @@ type constant =
163163

164164
val constant_equal : constant -> constant -> bool option
165165

166-
type loc = Addr.t
166+
type loc =
167+
| No
168+
| Before of Addr.t
169+
| After of Addr.t
170+
171+
val noloc : loc
172+
173+
val location_of_pc : int -> loc
167174

168175
type prim_arg =
169176
| Pv of Var.t
@@ -182,26 +189,26 @@ type expr =
182189
| Prim of prim * prim_arg list
183190

184191
type instr =
185-
| Let of Var.t * expr * loc
186-
| Assign of Var.t * Var.t * loc
187-
| Set_field of Var.t * int * Var.t * loc
188-
| Offset_ref of Var.t * int * loc
189-
| Array_set of Var.t * Var.t * Var.t * loc
192+
| Let of Var.t * expr
193+
| Assign of Var.t * Var.t
194+
| Set_field of Var.t * int * Var.t
195+
| Offset_ref of Var.t * int
196+
| Array_set of Var.t * Var.t * Var.t
190197

191198
type last =
192-
| Return of Var.t * loc
193-
| Raise of Var.t * [ `Normal | `Notrace | `Reraise ] * loc
194-
| Stop of loc
199+
| Return of Var.t
200+
| Raise of Var.t * [ `Normal | `Notrace | `Reraise ]
201+
| Stop
195202
| Branch of cont
196-
| Cond of Var.t * cont * cont * loc
197-
| Switch of Var.t * cont array * cont array * loc
198-
| Pushtrap of cont * Var.t * cont * Addr.Set.t * loc
203+
| Cond of Var.t * cont * cont
204+
| Switch of Var.t * cont array * cont array
205+
| Pushtrap of cont * Var.t * cont * Addr.Set.t
199206
| Poptrap of cont
200207

201208
type block =
202209
{ params : Var.t list
203-
; body : instr list
204-
; branch : last
210+
; body : (instr * loc) list
211+
; branch : last * loc
205212
}
206213

207214
type program =
@@ -212,18 +219,18 @@ type program =
212219

213220
module Print : sig
214221
type xinstr =
215-
| Instr of instr
216-
| Last of last
222+
| Instr of (instr * loc)
223+
| Last of (last * loc)
217224

218225
val var_list : Format.formatter -> Var.t list -> unit
219226

220-
val instr : Format.formatter -> instr -> unit
227+
val instr : Format.formatter -> instr * loc -> unit
221228

222229
val block : (Addr.Map.key -> xinstr -> string) -> int -> block -> unit
223230

224231
val program : (Addr.Map.key -> xinstr -> string) -> program -> unit
225232

226-
val last : Format.formatter -> last -> unit
233+
val last : Format.formatter -> last * loc -> unit
227234

228235
val cont : Format.formatter -> cont -> unit
229236
end
@@ -246,7 +253,7 @@ val traverse :
246253
val preorder_traverse :
247254
fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
248255

249-
val prepend : program -> instr list -> program
256+
val prepend : program -> (instr * loc) list -> program
250257

251258
val empty : program
252259

0 commit comments

Comments
 (0)