Skip to content

Commit

Permalink
Remove lazyness in Mpipeline
Browse files Browse the repository at this point in the history
  • Loading branch information
@lyrm
lyrm committed Jan 23, 2025
1 parent b2d54c7 commit 0d57b0a
Showing 1 changed file with 79 additions and 87 deletions.
166 changes: 79 additions & 87 deletions src/kernel/mpipeline.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,23 +4,22 @@ let { Logger.log } = Logger.for_section "Pipeline"

let time_shift = ref 0.0

let timed_lazy r x =
lazy
(let start = Misc.time_spent () in
let time_shift0 = !time_shift in
let update () =
let delta = Misc.time_spent () -. start in
let shift = !time_shift -. time_shift0 in
time_shift := time_shift0 +. delta;
r := !r +. delta -. shift
in
match Lazy.force x with
| x ->
update ();
x
| exception exn ->
update ();
Std.reraise exn)
let timed r x =
let start = Misc.time_spent () in
let time_shift0 = !time_shift in
let update () =
let delta = Misc.time_spent () -. start in
let shift = !time_shift -. time_shift0 in
time_shift := time_shift0 +. delta;
r := !r +. delta -. shift
in
match x () with
| x ->
update ();
x
| exception exn ->
update ();
Std.reraise exn

module Cache = struct
let cache = ref []
Expand Down Expand Up @@ -65,7 +64,7 @@ module Cache = struct
end

module Typer = struct
type t = { errors : exn list lazy_t; result : Mtyper.result }
type t = { errors : exn list; result : Mtyper.result }
end

