From 11b1f3be146fb2e23db6eeab45a352d9e596ac70 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 13 May 2024 21:29:38 -0400 Subject: [PATCH] wip: use mucppo --- src/cbor/dune | 2 +- src/core/CCList.ml | 16 +-- src/core/cpp/cpp.ml | 142 -------------------------- src/core/cpp/dune | 7 +- src/core/cpp/mucppo.ml | 188 +++++++++++++++++++++++++++++++++++ src/core/dune | 2 +- src/monomorphic/dune | 2 +- src/pvec/containers_pvec.mli | 6 +- src/pvec/dune | 2 +- src/testlib/dune | 2 +- tests/cbor/dune | 2 +- tests/core/dune | 2 +- tests/core/t_list.ml | 5 +- 13 files changed, 212 insertions(+), 166 deletions(-) delete mode 100644 src/core/cpp/cpp.ml create mode 100644 src/core/cpp/mucppo.ml diff --git a/src/cbor/dune b/src/cbor/dune index e6d64590..ba260ca4 100644 --- a/src/cbor/dune +++ b/src/cbor/dune @@ -3,5 +3,5 @@ (libraries containers) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (public_name containers.cbor)) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 87c7fefc..4a5b7723 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -47,7 +47,7 @@ let mguard c = (** max depth for direct recursion *) let direct_depth_default_ = 1000 -[@@@iflt 4.14] +#if OCAML_VERSION < (4,14,0) let tail_map f l = (* Unwind the list of tuples, reconstructing the full list front-to-back. @@ -114,7 +114,7 @@ let append l1 l2 = in direct 1000 l1 l2 -[@@@eliflt 5.1] +#elif OCAML_VERSION < (5,1,0) let[@tail_mod_cons] rec map f l = match l with @@ -128,11 +128,11 @@ let[@tail_mod_cons] rec append l1 l2 = | [] -> l2 | x :: tl1 -> x :: append tl1 l2 -[@@@else_] +#else (* TRMC functions on >= 5.1, no need to bring our own *) -[@@@endif] +#endif (* Wrapper around [append] to optimize for the case of short [l1], and for the case of [l2 = []] (saves the whole copy of [l1]!) *) @@ -157,7 +157,7 @@ let cons_when b x l = else l -[@@@iflt 4.14] +#if OCAML_VERSION < (4,14,0) let direct_depth_filter_ = 10_000 @@ -176,7 +176,7 @@ let filter p l = in direct direct_depth_filter_ p l -[@@@eliflt 5.1] +#elif OCAML_VERSION < (5,1,0) let[@tail_mod_cons] rec filter f l = match l with @@ -188,10 +188,10 @@ let[@tail_mod_cons] rec filter f l = else filter f tl -[@@@else_] +#else (* stdlib's filter uses TRMC after 5.1 *) -[@@@endif] +#endif let fold_right f l acc = let rec direct i f l acc = diff --git a/src/core/cpp/cpp.ml b/src/core/cpp/cpp.ml deleted file mode 100644 index 128ad712..00000000 --- a/src/core/cpp/cpp.ml +++ /dev/null @@ -1,142 +0,0 @@ -module C = Configurator.V1 - -type op = - | Le - | Ge - | Gt - | Lt - -type line = - | If of op * int * int - | Elseif of op * int * int - | Else - | Endif - | Raw of string - | Eof - -let prefix ~pre s = - let len = String.length pre in - if len > String.length s then - false - else ( - let rec check i = - if i = len then - true - else if String.unsafe_get s i <> String.unsafe_get pre i then - false - else - check (i + 1) - in - check 0 - ) - -let eval ~major ~minor op i j = - match op with - | Le -> (major, minor) <= (i, j) - | Lt -> (major, minor) < (i, j) - | Ge -> (major, minor) >= (i, j) - | Gt -> (major, minor) > (i, j) - -let preproc_lines ~file ~major ~minor (ic : in_channel) : unit = - let pos = ref 0 in - let fail msg = - failwith (Printf.sprintf "at line %d in '%s': %s" !pos file msg) - in - let pp_pos () = Printf.printf "#%d %S\n" !pos file in - - let parse_line () : line = - match input_line ic with - | exception End_of_file -> Eof - | line -> - let line' = String.trim line in - incr pos; - if line' <> "" && line'.[0] = '[' then - if prefix line' ~pre:"[@@@ifle" then - Scanf.sscanf line' "[@@@ifle %d.%d]" (fun x y -> If (Le, x, y)) - else if prefix line' ~pre:"[@@@iflt" then - Scanf.sscanf line' "[@@@iflt %d.%d]" (fun x y -> If (Lt, x, y)) - else if prefix line' ~pre:"[@@@ifge" then - Scanf.sscanf line' "[@@@ifge %d.%d]" (fun x y -> If (Ge, x, y)) - else if prefix line' ~pre:"[@@@ifgt" then - Scanf.sscanf line' "[@@@ifgt %d.%d]" (fun x y -> If (Gt, x, y)) - else if prefix line' ~pre:"[@@@elifle" then - Scanf.sscanf line' "[@@@elifle %d.%d]" (fun x y -> Elseif (Le, x, y)) - else if prefix line' ~pre:"[@@@elifge" then - Scanf.sscanf line' "[@@@elifge %d.%d]" (fun x y -> Elseif (Ge, x, y)) - else if prefix line' ~pre:"[@@@eliflt" then - Scanf.sscanf line' "[@@@eliflt %d.%d]" (fun x y -> Elseif (Lt, x, y)) - else if prefix line' ~pre:"[@@@elifge" then - Scanf.sscanf line' "[@@@elifge %d.%d]" (fun x y -> Elseif (Ge, x, y)) - else if line' = "[@@@else_]" then - Else - else if line' = "[@@@endif]" then - Endif - else - Raw line - else - Raw line - in - - (* entry point *) - let rec top () = - match parse_line () with - | Eof -> () - | If (op, i, j) -> - if eval ~major ~minor op i j then ( - pp_pos (); - cat_block () - ) else - skip_block ~elseok:true () - | Raw s -> - print_endline s; - top () - | Elseif _ | Else | Endif -> fail "unexpected elseif|else|endif" - (* current block is the valid one *) - and cat_block () = - match parse_line () with - | Eof -> fail "unexpected EOF" - | If _ -> fail "nested if not supported" - | Raw s -> - print_endline s; - cat_block () - | Endif -> - pp_pos (); - top () - | Elseif _ | Else -> skip_block ~elseok:false () - (* skip current block. - @param elseok if true, we should evaluate "elseif" *) - and skip_block ~elseok () = - match parse_line () with - | Eof -> fail "unexpected EOF" - | If _ -> fail "nested if not supported" - | Raw _ -> skip_block ~elseok () - | Endif -> - pp_pos (); - top () - | Elseif (op, i, j) -> - if elseok && eval ~major ~minor op i j then ( - pp_pos (); - cat_block () - ) else - skip_block ~elseok () - | Else -> - if elseok then ( - pp_pos (); - cat_block () - ) else - skip_block ~elseok () - in - top () - -let () = - let t0 = Unix.gettimeofday () in - let file = Sys.argv.(1) in - let c = C.create "main" in - let version = C.ocaml_config_var_exn c "version" in - let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> maj, min) in - - let ic = open_in file in - preproc_lines ~file ~major ~minor ic; - - Printf.printf "(* file preprocessed in %.3fs *)\n" (Unix.gettimeofday () -. t0); - () diff --git a/src/core/cpp/dune b/src/core/cpp/dune index 087a42df..15647422 100644 --- a/src/core/cpp/dune +++ b/src/core/cpp/dune @@ -1,8 +1,7 @@ -; our little preprocessor +; https://github.com/Leonidas-from-XIV/mucppo, cause it slaps (executable - (name cpp) + (name mucppo) (flags :standard -warn-error -a+8) (modes - (best exe)) - (libraries dune.configurator)) + (best exe))) diff --git a/src/core/cpp/mucppo.ml b/src/core/cpp/mucppo.ml new file mode 100644 index 00000000..5707c6b6 --- /dev/null +++ b/src/core/cpp/mucppo.ml @@ -0,0 +1,188 @@ +(* mucppo Copyright 2023-2024 Marek Kubica + * Released under CC0 license, freely available to all. + * + * Simple, no dependency cppo replacement to be embedded into builds. + * + * Contains a bare subset of cppo features to eliminate it as a dependency. + * For more info check the project page at + * https://github.com/Leonidas-from-XIV/mucppo + *) + +let version_triple major minor patch = major, minor, patch +let current_version = Scanf.sscanf Sys.ocaml_version "%u.%u.%u" version_triple +let greater_or_equal (v : int * int * int) = current_version >= v + +module PrintingState : sig + type t + + val empty : t + val is_empty : t -> bool + val flip_top : t -> t + val latest_was_triggered : t -> bool + val pop : t -> t + val push : bool -> t -> t + val should_print : t -> bool +end = struct + type state = { + state: bool; + was_true: bool; + } + + type t = state list + + let empty = [ { state = true; was_true = false } ] + let is_empty (x : t) = x = empty + + let flip_top = function + | [] -> failwith "Output stack empty, invalid state" + | x :: xs -> { state = not x.state; was_true = true } :: xs + + let latest_was_triggered l = (List.hd l).was_true + let pop = List.tl + let push state l = { state; was_true = state } :: l + + let should_print = + List.fold_left (fun acc { state; was_true = _ } -> state && acc) true +end + +module Variables = struct + module Map = Map.Make (String) + + let is_defined name = Map.mem name + let define name = Map.add name () + let undefine name = Map.remove name + let empty = Map.empty +end + +(* for OCaml 4.02 *) +let string_equal = ( = ) + +let starts_with ~prefix s = + let len = String.length prefix in + String.length s >= len && string_equal (String.sub s 0 len) prefix + +let is_if_statement = starts_with ~prefix:"#if" +let is_elif_defined_statement = starts_with ~prefix:"#elif defined" +let is_include_statement = starts_with ~prefix:"#include" +let is_define_statement = starts_with ~prefix:"#define" +let is_undef_statement = starts_with ~prefix:"#undef" +let is_ifdef = starts_with ~prefix:"#ifdef" +let filename_of_include s = Scanf.sscanf s "#include %S" (fun x -> x) +let variable_of_define s = Scanf.sscanf s "#define %s" (fun x -> x) +let variable_of_undef s = Scanf.sscanf s "#undef %s" (fun x -> x) +let variable_of_ifdef s = Scanf.sscanf s "#ifdef %s" (fun x -> x) +let variable_of_elif_defined s = Scanf.sscanf s "#elif defined %s" (fun x -> x) + +let is_ocaml_version s = + (* Sscanf.sscanf_opt exists but only since 5.0 *) + match Scanf.sscanf s "#if OCAML_VERSION >= (%u, %u, %u)" version_triple with + | v -> Some v + | exception _ -> None + +module State = struct + type t = { + (* print state *) + ps: PrintingState.t; + vars: unit Variables.Map.t; + } + + let conditional_triggered s = { s with ps = PrintingState.flip_top s.ps } + let end_conditional s = { s with ps = PrintingState.pop s.ps } + let triggered_before s = PrintingState.latest_was_triggered s.ps + let start_conditional v s = { s with ps = PrintingState.push v s.ps } + let should_output { ps; vars = _ } = PrintingState.should_print ps + + let don't_print s = + match should_output s with + | false -> s + | true -> { s with ps = PrintingState.flip_top s.ps } + + let finished { ps; vars = _ } = PrintingState.is_empty ps + let empty = { ps = PrintingState.empty; vars = Variables.empty } + let define v s = { s with vars = Variables.define v s.vars } + let undefine v s = { s with vars = Variables.undefine v s.vars } + let is_defined v { ps = _; vars } = Variables.is_defined v vars +end + +let output_endline oc s = + output_string oc s; + output_char oc '\n' + +let rec loop ic oc ~lineno ~filename st = + match input_line ic with + | line -> + let next = loop ic oc ~lineno:(succ lineno) ~filename in + (match String.trim line with + | "#else" -> + (match State.triggered_before st with + | true -> next (State.don't_print st) + | false -> next (State.conditional_triggered st)) + | "#endif" -> next (State.end_conditional st) + | trimmed_line when is_define_statement trimmed_line -> + let var = variable_of_define trimmed_line in + let st = State.define var st in + next st + | trimmed_line when is_undef_statement trimmed_line -> + let var = variable_of_undef trimmed_line in + let st = State.undefine var st in + next st + | trimmed_line when is_include_statement trimmed_line -> + let filename = filename_of_include trimmed_line in + let included_ic = open_in filename in + loop included_ic oc ~lineno:1 ~filename st; + next st + | trimmed_line when is_ifdef trimmed_line -> + let var = variable_of_ifdef trimmed_line in + let is_defined = State.is_defined var st in + let st = State.start_conditional is_defined st in + next st + | trimmed_line when is_if_statement trimmed_line -> + (match is_ocaml_version line with + | None -> + failwith + (Printf.sprintf "Parsing #if in file %s line %d failed, exiting" + filename lineno) + | Some (major, minor, patch) -> + next + (State.start_conditional (greater_or_equal (major, minor, patch)) st)) + | trimmed_line when is_elif_defined_statement trimmed_line -> + (match State.triggered_before st with + | true -> next (State.don't_print st) + | false -> + let var = variable_of_elif_defined trimmed_line in + (match State.is_defined var st with + | true -> next (State.conditional_triggered st) + | false -> next st)) + | _trimmed_line -> + if State.should_output st then output_endline oc line; + next st) + | exception End_of_file -> + if not (State.finished st) then + failwith "Output stack messed up, missing #endif?" + +let () = + let output_file = ref None in + let input_file = ref None in + let speclist = + [ + ( "-o", + Arg.String (fun filename -> output_file := Some filename), + "Set output file name" ); + ] + in + let anonymous filename = input_file := Some filename in + let usage = "mucppo -o " in + Arg.parse speclist anonymous usage; + let ic, filename = + match !input_file with + | Some filename -> open_in filename, filename + | None -> stdin, "" + in + let oc = + match !output_file with + | Some filename -> open_out filename + | None -> stdout + in + loop ic oc ~lineno:1 ~filename State.empty; + close_in ic; + close_out oc diff --git a/src/core/dune b/src/core/dune index cc17ce83..0bd64c8f 100644 --- a/src/core/dune +++ b/src/core/dune @@ -4,7 +4,7 @@ (wrapped false) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (flags :standard -nolabels -open CCMonomorphic) (libraries either containers.monomorphic)) diff --git a/src/monomorphic/dune b/src/monomorphic/dune index eacdccbe..67923f23 100644 --- a/src/monomorphic/dune +++ b/src/monomorphic/dune @@ -3,6 +3,6 @@ (public_name containers.monomorphic) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (modules CCMonomorphic) (wrapped false)) diff --git a/src/pvec/containers_pvec.mli b/src/pvec/containers_pvec.mli index 68773a2d..72989b98 100644 --- a/src/pvec/containers_pvec.mli +++ b/src/pvec/containers_pvec.mli @@ -10,15 +10,15 @@ type 'a iter = ('a -> unit) -> unit -[@@@ifge 5.0] +#if OCAML_VERSION >= (5,0,0) type !'a t -[@@@else_] +#else type 'a t -[@@@endif] +#endif val empty : 'a t (** Empty vector. *) diff --git a/src/pvec/dune b/src/pvec/dune index cca1fca6..410e9442 100644 --- a/src/pvec/dune +++ b/src/pvec/dune @@ -3,5 +3,5 @@ (public_name containers.pvec) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (synopsis "Persistent vector for OCaml")) diff --git a/src/testlib/dune b/src/testlib/dune index e36f9c7f..ab56f1eb 100644 --- a/src/testlib/dune +++ b/src/testlib/dune @@ -3,5 +3,5 @@ (synopsis "Test library for containers") (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (libraries containers qcheck-core unix)) diff --git a/tests/cbor/dune b/tests/cbor/dune index e235aab1..3d9db718 100644 --- a/tests/cbor/dune +++ b/tests/cbor/dune @@ -3,7 +3,7 @@ (modules t_appendix_a) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (libraries yojson containers containers.cbor)) (rule diff --git a/tests/core/dune b/tests/core/dune index d7c90a5e..a1799b10 100644 --- a/tests/core/dune +++ b/tests/core/dune @@ -6,7 +6,7 @@ (package containers) (preprocess (action - (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) + (run %{project_root}/src/core/cpp/mucppo.exe %{input-file}))) (libraries containers containers.bencode diff --git a/tests/core/t_list.ml b/tests/core/t_list.ml index ee0aac6a..ffd565f5 100644 --- a/tests/core/t_list.ml +++ b/tests/core/t_list.ml @@ -124,7 +124,8 @@ eq fold_flat_map (fun acc x -> acc + x, [ pf "%d" x; pf "a%d" x ]) 0 [ 1; 2; 3 ]) ;; -[@@@ifge 4.12] +#if OCAML_VERSION >= (4,12,0) + t @@ fun () -> let r = Atomic.make 0 in let f x = @@ -140,7 +141,7 @@ assert_equal true ;; -[@@@endif] +#endif q Q.(list int)