@ -28,7 +28,8 @@ let build_from_captured_procs g =
CallGraph . create_node g proc_name callees )
CallGraph . create_node g proc_name callees )
let build_from_sources g sources =
let build_from_sources sources =
let g = CallGraph . create CallGraph . default_initial_capacity in
let time0 = Mtime_clock . counter () in
let time0 = Mtime_clock . counter () in
L . progress " Building call graph...@ \n %! " ;
L . progress " Building call graph...@ \n %! " ;
build_from_captured_procs g ;
build_from_captured_procs g ;
@ -41,34 +42,22 @@ let build_from_sources g sources =
L . progress
L . progress
" Built call graph in %a, from %d total procs, %d reachable defined procs and takes %d bytes@. "
" Built call graph in %a, from %d total procs, %d reachable defined procs and takes %d bytes@. "
Mtime . Span . pp ( Mtime_clock . count time0 ) n_captured ( CallGraph . n_procs g )
Mtime . Span . pp ( Mtime_clock . count time0 ) n_captured ( CallGraph . n_procs g )
( Obj . ( reachable_words ( repr g ) ) * ( Sys . word_size / 8 ) )
( Obj . ( reachable_words ( repr g ) ) * ( Sys . word_size / 8 ) ) ;
g
let count_procedures () =
let db = ResultsDatabase . get_database () in
let stmt = Sqlite3 . prepare db " SELECT COUNT(rowid) FROM procedures " in
let count =
match SqliteUtils . result_single_column_option db ~ log : " counting procedures " stmt with
| Some ( Sqlite3 . Data . INT i64 ) ->
Int64 . to_int i64 | > Option . value ~ default : Int . max_value
| _ ->
L . die InternalError " Got no result trying to count procedures "
in
L . debug Analysis Quiet " Found %d procedures in procedures table.@. " count ;
count
let bottom_up sources : SchedulerTypes . target ProcessPool . TaskGenerator . t =
let bottom_up sources : SchedulerTypes . target ProcessPool . TaskGenerator . t =
let open SchedulerTypes in
let open SchedulerTypes in
(* this will potentially grossly overapproximate the tasks *)
let syntactic_call_graph = build_from_sources sources in
let remaining = ref ( count_procedures () ) in
let remaining = ref ( CallGraph . n_procs syntactic_call_graph ) in
let remaining_tasks () = ! remaining in
let remaining_tasks () = ! remaining in
let syntactic_call_graph = CallGraph . create CallGraph . default_initial_capacity in
let pending =
let initialized = ref false in
(* prime the pending queue so that [empty] doesn't immediately return true *)
let pending : CallGraph . Node . t list ref = ref [] in
ref ( CallGraph . get_unflagged_leaves syntactic_call_graph )
in
let scheduled = ref Procname . Set . empty in
let scheduled = ref Procname . Set . empty in
let is_empty () =
let is_empty () =
let empty = ! initialized && List . is_empty ! pending && Procname . Set . is_empty ! scheduled in
let empty = List . is_empty ! pending && Procname . Set . is_empty ! scheduled in
if empty then (
if empty then (
remaining := 0 ;
remaining := 0 ;
L . progress " Finished call graph scheduling, %d procs remaining (in, or reaching, cycles).@. "
L . progress " Finished call graph scheduling, %d procs remaining (in, or reaching, cycles).@. "
@ -78,14 +67,14 @@ let bottom_up sources : SchedulerTypes.target ProcessPool.TaskGenerator.t =
CallGraph . reset syntactic_call_graph ) ;
CallGraph . reset syntactic_call_graph ) ;
empty
empty
in
in
let rec next _aux () =
let rec next () =
match ! pending with
match ! pending with
| [] ->
| [] ->
pending := CallGraph . get_unflagged_leaves syntactic_call_graph ;
pending := CallGraph . get_unflagged_leaves syntactic_call_graph ;
if List . is_empty ! pending then None else next _aux ()
if List . is_empty ! pending then None else next ()
| n :: ns when n . flag | | not ( CallGraph . mem syntactic_call_graph n . id ) ->
| n :: ns when n . flag | | not ( CallGraph . mem syntactic_call_graph n . id ) ->
pending := ns ;
pending := ns ;
next _aux ()
next ()
| n :: ns ->
| n :: ns ->
pending := ns ;
pending := ns ;
scheduled := Procname . Set . add n . pname ! scheduled ;
scheduled := Procname . Set . add n . pname ! scheduled ;
@ -100,13 +89,6 @@ let bottom_up sources : SchedulerTypes.target ProcessPool.TaskGenerator.t =
| File _ ->
| File _ ->
L . die InternalError " Only Procnames are scheduled but File target was received "
L . die InternalError " Only Procnames are scheduled but File target was received "
in
in
let next () =
(* do construction here, to avoid having the call graph into forked workers *)
if not ! initialized then (
build_from_sources syntactic_call_graph sources ;
initialized := true ) ;
next_aux ()
in
{ remaining_tasks ; is_empty ; finished ; next }
{ remaining_tasks ; is_empty ; finished ; next }