module Ppx = struct
Expand All @@ -82,10 +81,10 @@ type t =
{ config : Mconfig.t;
state : Mocaml.typer_state;
raw_source : Msource.t;
source : (Msource.t * Mreader.parsetree option) lazy_t;
reader : Reader.t lazy_t;
ppx : Ppx.t lazy_t;
typer : Typer.t lazy_t;
source : Msource.t * Mreader.parsetree option;
reader : Reader.t;
ppx : Ppx.t;
typer : Typer.t;
pp_time : float ref;
reader_time : float ref;
ppx_time : float ref;
Expand All @@ -99,7 +98,7 @@ type t =
let raw_source t = t.raw_source

let input_config t = t.config
let input_source t = fst (Lazy.force t.source)
let input_source t = fst t.source

let with_pipeline t f =
Mocaml.with_state t.state @@ fun () ->
Expand All @@ -110,10 +109,10 @@ let get_lexing_pos t pos =
~filename:(Mconfig.filename t.config)
pos

let reader t = Lazy.force t.reader
let reader t = t.reader

let ppx t = Lazy.force t.ppx
let typer t = Lazy.force t.typer
let ppx t = t.ppx
let typer t = t.typer

let reader_config t = (reader t).config
let reader_parsetree t = (reader t).result.Mreader.parsetree
Expand All @@ -131,7 +130,7 @@ let ppx_errors t = (ppx t).Ppx.errors
let final_config t = (ppx t).Ppx.config

let typer_result t = (typer t).Typer.result
let typer_errors t = Lazy.force (typer t).Typer.errors
let typer_errors t = (typer t).Typer.errors

module Reader_phase = struct
type t =
Expand Down Expand Up @@ -230,9 +229,8 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0)
| Some state -> state
in
let source =
timed_lazy pp_time
(lazy
(match Mconfig.(config.ocaml.pp) with
timed pp_time (fun () ->
match Mconfig.(config.ocaml.pp) with
| None -> (raw_source, None)
| Some { workdir; workval } -> (
let source = Msource.text raw_source in
Expand All @@ -242,73 +240,67 @@ let process ?state ?(pp_time = ref 0.0) ?(reader_time = ref 0.0)
~source ~pp:workval
with
| `Source source -> (Msource.make source, None)
| (`Interface _ | `Implementation _) as ast -> (raw_source, Some ast))))
| (`Interface _ | `Implementation _) as ast -> (raw_source, Some ast)))
in
let reader =
timed_lazy reader_time
(lazy
(let (lazy ((_, pp_result) as source)) = source in
let config = Mconfig.normalize config in
Mocaml.setup_reader_config config;
let cache_disabling =
match (config.merlin.use_ppx_cache, pp_result) with
| false, _ -> Some "configuration"
| true, Some _ ->
(* The cache could be refined in the future to also act on the
timed reader_time (fun () ->
let ((_, pp_result) as source) = source in
let config = Mconfig.normalize config in
Mocaml.setup_reader_config config;
let cache_disabling =
match (config.merlin.use_ppx_cache, pp_result) with
| false, _ -> Some "configuration"
| true, Some _ ->
(* The cache could be refined in the future to also act on the
PP phase. For now, let's disable the whole cache when there's
a PP. *)
Some "source preprocessor usage"
| true, None -> None
in
let { Reader_with_cache.output = { result; cache_version };
cache_was_hit
} =
Reader_with_cache.apply ~cache_disabling
{ source; for_completion; config }
in
reader_cache_hit := cache_was_hit;
let cache_version =
if Option.is_some cache_disabling then None else Some cache_version
in
{ Reader.result; config; cache_version }))
Some "source preprocessor usage"
| true, None -> None
in
let { Reader_with_cache.output = { result; cache_version };
cache_was_hit
} =
Reader_with_cache.apply ~cache_disabling
{ source; for_completion; config }
in
reader_cache_hit := cache_was_hit;
let cache_version =
if Option.is_some cache_disabling then None else Some cache_version
in
{ Reader.result; config; cache_version })
in
let ppx =
timed_lazy ppx_time
(lazy
(let (lazy
{ Reader.result = { Mreader.parsetree; _ };
config;
cache_version
}) =
reader
in
let caught = ref [] in
Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught
@@ fun () ->
(* Currently the cache is invalidated even for source changes that don't
timed ppx_time (fun () ->
let { Reader.result = { Mreader.parsetree; _ }; config; cache_version }
=
reader
in
let caught = ref [] in
Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught
@@ fun () ->
(* Currently the cache is invalidated even for source changes that don't
change the parsetree. To avoid that, we'd have to digest the
parsetree in the cache. *)
let cache_disabling, reader_cache =
match cache_version with
| Some v -> (None, Ppx_phase.Version v)
| None -> (Some "reader cache is disabled", Off)
in
let { Ppx_with_cache.output = parsetree; cache_was_hit } =
Ppx_with_cache.apply ~cache_disabling
{ parsetree; config; reader_cache }
in
ppx_cache_hit := cache_was_hit;
{ Ppx.config; parsetree; errors = !caught }))
let cache_disabling, reader_cache =
match cache_version with
| Some v -> (None, Ppx_phase.Version v)
| None -> (Some "reader cache is disabled", Off)
in
let { Ppx_with_cache.output = parsetree; cache_was_hit } =
Ppx_with_cache.apply ~cache_disabling
{ parsetree; config; reader_cache }
in
ppx_cache_hit := cache_was_hit;
{ Ppx.config; parsetree; errors = !caught })
in
let typer =
timed_lazy typer_time
(lazy
(let (lazy { Ppx.config; parsetree; _ }) = ppx in
Mocaml.setup_typer_config config;
let result = Mtyper.run config parsetree in
let errors = timed_lazy error_time (lazy (Mtyper.get_errors result)) in
typer_cache_stats := Mtyper.get_cache_stat result;
{ Typer.errors; result }))
timed typer_time (fun () ->
let { Ppx.config; parsetree; _ } = ppx in
Mocaml.setup_typer_config config;
let result = Mtyper.run config parsetree in
let errors = timed error_time (fun () -> Mtyper.get_errors result) in
typer_cache_stats := Mtyper.get_cache_stat result;
{ Typer.errors; result })
in
{ config;
state;
Expand Down

0 comments on commit 0d57b0a

Please sign in to comment.