Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file profile.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520open!Core_kernelopen!Async_kernelmoduleStart_location=structtypet=|Line_preceding_profile|End_of_profile_first_line[@@derivingcompare,enumerate,sexp_of]letdefault=End_of_profile_first_lineendletstart_location=refStart_location.defaultletconcat=String.concatletapproximate_line_length_limit=ref1_000letshould_profile=reffalselethide_if_less_than=ref(Time_ns.Span.of_int_us100)lethide_top_level_if_less_than=ref(Time_ns.Span.of_int_ms10)letoutput_profile=refprint_stringletsexp_of_time_ns=ref[%sexp_of:Time_ns.Alternate_sexp.t]lettag_frames_with=refNonemoduleTime_ns=structincludeTime_nsletsexp_of_tt=try!sexp_of_time_nstwith|exn->letbacktrace=Backtrace.Exn.most_recent()in[%message"[Profile.sexp_of_time_ns] raised"(exn:exn)(backtrace:Backtrace.t)];;endmoduleClock=structtypet=|Wall|Virtualof{mutablenow:Time_ns.t}[@@derivingsexp_of]letcreate~now=Virtual{now}letnow=function|Wall->Time_ns.now()|Virtual{now}->now;;letadvancet~by=matchtwith|Wall->raise_s[%message"[Nested_profile.Clock.advance]"]|Virtuals->s.now<-Time_ns.adds.nowby;;endletclock=refClock.Wallletnow()=Clock.now!clock(* We don't support profiling for brief periods when profiler code calls user code,
because doing so would be hard and could cause infinite regress, e.g. if that code in
turns asks to be profiled. So, we have an internal bool ref, [profiling_is_allowed],
that we use to disable profiling when calling user code. *)letprofiling_is_allowed=reftrueletwith_profiling_disallowedf=Ref.set_temporarilyprofiling_is_allowedfalse~fmoduleElide_in_test=structtype'at='aletsexp_of_tsexp_of_aa=ifam_running_inline_testthen[%message"<elided-in-test>"]elsesexp_of_aa;;endmoduleMessage:sigtypet[@@derivingsexp_of]valcreate:Sexp.tLazy.t->tvalam_forcing:unit->boolvalforce:t->Sexp.tend=structtypet=Sexp.tLazy.t[@@derivingsexp_of]letcreatet=tletam_forcing_ref=reffalseletam_forcing()=!am_forcing_refletforcet=Ref.set_temporarilyam_forcing_reftrue~f:(fun()->forcet)endletam_forcing_message=Message.am_forcingmoduleRecord=structtypet={start:Time_ns.t;stop:Time_ns.t;message:Message.t;children:tlist;had_parallel_children:bool;pending_children:int}lettookt=Time_ns.difft.stopt.startletrecsexp_of_t({start=_;stop=_;message;children;had_parallel_children;pending_children}ast)=[%sexp(tookt|>Time_ns.Span.to_string_hum:string),(ifhad_parallel_childrenthenSome`parallelelseNone:([`parallel]option[@sexp.option])),(ifpending_children<>0thenSome(`pending_childrenpending_children)elseNone:([`pending_childrenofint]option[@sexp.option])),(Message.forcemessage:Sexp.t),(children:(tlist[@sexp.omit_nil]))];;letsexp_to_string_on_one_line=letbuffer=Buffer.create0inletemitstring=Buffer.add_stringbufferstringinletover_the_limit=reffalseinletcan_emitadditional=(not!over_the_limit)&&(ifBuffer.lengthbuffer+additional>!approximate_line_length_limitthen(over_the_limit:=true;emit"...");not!over_the_limit)inletrecemit_sexp(sexp:Sexp.t)=matchsexpwith|Atom_assexp->letstring=Sexp.to_stringsexpinifcan_emit(String.lengthstring)thenemitstring|Listsexps->ifcan_emit2then(emit"(";(matchsexpswith|[]->()|sexp::sexps->emit_sexpsexp;List.itersexps~f:(funsexp->ifnot!over_the_limitthen(emit" ";emit_sexpsexp)));emit")")infunsexp->Buffer.clearbuffer;over_the_limit:=false;emit_sexpsexp;Buffer.contentsbuffer;;lettime_span_as_micros_with_two_digits_of_precisionspan=letspan=span|>Time_ns.Span.to_int_usinletdigits=String.length(span|>Int.to_string)inletprecision=2inletmicroseconds=ifdigits<=precisionthenspanelse(letscale=Int.pow10(digits-precision)inscale*((span|>Int.to_float)/.(scale|>Int.to_float)|>Float.iround_nearest_exn))inconcat[microseconds|>Int.to_string_hum;"us"];;letpad_leftstring~total_width=letn=String.lengthstringinifn>total_widththenstringelseconcat[String.make(total_width-n)' ';string];;lettook_widtht=String.length(tookt|>time_span_as_micros_with_two_digits_of_precision);;letrecmax_took_widtht=Int.max(took_widtht)(List.foldt.children~init:0~f:(funacchild->Int.maxac(max_took_widthchild)));;letrecinsert_gap_framest=ifList.is_emptyt.childrenthentelse(letmaybe_add_gapts~start~stop=letgap_took=Time_ns.diffstopstartin(* We hide the gap frame if it took less than [!hide_if_less_than], like all other
frames. We also hide the gap frame if it took less than 1us, since a gap frame
that says 0us would be noise. *)ifTime_ns.Span.(<)gap_took!hide_if_less_than||Time_ns.Span.(<)gap_tookTime_ns.Span.microsecondthentselse{start;stop;message=Message.create(lazy[%sexp"gap"]);children=[];had_parallel_children=false;pending_children=0}::tsinletlast_stop,rev_children=List.foldt.children~init:(t.start,[])~f:(fun(last_stop,rev_children)child->(child.stop,insert_gap_frameschild::maybe_add_gaprev_children~start:last_stop~stop:child.start))inletrev_children=maybe_add_gaprev_children~start:last_stop~stop:t.stopin{twithchildren=List.revrev_children});;letto_string_humt=letrendering_started=now()inletstart_location=!start_locationinlett=insert_gap_framestinlettook_total_width=max_took_widthtinletparenstrings=concat["(";concatstrings;")"]inletshift_right=matchstart_locationwith|End_of_profile_first_line->0|Line_preceding_profile->1inletstart=[%sexp(t.start:Time_ns.t)]|>Sexp.to_stringinletrecloop({message;children;had_parallel_children;pending_children;_}ast)~depth~parent_took=lettook=tooktinletpercentage=matchparent_tookwith|None->""|Someparent_took->letpercentage_int=(ifTime_ns.Span.equalparent_tookTime_ns.Span.zerothen"_"elseTime_ns.Span.(//)tookparent_took*.100.|>Float.iround_nearest_exn|>Int.to_string)|>pad_left~total_width:3inconcat[percentage_int;"% "]inletmessage=with_profiling_disallowed(fun()->tryMessage.forcemessagewith|exn->letbacktrace=Backtrace.Exn.most_recent()in[%message"[Profile.profile] message raised"(exn:exn)(backtrace:Backtrace.t)])inconcat[String.make(shift_right+(3*depth))' ';paren[percentage;took|>time_span_as_micros_with_two_digits_of_precision|>pad_left~total_width:took_total_width;" ";(ifhad_parallel_childrenthen"[parallel] "else"");(matchpending_childrenwith|0->""|1->"[1 pending child] "|n->sprintf"[%d pending children] "n);message|>sexp_to_string_on_one_line;(matchstart_locationwith|Line_preceding_profile->""|End_of_profile_first_line->ifdepth=0thenconcat[" ";start]else"");(ifList.is_emptychildrenthen""elseconcat[" ";paren["\n";concat~sep:"\n"(List.mapchildren~f:(loop~depth:(depth+1)~parent_took:(Sometook)))]])]]inletprofile=loopt~depth:0~parent_took:Noneinletrendering_finished=now()inletrendering_took=Time_ns.diffrendering_finishedrendering_startedinletrendering_took=ifTime_ns.Span.(<)rendering_took!hide_top_level_if_less_thanthenNoneelseSome(paren["rendering_took ";rendering_took|>time_span_as_micros_with_two_digits_of_precision])inmatchstart_location,rendering_tookwith|End_of_profile_first_line,None->profile|End_of_profile_first_line,Somer->paren[r;"\n ";profile]|Line_preceding_profile,None->paren[start;"\n";profile]|Line_preceding_profile,Somer->paren[start;"\n ";r;"\n";profile];;endmoduleFrame=structtypet={message:Message.t;start:Time_ns.Alternate_sexp.tElide_in_test.t;children:Record.tQueue.t;parent:toption;mutablepending_children:int;mutablemax_pending_children:int}[@@derivingsexp_of]letcreate~message~parent={message=Message.createmessage;start=now();children=Queue.create();parent;pending_children=0;max_pending_children=0};;letrecord{message;start;children;parent=_;pending_children;max_pending_children}~stop:Record.t={start;stop;message;children=children|>Queue.to_list;had_parallel_children=max_pending_children>1;pending_children};;endmoduleProfile_context=structletrecord_profileframe~stop=letrecord=Frame.recordframe~stopinmatchframe.parentwith|None->ifTime_ns.Span.(>=)(Record.tookrecord)!hide_top_level_if_less_thanthen(letprofile=concat[record|>Record.to_string_hum;"\n"]inwith_profiling_disallowed(fun()->try!output_profileprofilewith|exn->letbacktrace=Backtrace.Exn.most_recent()ineprint_s[%message"[Profile.output_profile] raised"(exn:exn)(backtrace:Backtrace.t)]))|Someparent->Queue.enqueueparent.childrenrecord;;letbacktraceframe=letrecloop(frame:Frame.t)acc=letacc=frame.message::accinmatchframe.parentwith|None->acc|Someparent->loopparentaccinList.rev(loopframe[]);;endletmaybe_record_frame?hide_if_less_than:local_hide_if_less_than(frame:Frame.t)~stop=lettook=Time_ns.diffstopframe.startinlethide_if_less_than=Option.valuelocal_hide_if_less_than~default:!hide_if_less_thaninifTime_ns.Span.(>=)tookhide_if_less_thanthenProfile_context.record_profileframe~stop;;leton_async_out_of_order=ref(funsexp->!output_profile(Sexp.to_string_hum(forcesexp)^"\n"));;letrecord_profile?hide_if_less_than(frame:Frame.t)=ifframe.pending_children<>0then((* Pull this out of the record eagerly so we don't have problems with the lazy
expression being evaluated later, where there might be an intervening write to
[frame.pending_children]. *)letpending_children=frame.pending_childrenin!on_async_out_of_order(lazy[%message"Nested [profile Async] exited out-of-order."~message:(Message.forceframe.message:Sexp.t)(pending_children:int)]));maybe_record_frame?hide_if_less_thanframe~stop:(now());;moduleSync_or_async=structtype_t=|Sync:_t|Async:_Deferred.tt[@@derivingsexp_of]endletprofile_context_key=Univ_map.Key.create~name:"Nested_profile.Profile.Frame"[%sexp_of:Frame.t];;letcurrent_profile_context()=Async_kernel_scheduler.find_localprofile_context_keyletwith_profile_contextframe~f=Async_kernel_scheduler.with_localprofile_context_keyframe~f;;letprofile(typea)?hide_if_less_than(sync_or_async:aSync_or_async.t)(message:Sexp.tLazy.t)(f:unit->a):a=ifnot(!profiling_is_allowed&&!should_profile)thenf()else(lettag=with_profiling_disallowed(fun()->tryOption.bind!tag_frames_with~f:(funf->f())with|exn->letbacktrace=Backtrace.Exn.most_recent()inSome[%message"[Profile.tag_frames_with] raised"(exn:exn)(backtrace:Backtrace.t)])inletmessage=matchtagwith|None->message|Sometag->lazy(List[forcemessage;tag])inletparent=current_profile_context()inletframe=Frame.create~message~parentinletincr_pending_children=matchparentwith|None->fun~by:_->()|Someparent->fun~by->parent.pending_children<-parent.pending_children+by;parent.max_pending_children<-Int.maxparent.max_pending_childrenparent.pending_childreninincr_pending_children~by:1;letf()=with_profile_context(Someframe)~finmatchsync_or_asyncwith|Sync->Exn.protect~f~finally:(fun()->record_profile?hide_if_less_thanframe;incr_pending_children~by:(-1))|Async->Monitor.protectf~finally:(fun()->record_profile?hide_if_less_thanframe;incr_pending_children~by:(-1);return()));;letbacktrace()=letframe=current_profile_context()inmatch!should_profilewith|false->None|true->Some(Option.value_mapframe~f:Profile_context.backtrace~default:[]|>List.map~f:Message.force);;letdisownf=with_profile_contextNone~fmodulePrivate=structmoduleClock=Clockletclock=clockleton_async_out_of_order=on_async_out_of_orderletrecord_frame~start~stop~message=if!profiling_is_allowed&&!should_profilethenmaybe_record_frame{message=Message.createmessage;start;children=Queue.create();parent=current_profile_context();pending_children=0;max_pending_children=0}~stop;;end