feat(compiler): inferred GC classification + --dump-gc (7b Phase 1)
Structural half of the inference pass, additive — it backs `woc --dump-gc` and does NOT yet feed field-kind derivation (that is Phase 2 at the Types.is_gc_class seam), so no emitted bytecode or golden changes. - compiler/src/gcinfer.ml: build the class-reference graph (edges from Scalar/Multi/Map fields, unwrapping ?; ref and backlink contribute NO edge), run Tarjan SCC, classify any class in a non-trivial SCC or with a self-loop as `gc`, else `owned`; carry a cycle-path reason. - --dump-gc mode in bin/main.ml (mirrors --dump-owner) + usage line + dune. Verified: - docs/examples/gc-cycle -> `Node gc (cycle Node -> Node)`, `Segment owned`. - docs/examples/employee -> Department/Employee both `owned` (ref/backlink make no edge, so no false cycle) — the load-bearing correctness case. - just woc-test 566/0 (goldens untouched, build clean both flavors). Remaining Phase 1: a --dump-gc golden fixture (deferred — verified manually to avoid golden-harness churn this slice). Phases 2-4 per the plan. Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
This commit is contained in:
parent
335a797479
commit
3777234cdc
3 changed files with 131 additions and 1 deletions
|
|
@ -47,6 +47,7 @@ let usage_msg =
|
|||
usage: woc --dump-tokens <path>\n\
|
||||
usage: woc --dump-ast <path>\n\
|
||||
usage: woc --dump-owner <path>\n\
|
||||
usage: woc --dump-gc <path>\n\
|
||||
usage: woc --dump-bc <path>\n\
|
||||
\n\
|
||||
Compiles writeonce (.wo) source. <path> is a single .wo file or a\n\
|
||||
|
|
@ -408,6 +409,17 @@ let dump_owner path =
|
|||
parsed;
|
||||
finish collector (build_lookup sources)
|
||||
|
||||
(* --dump-gc (iteration 7b, plan Phase 1): runs lex/parse/typecheck, then prints
|
||||
the inferred GC classification (one line per class). Additive — it does not
|
||||
change what is emitted; it exposes what the inference pass decided. *)
|
||||
let dump_gc path =
|
||||
let sources = discover_and_read path in
|
||||
let collector = Woc_lib.Diag.Collector.create () in
|
||||
let parsed = parse_all collector sources in
|
||||
let syms, _module_syms = typecheck_all collector ~root:path parsed in
|
||||
print_string (Woc_lib.Gcinfer.render (Woc_lib.Gcinfer.classify syms));
|
||||
finish collector (build_lookup sources)
|
||||
|
||||
(* The bare `woc <path>` form (Task 8): runs the full pipeline with no
|
||||
dump — check-only. Nothing is printed to stdout on success, matching
|
||||
the exit-code contract's "0 = clean compile". *)
|
||||
|
|
@ -723,6 +735,7 @@ let () =
|
|||
| [| _; "--dump-tokens"; path |] -> dump_tokens path
|
||||
| [| _; "--dump-ast"; path |] -> dump_ast path
|
||||
| [| _; "--dump-owner"; path |] -> dump_owner path
|
||||
| [| _; "--dump-gc"; path |] -> dump_gc path
|
||||
| [| _; "--dump-bc"; path |] -> dump_bc path
|
||||
| [| _; "--emit"; path; "-o"; out |] -> emit_mode path out
|
||||
| [| _; "build"; path; "-o"; out |] -> build_mode ~runtime:None path out
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@
|
|||
; OCaml stdlib only: no Menhir, no ppx, no opam libraries.
|
||||
(library
|
||||
(name woc_lib)
|
||||
(modules diag token ast lexer parser types owner emit disasm dump))
|
||||
(modules diag token ast lexer parser types gcinfer owner emit disasm dump))
|
||||
|
|
|
|||
117
compiler/src/gcinfer.ml
Normal file
117
compiler/src/gcinfer.ml
Normal file
|
|
@ -0,0 +1,117 @@
|
|||
(* gcinfer.ml — inferred GC classification (spec 2026-08-11; plan Phase 1,
|
||||
structural half).
|
||||
|
||||
Build the class-reference graph and mark every class in a non-trivial SCC,
|
||||
or with a self-loop, as traced (`gc`); everything else is `owned`. `ref B`
|
||||
is a row id (Copy) and `backlink` is a virtual inverse (recomputed by index
|
||||
scan) — neither stores a pointer, so neither contributes a graph edge, and
|
||||
neither can force a cycle.
|
||||
|
||||
Additive: this pass does not yet feed field-kind derivation (that is plan
|
||||
Phase 2, at the `Types.is_gc_class` seam), so nothing it decides changes
|
||||
emitted bytecode. It only backs the `woc --dump-gc` artifact today. *)
|
||||
|
||||
module SMap = Types.StringMap
|
||||
|
||||
(* The user-class names one field type points at — the edges out of the class
|
||||
that declares the field. Builtin scalars (Int/Bool/Text) and non-class names
|
||||
resolve to no edge. *)
|
||||
let rec refs_of_ty (classes : Types.class_info SMap.t) (t : Ast.field_ty) :
|
||||
string list =
|
||||
match t with
|
||||
| Ast.Scalar n | Ast.Multi n -> if SMap.mem n classes then [ n ] else []
|
||||
| Ast.Map (k, v) -> List.filter (fun n -> SMap.mem n classes) [ k; v ]
|
||||
| Ast.Nullable ft -> refs_of_ty classes ft
|
||||
| Ast.Ref _ | Ast.Backlink _ -> [] (* id / virtual inverse: no pointer edge *)
|
||||
|
||||
let edges (classes : Types.class_info SMap.t) (ci : Types.class_info) :
|
||||
string list =
|
||||
List.concat_map (fun (_, ft, _, _) -> refs_of_ty classes ft) ci.Types.fields
|
||||
|> List.sort_uniq compare
|
||||
|
||||
(* Tarjan's strongly-connected components over the class-name graph. Recursive;
|
||||
class graphs are tiny, so recursion depth is a non-issue. *)
|
||||
let sccs (nodes : string list) (adj : string -> string list) : string list list
|
||||
=
|
||||
let index = Hashtbl.create 64 and low = Hashtbl.create 64 in
|
||||
let onstack = Hashtbl.create 64 and stack = ref [] in
|
||||
let counter = ref 0 and out = ref [] in
|
||||
let rec strong v =
|
||||
Hashtbl.replace index v !counter;
|
||||
Hashtbl.replace low v !counter;
|
||||
incr counter;
|
||||
stack := v :: !stack;
|
||||
Hashtbl.replace onstack v true;
|
||||
List.iter
|
||||
(fun w ->
|
||||
if not (Hashtbl.mem index w) then begin
|
||||
strong w;
|
||||
Hashtbl.replace low v (min (Hashtbl.find low v) (Hashtbl.find low w))
|
||||
end
|
||||
else if Hashtbl.mem onstack w && Hashtbl.find onstack w then
|
||||
Hashtbl.replace low v (min (Hashtbl.find low v) (Hashtbl.find index w)))
|
||||
(adj v);
|
||||
if Hashtbl.find low v = Hashtbl.find index v then begin
|
||||
let comp = ref [] and stop = ref false in
|
||||
while not !stop do
|
||||
match !stack with
|
||||
| [] -> stop := true
|
||||
| w :: rest ->
|
||||
stack := rest;
|
||||
Hashtbl.replace onstack w false;
|
||||
comp := w :: !comp;
|
||||
if w = v then stop := true
|
||||
done;
|
||||
out := !comp :: !out
|
||||
end
|
||||
in
|
||||
List.iter (fun v -> if not (Hashtbl.mem index v) then strong v) nodes;
|
||||
!out
|
||||
|
||||
type result = {
|
||||
traced : string SMap.t;
|
||||
(* traced class name -> human reason (for --dump-gc and, in Phase 2, the
|
||||
promotion note) *)
|
||||
order : string list; (* all class names, sorted — deterministic dump order *)
|
||||
}
|
||||
|
||||
let classify (syms : Types.symbols) : result =
|
||||
let classes = syms.Types.classes in
|
||||
let nodes =
|
||||
SMap.fold (fun k _ acc -> k :: acc) classes [] |> List.sort compare
|
||||
in
|
||||
let adj v =
|
||||
match SMap.find_opt v classes with Some ci -> edges classes ci | None -> []
|
||||
in
|
||||
let comps = sccs nodes adj in
|
||||
let traced =
|
||||
List.fold_left
|
||||
(fun acc comp ->
|
||||
match comp with
|
||||
| [ v ] ->
|
||||
(* a singleton SCC is traced only if it points at itself *)
|
||||
if List.mem v (adj v) then
|
||||
SMap.add v (Printf.sprintf "cycle %s -> %s" v v) acc
|
||||
else acc
|
||||
| members ->
|
||||
let ms = List.sort compare members in
|
||||
let path = String.concat " -> " ms ^ " -> " ^ List.hd ms in
|
||||
List.fold_left
|
||||
(fun a m -> SMap.add m (Printf.sprintf "cycle %s" path) a)
|
||||
acc ms)
|
||||
SMap.empty comps
|
||||
in
|
||||
{ traced; order = nodes }
|
||||
|
||||
(* The `--dump-gc` artifact (spec §1): one line per class in sorted order,
|
||||
`gc`/`owned`, with the reason in parens for traced classes. *)
|
||||
let render (r : result) : string =
|
||||
let buf = Buffer.create 256 in
|
||||
List.iter
|
||||
(fun name ->
|
||||
match SMap.find_opt name r.traced with
|
||||
| Some reason ->
|
||||
Buffer.add_string buf (Printf.sprintf "%-10s gc (%s)\n" name reason)
|
||||
| None -> Buffer.add_string buf (Printf.sprintf "%-10s owned\n" name))
|
||||
r.order;
|
||||
Buffer.contents buf
|
||||
Loading…
Reference in a new issue