diff options
34 files changed, 6957 insertions, 215 deletions
diff --git a/erts/doc/src/erl_tracer.xml b/erts/doc/src/erl_tracer.xml index 1e8e78b25f..2075b962d8 100644 --- a/erts/doc/src/erl_tracer.xml +++ b/erts/doc/src/erl_tracer.xml @@ -54,6 +54,14 @@ </description> <datatypes> + <datatype> <name name="trace_tag_send" /> </datatype> + <datatype> <name name="trace_tag_receive" /> </datatype> + <datatype> <name name="trace_tag_call" /> </datatype> + <datatype> <name name="trace_tag_procs" /> </datatype> + <datatype> <name name="trace_tag_ports" /> </datatype> + <datatype> <name name="trace_tag_running_procs" /> </datatype> + <datatype> <name name="trace_tag_running_ports" /> </datatype> + <datatype> <name name="trace_tag_gc" /> </datatype> <datatype> <name name="trace_tag" /> <desc> @@ -105,6 +113,29 @@ <title>CALLBACK FUNCTIONS</title> <p>The following functions should be exported from a <c>erl_tracer</c> callback module.</p> + <taglist> + <tag><seealso marker="#enabled"><c>Module:enabled/3</c></seealso></tag> + <item>Mandatory</item> + <tag><seealso marker="#trace"><c>Module:trace/6</c></seealso></tag> + <item>Mandatory</item> + <tag><seealso marker="#enabled_procs"><c>Module:enabled_procs/3</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#trace_procs"><c>Module:trace_procs/6</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#enabled_ports"><c>Module:enabled_ports/3</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#trace_ports"><c>Module:trace_ports/6</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#enabled_running_ports"><c>Module:enabled_running_ports/3</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#trace_running_ports"><c>Module:trace_running_ports/6</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#enabled_running_procs"><c>Module:enabled_running_procs/3</c></seealso></tag> + <item>Optional</item> + <tag><seealso marker="#trace_running_procs"><c>Module:trace_running_procs/6</c></seealso></tag> + <item>Optional</item> + </taglist> + </section> <marker id="enabled"></marker> <funcs> @@ -114,11 +145,11 @@ <type> <v>TraceTag = <seealso marker="#type-trace_tag">trace_tag()</seealso> | trace_status</v> <v>TracerState = term()</v> - <v>Tracee = <seealso marker="#type-trace_tag">tracee()</seealso></v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> <v>Result = trace | discard | remove</v> </type> <desc> - <p>This callback will be called whenever a trace point is triggered. It + <p>This callback will be called whenever a tracepoint is triggered. It allows the tracer to decide whether a trace should be generated or not. This check is made as early as possible in order to limit the amount of overhead associated with tracing. If <c>trace</c> is returned the @@ -132,7 +163,7 @@ to check if the tracer should still be active. It is called in multiple scenarios, but most significantly it is used when tracing is started using this tracer.</p> - <p>This function may be called multiple times per trace point, so it + <p>This function may be called multiple times per tracepoint, so it is important that it is both fast and side effect free.</p> </desc> </func> @@ -143,17 +174,17 @@ <type> <v>TraceTag = <seealso marker="#type-trace_tag">trace_tag()</seealso></v> <v>TracerState = term()</v> - <v>Tracee = <seealso marker="#type-trace_tag">tracee()</seealso></v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> <v>FirstTraceTerm = term()</v> <v>SecondTraceTerm = term() | undefined</v> <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> <v>Result = ok</v> </type> <desc> - <p>This callback will be called when a trace point is triggered and + <p>This callback will be called when a tracepoint is triggered and the <seealso marker="#enabled">Module:enabled/3</seealso> callback returned <c>trace</c>. In it any side effects needed by - the tracer should be done. The trace point payload is located in + the tracer should be done. The tracepoint payload is located in the <c>FirstTraceTerm</c> and <c>SecondTraceTerm</c>. The content of the TraceTerms depends on which <c>TraceTag</c> has been triggered. The <c>FirstTraceTerm</c> and <c>SecondTraceTerm</c> correspond to the @@ -181,6 +212,319 @@ see the <seealso marker="kernel:seq_trace">seq_trace</seealso> manual.</p> </desc> </func> + + <marker id="enabled_procs"></marker> + <func> + <name>Module:enabled_procs(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_procs">trace_tag_procs()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>procs</c></seealso> + is triggered.</p> + <p>If <c>enabled_procs/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_procs"></marker> + <func> + <name>Module:trace_procs(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_procs">trace_tag()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_procs">Module:enabled_procs/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_procs/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_ports"></marker> + <func> + <name>Module:enabled_ports(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_ports">trace_tag_ports()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>ports</c></seealso> + is triggered.</p> + <p>If <c>enabled_ports/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_ports"></marker> + <func> + <name>Module:trace_ports(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_ports">trace_tag()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_ports">Module:enabled_ports/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_ports/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_running_procs"></marker> + <func> + <name>Module:enabled_running_procs(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_running_procs">trace_tag_running_procs()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>running_procs | running</c></seealso> + is triggered.</p> + <p>If <c>enabled_running_procs/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_running_procs"></marker> + <func> + <name>Module:trace_running_procs(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_running_procs">trace_tag_running_procs()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_running_procs">Module:enabled_running_procs/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_running_procs/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_running_ports"></marker> + <func> + <name>Module:enabled_running_ports(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_running_ports">trace_tag_running_ports()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>running_ports</c></seealso> + is triggered.</p> + <p>If <c>enabled_running_ports/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_running_ports"></marker> + <func> + <name>Module:trace_running_ports(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_running_ports">trace_tag_running_ports()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_running_ports">Module:enabled_running_ports/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_running_ports/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_call"></marker> + <func> + <name>Module:enabled_call(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_call">trace_tag_call()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>call | return_to</c></seealso> + is triggered.</p> + <p>If <c>enabled_call/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_call"></marker> + <func> + <name>Module:trace_call(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_call">trace_tag_call()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_call">Module:enabled_call/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_call/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_send"></marker> + <func> + <name>Module:enabled_send(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_send">trace_tag_send()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>send</c></seealso> + is triggered.</p> + <p>If <c>enabled_send/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_send"></marker> + <func> + <name>Module:trace_send(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_send">trace_tag_send()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_send">Module:enabled_send/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_send/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_receive"></marker> + <func> + <name>Module:enabled_receive(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_receive">trace_tag_receive()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>'receive'</c></seealso> + is triggered.</p> + <p>If <c>enabled_receive/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_receive"></marker> + <func> + <name>Module:trace_receive(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_receive">trace_tag_receive()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_receive">Module:enabled_receive/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_receive/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + + <marker id="enabled_garbage_collection"></marker> + <func> + <name>Module:enabled_garbage_collection(TraceTag, TracerState, Tracee) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_gc">trace_tag_gc()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>Result = trace | discard | remove</v> + </type> + <desc> + <p>This callback will be called whenever a tracepoint with trace flag + <seealso marker="erlang#trace-3"><c>garbage_collection</c></seealso> + is triggered.</p> + <p>If <c>enabled_garbage_collection/3</c> is not defined <c>enabled/3</c> will be called instead.</p> + </desc> + </func> + + <marker id="trace_garbage_collection"></marker> + <func> + <name>Module:trace_garbage_collection(TraceTag, TracerState, Tracee, FirstTraceTerm, SecondTraceTerm, Opts) -> Result</name> + <fsummary>Check if a trace event should be generated.</fsummary> + <type> + <v>TraceTag = <seealso marker="#type-trace_tag_gc">trace_tag_gc()</seealso></v> + <v>TracerState = term()</v> + <v>Tracee = <seealso marker="#type-tracee">tracee()</seealso></v> + <v>FirstTraceTerm = term()</v> + <v>SecondTraceTerm = term() | undefined</v> + <v>Opts = <seealso marker="#type-trace_opts">trace_opts()</seealso></v> + <v>Result = ok</v> + </type> + <desc> + <p>This callback will be called when a tracepoint is triggered and + the <seealso marker="#enabled_garbage_collection">Module:enabled_garbage_collection/3</seealso> + callback returned <c>trace</c>.</p> + <p>If <c>trace_garbage_collection/6</c> is not defined <c>trace/6</c> will be called instead.</p> + </desc> + </func> + </funcs> <section> <marker id="example"></marker> @@ -282,7 +626,7 @@ static ERL_NIF_TERM enabled(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) ErlNifPid to_pid; if (enif_get_local_pid(env, argv[1], &to_pid)) if (!enif_is_process_alive(env, &to_pid)) - /* tracer is dead so we should remove this trace point */ + /* tracer is dead so we should remove this tracepoint */ return enif_make_atom(env, "remove"); /* Only generate trace for when tracer != tracee */ diff --git a/erts/emulator/beam/atom.names b/erts/emulator/beam/atom.names index 8c51f788c0..3022c0a99a 100644 --- a/erts/emulator/beam/atom.names +++ b/erts/emulator/beam/atom.names @@ -273,6 +273,10 @@ atom garbage_collecting atom garbage_collection atom garbage_collection_info atom gc_end +atom gc_major_end +atom gc_major_start +atom gc_minor_end +atom gc_minor_start atom gc_start atom Ge='>=' atom generational diff --git a/erts/emulator/beam/erl_gc.c b/erts/emulator/beam/erl_gc.c index 4698458521..df5d0f4918 100644 --- a/erts/emulator/beam/erl_gc.c +++ b/erts/emulator/beam/erl_gc.c @@ -593,10 +593,6 @@ garbage_collect(Process* p, ErlHeapFragment *live_hf_end, esdp = erts_get_scheduler_data(); - if (IS_TRACED_FL(p, F_TRACE_GC)) { - trace_gc(p, am_gc_start); - } - erts_smp_atomic32_read_bor_nob(&p->state, ERTS_PSFLG_GC); if (erts_system_monitor_long_gc != 0) start_time = erts_get_monotonic_time(esdp); @@ -619,18 +615,29 @@ garbage_collect(Process* p, ErlHeapFragment *live_hf_end, */ if (GEN_GCS(p) < MAX_GEN_GCS(p) && !(FLAGS(p) & F_NEED_FULLSWEEP)) { - DTRACE2(gc_minor_start, pidbuf, need); - reds = minor_collection(p, live_hf_end, need, objv, nobj, &reclaimed_now); - DTRACE2(gc_minor_end, pidbuf, reclaimed_now); - if (reds < 0) - goto do_major_collection; - } - else { - do_major_collection: + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_minor_start, need); + } + DTRACE2(gc_minor_start, pidbuf, need); + reds = minor_collection(p, live_hf_end, need, objv, nobj, &reclaimed_now); + DTRACE2(gc_minor_end, pidbuf, reclaimed_now); + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_minor_end, reclaimed_now); + } + if (reds < 0) + goto do_major_collection; + } else { +do_major_collection: ERTS_MSACC_SET_STATE_CACHED_M_X(ERTS_MSACC_STATE_GC_FULL); - DTRACE2(gc_major_start, pidbuf, need); - reds = major_collection(p, live_hf_end, need, objv, nobj, &reclaimed_now); - DTRACE2(gc_major_end, pidbuf, reclaimed_now); + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_major_start, need); + } + DTRACE2(gc_major_start, pidbuf, need); + reds = major_collection(p, live_hf_end, need, objv, nobj, &reclaimed_now); + DTRACE2(gc_major_end, pidbuf, reclaimed_now); + if (IS_TRACED_FL(p, F_TRACE_GC)) { + trace_gc(p, am_gc_major_end, reclaimed_now); + } ERTS_MSACC_SET_STATE_CACHED_M_X(ERTS_MSACC_STATE_GC); } @@ -646,10 +653,6 @@ garbage_collect(Process* p, ErlHeapFragment *live_hf_end, erts_smp_atomic32_read_band_nob(&p->state, ~ERTS_PSFLG_GC); - if (IS_TRACED_FL(p, F_TRACE_GC)) { - trace_gc(p, am_gc_end); - } - if (erts_system_monitor_long_gc != 0) { ErtsMonotonicTime end_time; Uint gc_time; diff --git a/erts/emulator/beam/erl_nif.c b/erts/emulator/beam/erl_nif.c index 24e72cc949..941f44b9ec 100644 --- a/erts/emulator/beam/erl_nif.c +++ b/erts/emulator/beam/erl_nif.c @@ -3157,7 +3157,7 @@ Eterm erts_nif_call_function(Process *p, Process *tracee, /* Verify that function is part of this module */ int i; for (i = 0; i < mod->entry->num_of_funcs; i++) - if (fun == mod->entry->funcs+i) + if (fun == &(mod->entry->funcs[i])) break; ASSERT(i < mod->entry->num_of_funcs); if (p) diff --git a/erts/emulator/beam/erl_trace.c b/erts/emulator/beam/erl_trace.c index bd88769dfc..56899f574a 100644 --- a/erts/emulator/beam/erl_trace.c +++ b/erts/emulator/beam/erl_trace.c @@ -237,6 +237,7 @@ write_timestamp(ErtsTraceTimeStamp *tsp, Eterm **hpp) } } +#ifdef ERTS_SMP #define PATCH_TS_SIZE(p) patch_ts_size(TFLGS_TS_TYPE(p)) static ERTS_INLINE Uint @@ -257,6 +258,7 @@ patch_ts_size(int ts_type) return 0; } } +#endif /* * Write a timestamp. The timestamp MUST be the last @@ -359,25 +361,50 @@ void erts_init_trace(void) { *(OHPP) = &(*(BPP))->off_heap, \ (*(BPP))->mem) +enum ErtsTracerOpt { + TRACE_FUN_DEFAULT = 0, + TRACE_FUN_ENABLED = 1, + TRACE_FUN_T_SEND = 2, + TRACE_FUN_T_RECEIVE = 3, + TRACE_FUN_T_CALL = 4, + TRACE_FUN_T_SCHED_PROC = 5, + TRACE_FUN_T_SCHED_PORT = 6, + TRACE_FUN_T_GC = 7, + TRACE_FUN_T_PROCS = 8, + TRACE_FUN_T_PORTS = 9, + TRACE_FUN_E_SEND = 10, + TRACE_FUN_E_RECEIVE = 11, + TRACE_FUN_E_CALL = 12, + TRACE_FUN_E_SCHED_PROC = 13, + TRACE_FUN_E_SCHED_PORT = 14, + TRACE_FUN_E_GC = 15, + TRACE_FUN_E_PROCS = 16, + TRACE_FUN_E_PORTS = 17 +}; + +#define NIF_TRACER_TYPES (18) + + static ERTS_INLINE int send_to_tracer_nif_raw(Process *c_p, Process *tracee, const ErtsTracer tracer, Uint trace_flags, Eterm t_p_id, ErtsTracerNif *tnif, + enum ErtsTracerOpt topt, Eterm tag, Eterm msg, Eterm extra, Eterm pam_result); static ERTS_INLINE int send_to_tracer_nif(Process *c_p, ErtsPTabElementCommon *t_p, - Eterm t_p_id, ErtsTracerNif *tnif, Eterm tag, - Eterm msg, Eterm extra); + Eterm t_p_id, ErtsTracerNif *tnif, + enum ErtsTracerOpt topt, + Eterm tag, Eterm msg, Eterm extra); static ERTS_INLINE Eterm call_enabled_tracer(Process *c_p, const ErtsTracer tracer, - ErtsTracerNif **tnif_ref, Eterm tag, Eterm t_p_id); + ErtsTracerNif **tnif_ref, + enum ErtsTracerOpt topt, + Eterm tag, Eterm t_p_id); static int -is_tracer_proc_enabled(Process* c_p, ErtsProcLocks c_p_locks, - ErtsPTabElementCommon *t_p, - ErtsTracerNif **tnif_ret, Eterm tag); - -#define SEND_TO_TRACER(c_p, tag, msg) \ - send_to_tracer_nif(c_p, &(c_p)->common, (c_p)->common.id, NULL, tag, \ - msg, THE_NON_VALUE) +is_tracer_enabled(Process* c_p, ErtsProcLocks c_p_locks, + ErtsPTabElementCommon *t_p, + ErtsTracerNif **tnif_ret, + enum ErtsTracerOpt topt, Eterm tag); static Uint active_sched; @@ -433,7 +460,7 @@ erts_set_system_seq_tracer(Process *c_p, ErtsProcLocks c_p_locks, ErtsTracer new if (!ERTS_TRACER_IS_NIL(new)) { Eterm nif_result = call_enabled_tracer( NULL, new, NULL, - am_trace_status, am_undefined); + TRACE_FUN_ENABLED, am_trace_status, am_undefined); switch (nif_result) { case am_trace: break; default: @@ -465,7 +492,8 @@ erts_get_system_seq_tracer(void) erts_smp_rwmtx_runlock(&sys_trace_rwmtx); if (st != erts_tracer_nil && - call_enabled_tracer(NULL, st, NULL, am_trace_status, am_undefined) == am_remove) { + call_enabled_tracer(NULL, st, NULL, TRACE_FUN_ENABLED, + am_trace_status, am_undefined) == am_remove) { erts_set_system_seq_tracer(NULL, 0, erts_tracer_nil); st = erts_tracer_nil; } @@ -484,10 +512,11 @@ get_default_tracing(Uint *flagsp, ErtsTracer *tracerp, if (ERTS_TRACER_IS_NIL(*default_tracer)) { *default_trace_flags &= ~TRACEE_FLAGS; } else { - Eterm nif_result = call_enabled_tracer( - NULL, *default_tracer, NULL, - am_trace_status, am_undefined); - switch (nif_result) { + Eterm nif_res; + nif_res = call_enabled_tracer(NULL, *default_tracer, + NULL, TRACE_FUN_ENABLED, + am_trace_status, am_undefined); + switch (nif_res) { case am_trace: break; default: { ErtsTracer curr_default_tracer = *default_tracer; @@ -737,7 +766,7 @@ trace_sched_aux(Process *p, ErtsProcLocks locks, Eterm what) break; } - if (!is_tracer_proc_enabled(p, locks, &p->common, &tnif, what)) + if (!is_tracer_enabled(p, locks, &p->common, &tnif, TRACE_FUN_E_SCHED_PROC, what)) return; if (ERTS_PROC_IS_EXITING(p)) @@ -756,7 +785,7 @@ trace_sched_aux(Process *p, ErtsProcLocks locks, Eterm what) hp += 4; } - send_to_tracer_nif(p, &p->common, p->common.id, tnif, + send_to_tracer_nif(p, &p->common, p->common.id, tnif, TRACE_FUN_T_SCHED_PROC, what, tmp, THE_NON_VALUE); } @@ -795,8 +824,10 @@ trace_send(Process *p, Eterm to, Eterm msg) operation = am_send_to_non_existing_process; } - if (is_tracer_proc_enabled(p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, operation)) - send_to_tracer_nif(p, &p->common, p->common.id, tnif, operation, msg, to); + if (is_tracer_enabled(p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, + TRACE_FUN_E_SEND, operation)) + send_to_tracer_nif(p, &p->common, p->common.id, tnif, TRACE_FUN_T_SEND, + operation, msg, to); } /* Send {trace_ts, Pid, receive, Msg, Timestamp} @@ -806,10 +837,11 @@ void trace_receive(Process *c_p, Eterm msg) { ErtsTracerNif *tnif = NULL; - if (is_tracer_proc_enabled(NULL, 0, &c_p->common, - &tnif, am_receive)) + if (is_tracer_enabled(NULL, 0, &c_p->common, &tnif, + TRACE_FUN_E_RECEIVE, am_receive)) send_to_tracer_nif(NULL, &c_p->common, c_p->common.id, - tnif, am_receive, msg, THE_NON_VALUE); + tnif, TRACE_FUN_T_RECEIVE, + am_receive, msg, THE_NON_VALUE); } int @@ -819,8 +851,9 @@ seq_trace_update_send(Process *p) ASSERT((is_tuple(SEQ_TRACE_TOKEN(p)) || is_nil(SEQ_TRACE_TOKEN(p)))); if (have_no_seqtrace(SEQ_TRACE_TOKEN(p)) || (seq_tracer != NIL && - call_enabled_tracer( NULL, seq_tracer, NULL, am_trace_status, - p ? p->common.id : am_undefined) != am_trace) + call_enabled_tracer(NULL, seq_tracer, NULL, + TRACE_FUN_ENABLED, am_trace_status, + p ? p->common.id : am_undefined) != am_trace) #ifdef USE_VM_PROBES || (SEQ_TRACE_TOKEN(p) == am_have_dt_utag) #endif @@ -866,9 +899,10 @@ seq_trace_output_generic(Eterm token, Eterm msg, Uint type, ASSERT(is_tuple(token) || is_nil(token)); if (token == NIL || (process && ERTS_TRACE_FLAGS(process) & F_SENSITIVE) || ERTS_TRACER_IS_NIL(seq_tracer) || - call_enabled_tracer( - NULL, seq_tracer, NULL, am_trace_status, - process ? process->common.id : am_undefined) != am_trace) { + call_enabled_tracer(NULL, seq_tracer, + NULL, TRACE_FUN_ENABLED, + am_trace_status, + process ? process->common.id : am_undefined) != am_trace) { return; } @@ -897,14 +931,13 @@ seq_trace_output_generic(Eterm token, Eterm msg, Uint type, msg = TUPLE3(hp, am_EXIT, exitfrom, msg); hp += 4; } - mess = TUPLE5(hp, type_atom, lastcnt_serial, SEQ_TRACE_T_SENDER(token), - receiver, msg); + mess = TUPLE5(hp, type_atom, lastcnt_serial, SEQ_TRACE_T_SENDER(token), receiver, msg); hp += 6; seq_tracer_flags |= ERTS_SEQTFLGS2TFLGS(unsigned_val(SEQ_TRACE_T_FLAGS(token))); send_to_tracer_nif_raw(NULL, process, seq_tracer, seq_tracer_flags, - label, NULL, am_seq_trace, mess, + label, NULL, TRACE_FUN_DEFAULT, am_seq_trace, mess, THE_NON_VALUE, am_true); UnUseTmpHeapNoproc(LOCAL_HEAP_SIZE); @@ -929,7 +962,8 @@ erts_trace_return_to(Process *p, BeamInstr *pc) mfa = TUPLE3(hp, code_ptr[0], code_ptr[1], make_small(code_ptr[2])); } - SEND_TO_TRACER(p, am_return_to, mfa); + send_to_tracer_nif(p, &p->common, p->common.id, NULL, TRACE_FUN_T_CALL, + am_return_to, mfa, THE_NON_VALUE); } @@ -983,7 +1017,7 @@ erts_trace_return(Process* p, BeamInstr* fi, Eterm retval, ErtsTracer *tracer) mfa = TUPLE3(hp, mod, name, make_small(arity)); hp += 4; send_to_tracer_nif_raw(p, NULL, *tracer, *tracee_flags, p->common.id, - NULL, am_return_from, mfa, retval, am_true); + NULL, TRACE_FUN_T_CALL, am_return_from, mfa, retval, am_true); } /* Send {trace_ts, Pid, exception_from, {Mod, Name, Arity}, {Class,Value}, @@ -1038,7 +1072,7 @@ erts_trace_exception(Process* p, BeamInstr mfa[3], Eterm class, Eterm value, cv = TUPLE2(hp, class, value); hp += 3; send_to_tracer_nif_raw(p, NULL, *tracer, *tracee_flags, p->common.id, - NULL, am_exception_from, mfa_tuple, cv, am_true); + NULL, TRACE_FUN_T_CALL, am_exception_from, mfa_tuple, cv, am_true); } /* @@ -1088,7 +1122,8 @@ erts_call_trace(Process* p, BeamInstr mfa[3], Binary *match_spec, * use process flags */ tracee_flags = &ERTS_TRACE_FLAGS(p); - if (!is_tracer_proc_enabled(p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, am_call)) { + if (!is_tracer_enabled(p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, + TRACE_FUN_E_CALL, am_call)) { return 0; } } else { @@ -1103,7 +1138,9 @@ erts_call_trace(Process* p, BeamInstr mfa[3], Binary *match_spec, } meta_flags = F_TRACE_CALLS | F_NOW_TS; tracee_flags = &meta_flags; - switch (call_enabled_tracer(p, *tracer, &tnif, am_call, p->common.id)) { + switch (call_enabled_tracer(p, *tracer, + &tnif, TRACE_FUN_T_CALL, + am_call, p->common.id)) { default: case am_remove: *tracer = erts_tracer_nil; case am_discard: return 0; @@ -1227,7 +1264,7 @@ erts_call_trace(Process* p, BeamInstr mfa[3], Binary *match_spec, * Build the trace tuple and send it to the port. */ send_to_tracer_nif_raw(p, NULL, *tracer, *tracee_flags, p->common.id, - tnif, am_call, mfa_tuple, THE_NON_VALUE, pam_result); + tnif, TRACE_FUN_T_CALL, am_call, mfa_tuple, THE_NON_VALUE, pam_result); erts_match_set_release_result(p); if (match_spec && tracer == &pre_ms_tracer) @@ -1249,8 +1286,9 @@ trace_proc(Process *c_p, ErtsProcLocks c_p_locks, Process *t_p, Eterm what, Eterm data) { ErtsTracerNif *tnif = NULL; - if (is_tracer_proc_enabled(c_p, c_p_locks, &t_p->common, &tnif, what)) - send_to_tracer_nif(c_p, &t_p->common, t_p->common.id, tnif, + if (is_tracer_enabled(c_p, c_p_locks, &t_p->common, &tnif, + TRACE_FUN_E_PROCS, what)) + send_to_tracer_nif(c_p, &t_p->common, t_p->common.id, tnif, TRACE_FUN_T_PROCS, what, data, THE_NON_VALUE); } @@ -1267,16 +1305,17 @@ trace_proc_spawn(Process *p, Eterm what, Eterm pid, Eterm mod, Eterm func, Eterm args) { ErtsTracerNif *tnif = NULL; - if (is_tracer_proc_enabled(p, ERTS_PROC_LOCKS_ALL & + if (is_tracer_enabled(p, ERTS_PROC_LOCKS_ALL & ~(ERTS_PROC_LOCK_STATUS|ERTS_PROC_LOCK_TRACE), - &p->common, &tnif, what)) { + &p->common, &tnif, TRACE_FUN_E_PROCS, what)) { Eterm mfa; Eterm* hp; hp = HAlloc(p, 4); mfa = TUPLE3(hp, mod, func, args); hp += 4; - send_to_tracer_nif(p, &p->common, p->common.id, tnif, what, pid, mfa); + send_to_tracer_nif(p, &p->common, p->common.id, tnif, TRACE_FUN_T_PROCS, + what, pid, mfa); } } @@ -1308,23 +1347,25 @@ void save_calls(Process *p, Export *e) * are all small (atomic) integers. */ void -trace_gc(Process *p, Eterm what) +trace_gc(Process *p, Eterm what, Uint size) { ErtsTracerNif *tnif = NULL; Eterm* hp; Eterm msg = NIL; - Uint size = 0; + Uint sz = 0; + Eterm tup; - if (is_tracer_proc_enabled( - p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, what)) { + if (is_tracer_enabled(p, ERTS_PROC_LOCK_MAIN, &p->common, &tnif, TRACE_FUN_E_GC, what)) { - (void) erts_process_gc_info(p, &size, NULL); - hp = HAlloc(p, size); + (void) erts_process_gc_info(p, &sz, NULL); + hp = HAlloc(p, sz + 3 + 2); msg = erts_process_gc_info(p, NULL, &hp); + tup = TUPLE2(hp, am_wordsize, make_small(size)); hp += 3; + msg = CONS(hp, tup, msg); hp += 2; - send_to_tracer_nif(p, &p->common, p->common.id, tnif, what, - msg, THE_NON_VALUE); + send_to_tracer_nif(p, &p->common, p->common.id, tnif, TRACE_FUN_T_GC, + what, msg, am_undefined); } } @@ -1737,9 +1778,9 @@ void trace_port_open(Port *p, Eterm calling_pid, Eterm drv_name) { ErtsTracerNif *tnif = NULL; ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &p->common, &tnif, am_open)) - send_to_tracer_nif(NULL, &p->common, p->common.id, tnif, am_open, - calling_pid, drv_name); + if (is_tracer_enabled(NULL, 0, &p->common, &tnif, TRACE_FUN_E_PORTS, am_open)) + send_to_tracer_nif(NULL, &p->common, p->common.id, tnif, TRACE_FUN_T_PORTS, + am_open, calling_pid, drv_name); } /* Sends trace message: @@ -1756,8 +1797,8 @@ trace_port(Port *t_p, Eterm what, Eterm data) { ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(t_p) || erts_thr_progress_is_blocking()); ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &t_p->common, &tnif, what)) - send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, + if (is_tracer_enabled(NULL, 0, &t_p->common, &tnif, TRACE_FUN_E_PORTS, what)) + send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, TRACE_FUN_T_PORTS, what, data, THE_NON_VALUE); } @@ -1802,7 +1843,7 @@ trace_port_receive(Port *t_p, Eterm caller, Eterm what, ...) ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(t_p) || erts_thr_progress_is_blocking()); ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &t_p->common, &tnif, am_receive)) { + if (is_tracer_enabled(NULL, 0, &t_p->common, &tnif, TRACE_FUN_E_RECEIVE, am_receive)) { /* We can use a stack heap here, as the nif is called in the context of a port */ #define LOCAL_HEAP_SIZE (3 + 3 + heap_bin_size(ERL_ONHEAP_BIN_LIMIT) + 3) @@ -1894,7 +1935,7 @@ trace_port_receive(Port *t_p, Eterm caller, Eterm what, ...) } data = TUPLE2(hp, caller, data); - send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, + send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, TRACE_FUN_T_RECEIVE, am_receive, data, THE_NON_VALUE); if (bptr && erts_refc_dectest(&bptr->refc, 1) == 0) @@ -1916,8 +1957,8 @@ trace_port_send(Port *t_p, Eterm receiver, Eterm msg, int exists) ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(t_p) || erts_thr_progress_is_blocking()); ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &t_p->common, &tnif, op)) - send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, + if (is_tracer_enabled(NULL, 0, &t_p->common, &tnif, TRACE_FUN_E_SEND, op)) + send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, TRACE_FUN_T_SEND, op, msg, receiver); } @@ -1927,7 +1968,7 @@ void trace_port_send_binary(Port *t_p, Eterm to, Eterm what, char *bin, Sint sz) ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(t_p) || erts_thr_progress_is_blocking()); ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &t_p->common, &tnif, am_send)) { + if (is_tracer_enabled(NULL, 0, &t_p->common, &tnif, TRACE_FUN_E_SEND, am_send)) { Eterm msg; Binary* bptr = NULL; #define LOCAL_HEAP_SIZE (3 + 3 + heap_bin_size(ERL_ONHEAP_BIN_LIMIT)) @@ -1946,7 +1987,7 @@ void trace_port_send_binary(Port *t_p, Eterm to, Eterm what, char *bin, Sint sz) msg = TUPLE2(hp, t_p->common.id, msg); hp += 3; - send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, + send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, tnif, TRACE_FUN_T_SEND, am_send, msg, to); if (bptr && erts_refc_dectest(&bptr->refc, 1) == 0) erts_bin_free(bptr); @@ -1975,9 +2016,10 @@ trace_sched_ports_where(Port *t_p, Eterm what, Eterm where) { ERTS_SMP_LC_ASSERT(erts_lc_is_port_locked(t_p) || erts_thr_progress_is_blocking()); ERTS_SMP_CHK_NO_PROC_LOCKS; - if (is_tracer_proc_enabled(NULL, 0, &t_p->common, &tnif, what)) + if (is_tracer_enabled(NULL, 0, &t_p->common, &tnif, TRACE_FUN_E_SCHED_PORT, what)) send_to_tracer_nif(NULL, &t_p->common, t_p->common.id, - tnif, what, where, THE_NON_VALUE); + tnif, TRACE_FUN_T_SCHED_PORT, + what, where, THE_NON_VALUE); } /* Port profiling */ @@ -2523,14 +2565,97 @@ init_sys_msg_dispatcher(void) #include "erl_nif.h" +typedef struct { + char *name; + Uint arity; + ErlNifFunc *cb; +} ErtsTracerType; + struct ErtsTracerNif_ { HashBucket hb; Eterm module; struct erl_module_nif* nif_mod; - ErlNifFunc *enabled; - ErlNifFunc *trace; + ErtsTracerType tracers[NIF_TRACER_TYPES]; }; +static void init_tracer_template(ErtsTracerNif *tnif) { + + /* default tracer functions */ + tnif->tracers[TRACE_FUN_DEFAULT].name = "trace"; + tnif->tracers[TRACE_FUN_DEFAULT].arity = 6; + tnif->tracers[TRACE_FUN_DEFAULT].cb = NULL; + + tnif->tracers[TRACE_FUN_ENABLED].name = "enabled"; + tnif->tracers[TRACE_FUN_ENABLED].arity = 3; + tnif->tracers[TRACE_FUN_ENABLED].cb = NULL; + + /* specific tracer functions */ + tnif->tracers[TRACE_FUN_T_SEND].name = "trace_send"; + tnif->tracers[TRACE_FUN_T_SEND].arity = 6; + tnif->tracers[TRACE_FUN_T_SEND].cb = NULL; + + tnif->tracers[TRACE_FUN_T_RECEIVE].name = "trace_receive"; + tnif->tracers[TRACE_FUN_T_RECEIVE].arity = 6; + tnif->tracers[TRACE_FUN_T_RECEIVE].cb = NULL; + + tnif->tracers[TRACE_FUN_T_CALL].name = "trace_call"; + tnif->tracers[TRACE_FUN_T_CALL].arity = 6; + tnif->tracers[TRACE_FUN_T_CALL].cb = NULL; + + tnif->tracers[TRACE_FUN_T_SCHED_PROC].name = "trace_running_procs"; + tnif->tracers[TRACE_FUN_T_SCHED_PROC].arity = 6; + tnif->tracers[TRACE_FUN_T_SCHED_PROC].cb = NULL; + + tnif->tracers[TRACE_FUN_T_SCHED_PORT].name = "trace_running_ports"; + tnif->tracers[TRACE_FUN_T_SCHED_PORT].arity = 6; + tnif->tracers[TRACE_FUN_T_SCHED_PORT].cb = NULL; + + tnif->tracers[TRACE_FUN_T_GC].name = "trace_garbage_collection"; + tnif->tracers[TRACE_FUN_T_GC].arity = 6; + tnif->tracers[TRACE_FUN_T_GC].cb = NULL; + + tnif->tracers[TRACE_FUN_T_PROCS].name = "trace_procs"; + tnif->tracers[TRACE_FUN_T_PROCS].arity = 6; + tnif->tracers[TRACE_FUN_T_PROCS].cb = NULL; + + tnif->tracers[TRACE_FUN_T_PORTS].name = "trace_ports"; + tnif->tracers[TRACE_FUN_T_PORTS].arity = 6; + tnif->tracers[TRACE_FUN_T_PORTS].cb = NULL; + + /* specific enabled functions */ + tnif->tracers[TRACE_FUN_E_SEND].name = "enabled_send"; + tnif->tracers[TRACE_FUN_E_SEND].arity = 3; + tnif->tracers[TRACE_FUN_E_SEND].cb = NULL; + + tnif->tracers[TRACE_FUN_E_RECEIVE].name = "enabled_receive"; + tnif->tracers[TRACE_FUN_E_RECEIVE].arity = 3; + tnif->tracers[TRACE_FUN_E_RECEIVE].cb = NULL; + + tnif->tracers[TRACE_FUN_E_CALL].name = "enabled_call"; + tnif->tracers[TRACE_FUN_E_CALL].arity = 3; + tnif->tracers[TRACE_FUN_E_CALL].cb = NULL; + + tnif->tracers[TRACE_FUN_E_SCHED_PROC].name = "enabled_running_procs"; + tnif->tracers[TRACE_FUN_E_SCHED_PROC].arity = 3; + tnif->tracers[TRACE_FUN_E_SCHED_PROC].cb = NULL; + + tnif->tracers[TRACE_FUN_E_SCHED_PORT].name = "enabled_running_ports"; + tnif->tracers[TRACE_FUN_E_SCHED_PORT].arity = 3; + tnif->tracers[TRACE_FUN_E_SCHED_PORT].cb = NULL; + + tnif->tracers[TRACE_FUN_E_GC].name = "enabled_garbage_collection"; + tnif->tracers[TRACE_FUN_E_GC].arity = 3; + tnif->tracers[TRACE_FUN_E_GC].cb = NULL; + + tnif->tracers[TRACE_FUN_E_PROCS].name = "enabled_procs"; + tnif->tracers[TRACE_FUN_E_PROCS].arity = 3; + tnif->tracers[TRACE_FUN_E_PROCS].cb = NULL; + + tnif->tracers[TRACE_FUN_E_PORTS].name = "enabled_ports"; + tnif->tracers[TRACE_FUN_E_PORTS].arity = 3; + tnif->tracers[TRACE_FUN_E_PORTS].cb = NULL; +} + static Hash *tracer_hash = NULL; static erts_smp_rwmtx_t tracer_mtx; @@ -2543,31 +2668,32 @@ load_tracer_nif(const ErtsTracer tracer) ErlNifFunc *funcs; int num_of_funcs; ErtsTracerNif tnif_tmpl, *tnif; - int i; + ErtsTracerType *tracers; + int i,j; - if (mod && mod->curr.nif != NULL) { - instance = &mod->curr; - } else { + if (!mod || !mod->curr.nif) { return NULL; } - tnif_tmpl.enabled = NULL; - tnif_tmpl.trace = NULL; + instance = &mod->curr; + + init_tracer_template(&tnif_tmpl); tnif_tmpl.nif_mod = instance->nif; tnif_tmpl.module = ERTS_TRACER_MODULE(tracer); + tracers = tnif_tmpl.tracers; num_of_funcs = erts_nif_get_funcs(instance->nif, &funcs); for(i = 0; i < num_of_funcs; i++) { - if (strcmp("enabled",funcs[i].name) == 0 && funcs[i].arity == 3) { - tnif_tmpl.enabled = funcs + i; - } else if (strcmp("trace",funcs[i].name) == 0 && funcs[i].arity == 6) { - tnif_tmpl.trace = funcs + i; + for (j = 0; j < NIF_TRACER_TYPES; j++) { + if (strcmp(tracers[j].name, funcs[i].name) == 0 && tracers[j].arity == funcs[i].arity) { + tracers[j].cb = &(funcs[i]); + break; + } } } - if (tnif_tmpl.enabled == NULL || - tnif_tmpl.trace == NULL ) { + if (tracers[TRACE_FUN_DEFAULT].cb == NULL || tracers[TRACE_FUN_ENABLED].cb == NULL ) { return NULL; } @@ -2660,17 +2786,18 @@ erts_tracer_to_term(Process *p, ErtsTracer tracer) static ERTS_INLINE int send_to_tracer_nif_raw(Process *c_p, Process *tracee, const ErtsTracer tracer, Uint tracee_flags, - Eterm t_p_id, ErtsTracerNif *tnif, Eterm tag, Eterm msg, - Eterm extra, Eterm pam_result) + Eterm t_p_id, ErtsTracerNif *tnif, + enum ErtsTracerOpt topt, + Eterm tag, Eterm msg, Eterm extra, Eterm pam_result) { if (tnif || (tnif = lookup_tracer_nif(tracer)) != NULL) { #define MAP_SIZE 3 - Eterm argv[6], - local_heap[3+MAP_SIZE /* values */+(MAP_SIZE+1 /* keys */)]; + Eterm argv[6], local_heap[3+MAP_SIZE /* values */ + (MAP_SIZE+1 /* keys */)]; flatmap_t *map = (flatmap_t*)(local_heap+(MAP_SIZE+1)); Eterm *map_values = flatmap_get_values(map); - int argc = 6; + topt = (tnif->tracers[topt].cb) ? topt : TRACE_FUN_DEFAULT; + ASSERT(topt < NIF_TRACER_TYPES); argv[0] = tag; argv[1] = ERTS_TRACER_STATE(tracer); @@ -2681,8 +2808,7 @@ send_to_tracer_nif_raw(Process *c_p, Process *tracee, map->thing_word = MAP_HEADER_FLATMAP; map->size = MAP_SIZE; - map->keys = TUPLE3(local_heap, am_match_spec_result, am_scheduler_id, - am_timestamp); + map->keys = TUPLE3(local_heap, am_match_spec_result, am_scheduler_id, am_timestamp); *map_values++ = pam_result; if (tracee_flags & F_TRACE_SCHED_NO) @@ -2705,16 +2831,18 @@ send_to_tracer_nif_raw(Process *c_p, Process *tracee, #undef MAP_SIZE erts_nif_call_function(c_p, tracee ? tracee : c_p, - tnif->nif_mod, tnif->trace, argc, argv); + tnif->nif_mod, + tnif->tracers[topt].cb, + tnif->tracers[topt].arity, + argv); } return 1; } - static ERTS_INLINE int send_to_tracer_nif(Process *c_p, ErtsPTabElementCommon *t_p, - Eterm t_p_id, ErtsTracerNif *tnif, Eterm tag, - Eterm msg, Eterm extra) + Eterm t_p_id, ErtsTracerNif *tnif, enum ErtsTracerOpt topt, + Eterm tag, Eterm msg, Eterm extra) { #if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) if (c_p) { @@ -2733,29 +2861,35 @@ send_to_tracer_nif(Process *c_p, ErtsPTabElementCommon *t_p, return send_to_tracer_nif_raw(c_p, is_internal_pid(t_p->id) ? (Process*)t_p : NULL, t_p->tracer, t_p->trace_flags, - t_p_id, tnif, tag, msg, extra, + t_p_id, tnif, topt, tag, msg, extra, am_true); } static ERTS_INLINE Eterm call_enabled_tracer(Process *c_p, const ErtsTracer tracer, - ErtsTracerNif **tnif_ret, Eterm tag, Eterm t_p_id) -{ + ErtsTracerNif **tnif_ret, + enum ErtsTracerOpt topt, + Eterm tag, Eterm t_p_id) { ErtsTracerNif *tnif = lookup_tracer_nif(tracer); if (tnif) { Eterm argv[] = {tag, ERTS_TRACER_STATE(tracer), t_p_id}; + topt = (tnif->tracers[topt].cb) ? topt : TRACE_FUN_ENABLED; + ASSERT(topt < NIF_TRACER_TYPES); + ASSERT(tnif->tracers[topt].cb != NULL); if (tnif_ret) *tnif_ret = tnif; - return erts_nif_call_function( - c_p, NULL, tnif->nif_mod, tnif->enabled, 3, argv); + return erts_nif_call_function(c_p, NULL, tnif->nif_mod, + tnif->tracers[topt].cb, + tnif->tracers[topt].arity, + argv); } return am_remove; } static int -is_tracer_proc_enabled(Process* c_p, ErtsProcLocks c_p_locks, - ErtsPTabElementCommon *t_p, - ErtsTracerNif **tnif_ret, Eterm tag) -{ +is_tracer_enabled(Process* c_p, ErtsProcLocks c_p_locks, + ErtsPTabElementCommon *t_p, + ErtsTracerNif **tnif_ret, + enum ErtsTracerOpt topt, Eterm tag) { Eterm nif_result; #if defined(ERTS_SMP) && defined(ERTS_ENABLE_LOCK_CHECK) @@ -2773,7 +2907,7 @@ is_tracer_proc_enabled(Process* c_p, ErtsProcLocks c_p_locks, } #endif - nif_result = call_enabled_tracer(c_p, t_p->tracer, tnif_ret, tag, t_p->id); + nif_result = call_enabled_tracer(c_p, t_p->tracer, tnif_ret, topt, tag, t_p->id); switch (nif_result) { case am_discard: return 0; case am_trace: return 1; @@ -2806,14 +2940,13 @@ is_tracer_proc_enabled(Process* c_p, ErtsProcLocks c_p_locks, erts_smp_proc_unlock(c_p, c_p_xlocks); } - return 0; } int erts_is_tracer_proc_enabled(Process* c_p, ErtsProcLocks c_p_locks, ErtsPTabElementCommon *t_p, Eterm type) { - return is_tracer_proc_enabled(c_p, c_p_locks, t_p, NULL, am_trace_status); + return is_tracer_enabled(c_p, c_p_locks, t_p, NULL, TRACE_FUN_ENABLED, am_trace_status); } int erts_is_tracer_enabled(Process *c_p, const ErtsTracer tracer) @@ -2821,7 +2954,7 @@ int erts_is_tracer_enabled(Process *c_p, const ErtsTracer tracer) ErtsTracerNif *tnif = lookup_tracer_nif(tracer); if (tnif) { Eterm nif_result = call_enabled_tracer(c_p, tracer, &tnif, - am_trace_status, + TRACE_FUN_ENABLED, am_trace_status, c_p->common.id); switch (nif_result) { case am_discard: diff --git a/erts/emulator/beam/erl_trace.h b/erts/emulator/beam/erl_trace.h index 177fd373a6..9a007e62ec 100644 --- a/erts/emulator/beam/erl_trace.h +++ b/erts/emulator/beam/erl_trace.h @@ -103,7 +103,7 @@ void trace_sched(Process*, ErtsProcLocks, Eterm); void trace_proc(Process*, ErtsProcLocks, Process*, Eterm, Eterm); void trace_proc_spawn(Process*, Eterm what, Eterm pid, Eterm mod, Eterm func, Eterm args); void save_calls(Process *p, Export *); -void trace_gc(Process *p, Eterm what); +void trace_gc(Process *p, Eterm what, Uint size); /* port tracing */ void trace_virtual_sched(Process*, ErtsProcLocks, Eterm); void trace_sched_ports(Port *pp, Eterm); diff --git a/erts/emulator/beam/external.c b/erts/emulator/beam/external.c index 723c25ff77..3c002d43a7 100644 --- a/erts/emulator/beam/external.c +++ b/erts/emulator/beam/external.c @@ -4429,22 +4429,32 @@ init_done: SKIP(1+atom_extra_skip); atom_extra_skip = 0; break; - case PID_EXT: case NEW_PID_EXT: + atom_extra_skip = 12; + goto case_PID; + case PID_EXT: atom_extra_skip = 9; + case_PID: /* In case it is an external pid */ heap_size += EXTERNAL_THING_HEAD_SIZE + 1; terms++; break; - case PORT_EXT: case NEW_PORT_EXT: + atom_extra_skip = 8; + goto case_PORT; + case PORT_EXT: atom_extra_skip = 5; + case_PORT: /* In case it is an external port */ heap_size += EXTERNAL_THING_HEAD_SIZE + 1; terms++; break; - case NEW_REFERENCE_EXT: case NEWER_REFERENCE_EXT: + atom_extra_skip = 4; + goto case_NEW_REFERENCE; + case NEW_REFERENCE_EXT: + atom_extra_skip = 1; + case_NEW_REFERENCE: { int id_words; @@ -4455,7 +4465,7 @@ init_done: goto error; ep += 2; - atom_extra_skip = 1 + 4*id_words; + atom_extra_skip += 4*id_words; /* In case it is an external ref */ #if defined(ARCH_64) heap_size += EXTERNAL_THING_HEAD_SIZE + id_words/2 + 1; diff --git a/erts/emulator/nifs/common/erl_tracer_nif.c b/erts/emulator/nifs/common/erl_tracer_nif.c index a1e0e581a4..1bb6b940c4 100644 --- a/erts/emulator/nifs/common/erl_tracer_nif.c +++ b/erts/emulator/nifs/common/erl_tracer_nif.c @@ -72,6 +72,12 @@ ERL_NIF_INIT(erl_tracer, nif_funcs, load, NULL, upgrade, unload) ATOM_DECL(trace); \ ATOM_DECL(trace_ts); \ ATOM_DECL(true); \ + ATOM_DECL(gc_start); \ + ATOM_DECL(gc_end); \ + ATOM_DECL(gc_minor_start); \ + ATOM_DECL(gc_minor_end); \ + ATOM_DECL(gc_major_start); \ + ATOM_DECL(gc_major_end); \ ATOM_DECL(undefined); #define ATOM_DECL(A) static ERL_NIF_TERM atom_##A diff --git a/erts/emulator/sys/unix/sys_float.c b/erts/emulator/sys/unix/sys_float.c index 60661d9016..6435da086f 100644 --- a/erts/emulator/sys/unix/sys_float.c +++ b/erts/emulator/sys/unix/sys_float.c @@ -53,7 +53,7 @@ static void erts_init_fp_exception(void) void erts_thread_init_fp_exception(void) { unsigned long *fpe = erts_alloc(ERTS_ALC_T_FP_EXCEPTION, sizeof(*fpe)); - *fpe = 0L; + *fpe = 0; erts_tsd_set(fpe_key, fpe); } @@ -102,6 +102,17 @@ void erts_fp_check_init_error(volatile unsigned long *fpexnp) #define __DARWIN__ 1 #endif +/* + * Define two processor and possibly OS-specific primitives: + * + * static void unmask_fpe(void); + * -- unmask invalid, overflow, and divide-by-zero exceptions + * + * static int mask_fpe(void); + * -- mask invalid, overflow, and divide-by-zero exceptions + * -- return non-zero if the previous state was unmasked + */ + #if (defined(__i386__) || defined(__x86_64__)) && defined(__GNUC__) static void unmask_x87(void) @@ -113,7 +124,6 @@ static void unmask_x87(void) __asm__ __volatile__("fldcw %0" : : "m"(cw)); } -/* mask x87 FPE, return true if the previous state was unmasked */ static int mask_x87(void) { unsigned short cw; @@ -136,7 +146,6 @@ static void unmask_sse2(void) __asm__ __volatile__("ldmxcsr %0" : : "m"(mxcsr)); } -/* mask SSE2 FPE, return true if the previous state was unmasked */ static int mask_sse2(void) { unsigned int mxcsr; @@ -257,21 +266,19 @@ static int cpu_has_sse2(void) } #endif /* !__x86_64__ */ -static void unmask_fpe(void) +static void unmask_fpe_internal(void) { - __asm__ __volatile__("fnclex"); unmask_x87(); if (cpu_has_sse2()) unmask_sse2(); } -static void unmask_fpe_conditional(int unmasked) +static void unmask_fpe(void) { - if (unmasked) - unmask_fpe(); + __asm__ __volatile__("fnclex"); + unmask_fpe_internal(); } -/* mask x86 FPE, return true if the previous state was unmasked */ static int mask_fpe(void) { int unmasked; @@ -285,9 +292,7 @@ static int mask_fpe(void) void erts_restore_fpu(void) { __asm__ __volatile__("fninit"); - unmask_x87(); - if (cpu_has_sse2()) - unmask_sse2(); + unmask_fpe_internal(); } #elif defined(__sparc__) && defined(__linux__) @@ -310,13 +315,6 @@ static void unmask_fpe(void) __asm__ __volatile__(LDX " %0, %%fsr" : : "m"(fsr)); } -static void unmask_fpe_conditional(int unmasked) -{ - if (unmasked) - unmask_fpe(); -} - -/* mask SPARC FPE, return true if the previous state was unmasked */ static int mask_fpe(void) { unsigned long fsr; @@ -431,13 +429,6 @@ static void unmask_fpe(void) set_fpscr(0x80|0x40|0x10); /* VE, OE, ZE; not UE or XE */ } -static void unmask_fpe_conditional(int unmasked) -{ - if (unmasked) - unmask_fpe(); -} - -/* mask PowerPC FPE, return true if the previous state was unmasked */ static int mask_fpe(void) { int unmasked; @@ -447,20 +438,13 @@ static int mask_fpe(void) return unmasked; } -#else +#else /* !(x86 || (sparc && linux) || (powerpc && (linux || darwin))) */ static void unmask_fpe(void) { fpsetmask(FP_X_INV | FP_X_OFL | FP_X_DZ); } -static void unmask_fpe_conditional(int unmasked) -{ - if (unmasked) - unmask_fpe(); -} - -/* mask IEEE FPE, return true if previous state was unmasked */ static int mask_fpe(void) { const fp_except unmasked_mask = FP_X_INV | FP_X_OFL | FP_X_DZ; @@ -472,6 +456,16 @@ static int mask_fpe(void) #endif +/* + * Define a processor and OS-specific SIGFPE handler. + * + * The effect of receiving a SIGFPE should be: + * 1. Update the processor context: + * a) on x86: mask FP exceptions, do not skip faulting instruction + * b) on SPARC and PowerPC: unmask FP exceptions, skip faulting instruction + * 2. call set_current_fp_exception with the PC of the faulting instruction + */ + #if (defined(__linux__) && (defined(__i386__) || defined(__x86_64__) || defined(__sparc__) || defined(__powerpc__))) || (defined(__DARWIN__) && (defined(__i386__) || defined(__x86_64__) || defined(__ppc__))) || (defined(__FreeBSD__) && (defined(__x86_64__) || defined(__i386__))) || ((defined(__NetBSD__) || defined(__OpenBSD__)) && defined(__x86_64__)) || (defined(__sun__) && defined(__x86_64__)) #if defined(__linux__) && defined(__i386__) @@ -520,8 +514,7 @@ static void fpe_sig_action(int sig, siginfo_t *si, void *puc) ucontext_t *uc = puc; unsigned long pc; -#if defined(__linux__) -#if defined(__x86_64__) +#if defined(__linux__) && defined(__x86_64__) mcontext_t *mc = &uc->uc_mcontext; fpregset_t fpstate = mc->fpregs; pc = mc_pc(mc); @@ -533,26 +526,26 @@ static void fpe_sig_action(int sig, siginfo_t *si, void *puc) set encoding makes that a poor solution here. */ fpstate->mxcsr = 0x1F80; fpstate->swd &= ~0xFF; -#elif defined(__i386__) +#elif defined(__linux__) && defined(__i386__) mcontext_t *mc = &uc->uc_mcontext; fpregset_t fpstate = mc->fpregs; pc = mc_pc(mc); if ((fpstate->status >> 16) == X86_FXSR_MAGIC) ((struct _fpstate*)fpstate)->mxcsr = 0x1F80; fpstate->sw &= ~0xFF; -#elif defined(__sparc__) && defined(__arch64__) +#elif defined(__linux__) && defined(__sparc__) && defined(__arch64__) /* on SPARC the 3rd parameter points to a sigcontext not a ucontext */ struct sigcontext *sc = (struct sigcontext*)puc; pc = sc->sigc_regs.tpc; sc->sigc_regs.tpc = sc->sigc_regs.tnpc; sc->sigc_regs.tnpc += 4; -#elif defined(__sparc__) +#elif defined(__linux__) && defined(__sparc__) /* on SPARC the 3rd parameter points to a sigcontext not a ucontext */ struct sigcontext *sc = (struct sigcontext*)puc; pc = sc->si_regs.pc; sc->si_regs.pc = sc->si_regs.npc; sc->si_regs.npc = (unsigned long)sc->si_regs.npc + 4; -#elif defined(__powerpc__) +#elif defined(__linux__) && defined(__powerpc__) #if defined(__powerpc64__) mcontext_t *mc = &uc->uc_mcontext; unsigned long *regs = &mc->gp_regs[0]; @@ -563,7 +556,6 @@ static void fpe_sig_action(int sig, siginfo_t *si, void *puc) pc = regs[PT_NIP]; regs[PT_NIP] += 4; regs[PT_FPSCR] = 0x80|0x40|0x10; /* VE, OE, ZE; not UE or XE */ -#endif #elif defined(__DARWIN__) && (defined(__i386__) || defined(__x86_64__)) # error "Floating-point exceptions not supported on MacOS X" #elif defined(__DARWIN__) && defined(__ppc__) @@ -621,7 +613,7 @@ static void fpe_sig_action(int sig, siginfo_t *si, void *puc) #endif #if 0 { - char buf[64]; + char buf[128]; snprintf(buf, sizeof buf, "%s: FPE at %p\r\n", __FUNCTION__, (void*)pc); write(2, buf, strlen(buf)); } @@ -706,7 +698,8 @@ int erts_sys_block_fpe(void) void erts_sys_unblock_fpe(int unmasked) { - unmask_fpe_conditional(unmasked); + if (unmasked) + unmask_fpe(); } #endif @@ -818,11 +811,6 @@ sys_chars_to_double(char* buf, double* fp) int matherr(struct exception *exc) { -#if !defined(NO_FPE_SIGNALS) - volatile unsigned long *fpexnp = erts_get_current_fp_exception(); - if (fpexnp != NULL) - *fpexnp = (unsigned long)__builtin_return_address(0); -#endif return 1; } diff --git a/erts/emulator/sys/win32/sys_float.c b/erts/emulator/sys/win32/sys_float.c index a2b9bd1263..2b2d6ab7d3 100644 --- a/erts/emulator/sys/win32/sys_float.c +++ b/erts/emulator/sys/win32/sys_float.c @@ -139,8 +139,7 @@ sys_double_to_chars_ext(double fp, char *buffer, size_t buffer_size, size_t deci int matherr(struct _exception *exc) { - erl_fp_exception = 1; - DEBUGF(("FP exception (matherr) (0x%x) (%d)\n", exc->type, erl_fp_exception)); + DEBUGF(("FP exception (matherr) (0x%x)\n", exc->type)); return 1; } diff --git a/erts/emulator/test/sensitive_SUITE.erl b/erts/emulator/test/sensitive_SUITE.erl index b7ff4c109c..c3e303bbd1 100644 --- a/erts/emulator/test/sensitive_SUITE.erl +++ b/erts/emulator/test/sensitive_SUITE.erl @@ -311,7 +311,7 @@ gc_trace(Config) when is_list(Config) -> wait_trace(Self), {messages,Messages} = process_info(Tracer, messages), - [{trace,Self,gc_start,_},{trace,Self,gc_end,_}] = Messages, + [{trace,Self,gc_major_start,_},{trace,Self,gc_major_end,_}] = Messages, unlink(Tracer), exit(Tracer, kill), ok. diff --git a/erts/emulator/test/trace_port_SUITE.erl b/erts/emulator/test/trace_port_SUITE.erl index 1068c1d22d..a66563d15b 100644 --- a/erts/emulator/test/trace_port_SUITE.erl +++ b/erts/emulator/test/trace_port_SUITE.erl @@ -236,13 +236,13 @@ gc(Config) when is_list(Config) -> trace_info(Garber, flags), Garber ! hi, - expect({trace,Garber,gc_start,info}), - expect({trace,Garber,gc_end,info}), + expect({trace,Garber,gc_major_start,info}), + expect({trace,Garber,gc_major_end,info}), trac(Garber, true, [garbage_collection,timestamp]), Garber ! hi, - expect({trace_ts,Garber,gc_start,info,ts}), - expect({trace_ts,Garber,gc_end,info,ts}), + expect({trace_ts,Garber,gc_major_start,info,ts}), + expect({trace_ts,Garber,gc_major_end,info,ts}), ok. diff --git a/erts/emulator/test/tracer_SUITE.erl b/erts/emulator/test/tracer_SUITE.erl index 812e834562..de44d6656a 100644 --- a/erts/emulator/test/tracer_SUITE.erl +++ b/erts/emulator/test/tracer_SUITE.erl @@ -468,12 +468,12 @@ gc_start(_Config) -> fun(Pid, State, EOpts) -> receive Msg -> - {Pid, gc_start, State, Pid, _, undefined, Opts} = Msg, + {Pid, gc_major_start, State, Pid, _, undefined, Opts} = Msg, check_opts(EOpts, Opts) end end, - test(gc_start, garbage_collection, Tc, Expect, true). + test(gc_major_start, garbage_collection, Tc, Expect, true). gc_end(_Config) -> @@ -488,12 +488,12 @@ gc_end(_Config) -> fun(Pid, State, EOpts) -> receive Msg -> - {Pid, gc_end, State, Pid, _, undefined, Opts} = Msg, + {Pid, gc_major_end, State, Pid, _, undefined, Opts} = Msg, check_opts(EOpts, Opts) end end, - test(gc_end, garbage_collection, Tc, Expect, true). + test(gc_major_end, garbage_collection, Tc, Expect, true). test(Event, Tc, Expect) -> test(Event, Tc, Expect, true). diff --git a/erts/preloaded/ebin/erl_tracer.beam b/erts/preloaded/ebin/erl_tracer.beam Binary files differindex ffe5d5631c..b8f3f6d8c2 100644 --- a/erts/preloaded/ebin/erl_tracer.beam +++ b/erts/preloaded/ebin/erl_tracer.beam diff --git a/erts/preloaded/src/erl_tracer.erl b/erts/preloaded/src/erl_tracer.erl index 2177e48f60..de1e9ca01e 100644 --- a/erts/preloaded/src/erl_tracer.erl +++ b/erts/preloaded/src/erl_tracer.erl @@ -3,12 +3,29 @@ -export([enabled/3, trace/6, on_load/0]). -type tracee() :: port() | pid() | undefined. --type trace_tag() :: send | send_to_non_existing_process | 'receive' | - call | return_to | return_from | exception_from | - spawn | spawned | exit | link | unlink | getting_linked | - getting_unlinked | register | unregister | in | out | - in_exiting | out_exiting | out_exited | - open | closed | gc_start | gc_end. + +-type trace_tag_running_ports() :: in | out | in_exiting | out_exiting | out_exited. +-type trace_tag_running_procs() :: in | out | in_exiting | out_exiting | out_exited. +-type trace_tag_send() :: send | send_to_non_existing_process. +-type trace_tag_receive() :: 'receive'. +-type trace_tag_call() :: call | return_to | return_from | exception_from. +-type trace_tag_procs() :: spawn | spawned | exit | link | unlink + | getting_linked | getting_unlinked + | register | unregister. +-type trace_tag_ports() :: open | closed | link | unlink + | getting_linked | getting_unlinked. +-type trace_tag_gc() :: gc_minor_start | gc_minor_end + | gc_major_start | gc_major_end. + +-type trace_tag() :: trace_tag_send() + | trace_tag_receive() + | trace_tag_call() + | trace_tag_procs() + | trace_tag_ports() + | trace_tag_running_procs() + | trace_tag_running_ports() + | trace_tag_gc(). + -type trace_opts() :: #{ match_spec_result => true | term(), scheduler_id => undefined | non_neg_integer(), timestamp => undefined | timestamp | cpu_timestamp | diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl new file mode 100644 index 0000000000..e5ee44ace1 --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/compile_flags.hrl @@ -0,0 +1,2 @@ +-define(AT_LEAST_19, 1). +-define(AT_LEAST_17, 1). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl new file mode 100644 index 0000000000..c10626c5cc --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_common.hrl @@ -0,0 +1,55 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Common parts of user and internal header files + + +%%------------------------------------------------------------------------------ +%% Test generation macros +%%------------------------------------------------------------------------------ + +-define(FORALL(X,RawType,Prop), proper:forall(RawType,fun(X) -> Prop end)). +-define(IMPLIES(Pre,Prop), proper:implies(Pre,?DELAY(Prop))). +-define(WHENFAIL(Action,Prop), proper:whenfail(?DELAY(Action),?DELAY(Prop))). +-define(TRAPEXIT(Prop), proper:trapexit(?DELAY(Prop))). +-define(TIMEOUT(Limit,Prop), proper:timeout(Limit,?DELAY(Prop))). +%% TODO: -define(ALWAYS(Tests,Prop), proper:always(Tests,?DELAY(Prop))). +%% TODO: -define(SOMETIMES(Tests,Prop), proper:sometimes(Tests,?DELAY(Prop))). + + +%%------------------------------------------------------------------------------ +%% Generator macros +%%------------------------------------------------------------------------------ + +-define(FORCE(X), (X)()). +-define(DELAY(X), fun() -> X end). +-define(LAZY(X), proper_types:lazy(?DELAY(X))). +-define(SIZED(SizeArg,Gen), proper_types:sized(fun(SizeArg) -> Gen end)). +-define(LET(X,RawType,Gen), proper_types:bind(RawType,fun(X) -> Gen end,false)). +-define(SHRINK(Gen,AltGens), + proper_types:shrinkwith(?DELAY(Gen),?DELAY(AltGens))). +-define(LETSHRINK(Xs,RawType,Gen), + proper_types:bind(RawType,fun(Xs) -> Gen end,true)). +-define(SUCHTHAT(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,true)). +-define(SUCHTHATMAYBE(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,false)). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl new file mode 100644 index 0000000000..b64a139e4d --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_gen.erl @@ -0,0 +1,611 @@ +%%% Copyright 2010-2015 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2015 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Generator subsystem and generators for basic types. +%%% +%%% You can use <a href="#index">these</a> functions to try out the random +%%% instance generation and shrinking subsystems. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_gen). +-export([pick/1, pick/2, pick/3, + sample/1, sample/3, sampleshrink/1, sampleshrink/2]). + +-export([safe_generate/1]). +-export([generate/1, normal_gen/1, alt_gens/1, clean_instance/1, + get_ret_type/1]). +-export([integer_gen/3, float_gen/3, atom_gen/1, atom_rev/1, binary_gen/1, + binary_rev/1, binary_len_gen/1, bitstring_gen/1, bitstring_rev/1, + bitstring_len_gen/1, list_gen/2, distlist_gen/3, vector_gen/2, + union_gen/1, weighted_union_gen/1, tuple_gen/1, loose_tuple_gen/2, + loose_tuple_rev/2, exactly_gen/1, fixed_list_gen/1, function_gen/2, + any_gen/1, native_type_gen/2, safe_weighted_union_gen/1, + safe_union_gen/1]). + +-export_type([instance/0, imm_instance/0, sized_generator/0, nosize_generator/0, + generator/0, reverse_gen/0, combine_fun/0, alt_gens/0]). + +-include("proper_internal.hrl"). + +%%----------------------------------------------------------------------------- +%% Types +%%----------------------------------------------------------------------------- + +%% TODO: update imm_instance() when adding more types: be careful when reading +%% anything that returns it +%% @private_type +-type imm_instance() :: proper_types:raw_type() + | instance() + | {'$used', imm_instance(), imm_instance()} + | {'$to_part', imm_instance()}. +-type instance() :: term(). +%% A value produced by the random instance generator. +-type error_reason() :: 'arity_limit' | 'cant_generate' | {'typeserver',term()}. + +%% @private_type +-type sized_generator() :: fun((size()) -> imm_instance()). +%% @private_type +-type typed_sized_generator() :: {'typed', + fun((proper_types:type(),size()) -> + imm_instance())}. +%% @private_type +-type nosize_generator() :: fun(() -> imm_instance()). +%% @private_type +-type typed_nosize_generator() :: {'typed', + fun((proper_types:type()) -> + imm_instance())}. +%% @private_type +-type generator() :: sized_generator() + | typed_sized_generator() + | nosize_generator() + | typed_nosize_generator(). +%% @private_type +-type plain_reverse_gen() :: fun((instance()) -> imm_instance()). +%% @private_type +-type typed_reverse_gen() :: {'typed', + fun((proper_types:type(),instance()) -> + imm_instance())}. +%% @private_type +-type reverse_gen() :: plain_reverse_gen() | typed_reverse_gen(). +%% @private_type +-type combine_fun() :: fun((instance()) -> imm_instance()). +%% @private_type +-type alt_gens() :: fun(() -> [imm_instance()]). +%% @private_type +-type fun_seed() :: {non_neg_integer(),non_neg_integer()}. + + +%%----------------------------------------------------------------------------- +%% Instance generation functions +%%----------------------------------------------------------------------------- + +%% @private +-spec safe_generate(proper_types:raw_type()) -> + {'ok',imm_instance()} | {'error',error_reason()}. +safe_generate(RawType) -> + try generate(RawType) of + ImmInstance -> {ok, ImmInstance} + catch + throw:'$arity_limit' -> {error, arity_limit}; + throw:'$cant_generate' -> {error, cant_generate}; + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec generate(proper_types:raw_type()) -> imm_instance(). +generate(RawType) -> + Type = proper_types:cook_outer(RawType), + ok = add_parameters(Type), + Instance = generate(Type, get('$constraint_tries'), none), + ok = remove_parameters(Type), + Instance. + +-spec add_parameters(proper_types:type()) -> 'ok'. +add_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + OldParams = erlang:get('$parameters'), + case OldParams of + undefined -> + erlang:put('$parameters', Params); + _ -> + erlang:put('$parameters', Params ++ OldParams) + end, + ok; + _ -> + ok + end. + +-spec remove_parameters(proper_types:type()) -> 'ok'. +remove_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + AllParams = erlang:get('$parameters'), + case AllParams of + Params-> + erlang:erase('$parameters'); + _ -> + erlang:put('$parameters', AllParams -- Params) + end, + ok; + _ -> + ok + end. + +-spec generate(proper_types:type(), non_neg_integer(), + 'none' | {'ok',imm_instance()}) -> imm_instance(). +generate(_Type, 0, none) -> + throw('$cant_generate'); +generate(_Type, 0, {ok,Fallback}) -> + Fallback; +generate(Type, TriesLeft, Fallback) -> + ImmInstance = + case proper_types:get_prop(kind, Type) of + constructed -> + PartsType = proper_types:get_prop(parts_type, Type), + Combine = proper_types:get_prop(combine, Type), + ImmParts = generate(PartsType), + Parts = clean_instance(ImmParts), + ImmInstance1 = Combine(Parts), + %% TODO: We can just generate the internal type: if it's not + %% a type, it will turn into an exactly. + ImmInstance2 = + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end, + {'$used',ImmParts,ImmInstance2}; + _ -> + ImmInstance1 = normal_gen(Type), + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end + end, + case proper_types:satisfies_all(clean_instance(ImmInstance), Type) of + {_,true} -> ImmInstance; + {true,false} -> generate(Type, TriesLeft - 1, {ok,ImmInstance}); + {false,false} -> generate(Type, TriesLeft - 1, Fallback) + end. + +%% @equiv pick(Type, 10) +-spec pick(Type::proper_types:raw_type()) -> {'ok',instance()} | 'error'. +pick(RawType) -> + pick(RawType, 10). + +%% @equiv pick(Type, Size, os:timestamp()) +-spec pick(Type::proper_types:raw_type(), size()) -> {'ok',instance()} | 'error'. +pick(RawType, Size) -> + pick(RawType, Size, os:timestamp()). + +%% @doc Generates a random instance of `Type', of size `Size' with seed `Seed'. +-spec pick(Type::proper_types:raw_type(), size(), seed()) -> + {'ok',instance()} | 'error'. +pick(RawType, Size, Seed) -> + proper:global_state_init_size_seed(Size, Seed), + case clean_instance(safe_generate(RawType)) of + {ok,Instance} = Result -> + Msg = "WARNING: Some garbage has been left in the process registry " + "and the code server~n" + "to allow for the returned function(s) to run normally.~n" + "Please run proper:global_state_erase() when done.~n", + case contains_fun(Instance) of + true -> io:format(Msg, []); + false -> proper:global_state_erase() + end, + Result; + {error,Reason} -> + proper:report_error(Reason, fun io:format/2), + proper:global_state_erase(), + error + end. + +%% @equiv sample(Type, 10, 20) +-spec sample(Type::proper_types:raw_type()) -> 'ok'. +sample(RawType) -> + sample(RawType, 10, 20). + +%% @doc Generates and prints one random instance of `Type' for each size from +%% `StartSize' up to `EndSize'. +-spec sample(Type::proper_types:raw_type(), size(), size()) -> 'ok'. +sample(RawType, StartSize, EndSize) when StartSize =< EndSize -> + Tests = EndSize - StartSize + 1, + Prop = ?FORALL(X, RawType, begin io:format("~p~n",[X]), true end), + Opts = [quiet,{start_size,StartSize},{max_size,EndSize},{numtests,Tests}], + _ = proper:quickcheck(Prop, Opts), + ok. + +%% @equiv sampleshrink(Type, 10) +-spec sampleshrink(Type::proper_types:raw_type()) -> 'ok'. +sampleshrink(RawType) -> + sampleshrink(RawType, 10). + +%% @doc Generates a random instance of `Type', of size `Size', then shrinks it +%% as far as it goes. The value produced on each step of the shrinking process +%% is printed on the screen. +-spec sampleshrink(Type::proper_types:raw_type(), size()) -> 'ok'. +sampleshrink(RawType, Size) -> + proper:global_state_init_size(Size), + Type = proper_types:cook_outer(RawType), + case safe_generate(Type) of + {ok,ImmInstance} -> + Shrunk = keep_shrinking(ImmInstance, [], Type), + PrintInst = fun(I) -> io:format("~p~n",[clean_instance(I)]) end, + lists:foreach(PrintInst, Shrunk); + {error,Reason} -> + proper:report_error(Reason, fun io:format/2) + end, + proper:global_state_erase(), + ok. + +-spec keep_shrinking(imm_instance(), [imm_instance()], proper_types:type()) -> + [imm_instance(),...]. +keep_shrinking(ImmInstance, Acc, Type) -> + keep_shrinking(ImmInstance, Acc, Type, init). + +keep_shrinking(ImmInstance, Acc, Type, State) -> + case proper_shrink:shrink(ImmInstance, Type, State) of + {[], done} -> %% no more shrinkers + lists:reverse([ImmInstance|Acc]); + {[], NewState} -> + %% try next shrinker + keep_shrinking(ImmInstance, Acc, Type, NewState); + {[Shrunk|_Rest], _NewState} -> + Acc2 = [ImmInstance|Acc], + case lists:member(Shrunk, Acc2) of + true -> + %% Avoid infinite loops + lists:reverse(Acc2); + false -> + keep_shrinking(Shrunk, Acc2, Type) + end + end. + +-spec contains_fun(term()) -> boolean(). +contains_fun(List) when is_list(List) -> + proper_arith:safe_any(fun contains_fun/1, List); +contains_fun(Tuple) when is_tuple(Tuple) -> + contains_fun(tuple_to_list(Tuple)); +contains_fun(Fun) when is_function(Fun) -> + true; +contains_fun(_Term) -> + false. + + +%%----------------------------------------------------------------------------- +%% Utility functions +%%----------------------------------------------------------------------------- + +%% @private +-spec normal_gen(proper_types:type()) -> imm_instance(). +normal_gen(Type) -> + case proper_types:get_prop(generator, Type) of + {typed, Gen} -> + if + is_function(Gen, 1) -> Gen(Type); + is_function(Gen, 2) -> Gen(Type, proper:get_size(Type)) + end; + Gen -> + if + is_function(Gen, 0) -> Gen(); + is_function(Gen, 1) -> Gen(proper:get_size(Type)) + end + end. + +%% @private +-spec alt_gens(proper_types:type()) -> [imm_instance()]. +alt_gens(Type) -> + case proper_types:find_prop(alt_gens, Type) of + {ok, AltGens} -> ?FORCE(AltGens); + error -> [] + end. + +%% @private +-spec clean_instance(imm_instance()) -> instance(). +clean_instance({'$used',_ImmParts,ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance({'$to_part',ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance(ImmInstance) -> + if + is_list(ImmInstance) -> + %% CAUTION: this must handle improper lists + proper_arith:safe_map(fun clean_instance/1, ImmInstance); + is_tuple(ImmInstance) -> + proper_arith:tuple_map(fun clean_instance/1, ImmInstance); + true -> + ImmInstance + end. + + +%%----------------------------------------------------------------------------- +%% Basic type generators +%%----------------------------------------------------------------------------- + +%% @private +-spec integer_gen(size(), proper_types:extint(), proper_types:extint()) -> + integer(). +integer_gen(Size, inf, inf) -> + proper_arith:rand_int(Size); +integer_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, High) -> + proper_arith:smart_rand_int(Size, Low, High). + +%% @private +-spec float_gen(size(), proper_types:extnum(), proper_types:extnum()) -> + float(). +float_gen(Size, inf, inf) -> + proper_arith:rand_float(Size); +float_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_float(Size); +float_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_float(Size); +float_gen(_Size, Low, High) -> + proper_arith:rand_float(Low, High). + +%% @private +-spec atom_gen(size()) -> proper_types:type(). +%% We make sure we never clash with internal atoms by checking that the first +%% character is not '$'. +atom_gen(Size) -> + ?LET(Str, + ?SUCHTHAT(X, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + X =:= [] orelse hd(X) =/= $$), + list_to_atom(Str)). + +%% @private +-spec atom_rev(atom()) -> imm_instance(). +atom_rev(Atom) -> + {'$used', atom_to_list(Atom), Atom}. + +%% @private +-spec binary_gen(size()) -> proper_types:type(). +binary_gen(Size) -> + ?LET(Bytes, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + list_to_binary(Bytes)). + +%% @private +-spec binary_rev(binary()) -> imm_instance(). +binary_rev(Binary) -> + {'$used', binary_to_list(Binary), Binary}. + +%% @private +-spec binary_len_gen(length()) -> proper_types:type(). +binary_len_gen(Len) -> + ?LET(Bytes, + proper_types:vector(Len, proper_types:byte()), + list_to_binary(Bytes)). + +%% @private +-spec bitstring_gen(size()) -> proper_types:type(). +bitstring_gen(Size) -> + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:resize(Size,proper_types:binary()), + proper_types:range(0,7), proper_types:range(0,127)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec bitstring_rev(bitstring()) -> imm_instance(). +bitstring_rev(BitString) -> + List = bitstring_to_list(BitString), + {BytesList, BitsTail} = lists:splitwith(fun erlang:is_integer/1, List), + {NumBits, TailByte} = case BitsTail of + [] -> {0, 0}; + [Bits] -> N = bit_size(Bits), + <<Byte:N>> = Bits, + {N, Byte} + end, + {'$used', + {{'$used',BytesList,list_to_binary(BytesList)}, NumBits, TailByte}, + BitString}. + +%% @private +-spec bitstring_len_gen(length()) -> proper_types:type(). +bitstring_len_gen(Len) -> + BytesLen = Len div 8, + BitsLen = Len rem 8, + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:binary(BytesLen), BitsLen, + proper_types:range(0, 1 bsl BitsLen - 1)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec list_gen(size(), proper_types:type()) -> [imm_instance()]. +list_gen(Size, ElemType) -> + Len = proper_arith:rand_int(0, Size), + vector_gen(Len, ElemType). + +%% @private +-spec distlist_gen(size(), sized_generator(), boolean()) -> [imm_instance()]. +distlist_gen(RawSize, Gen, NonEmpty) -> + Len = case NonEmpty of + true -> proper_arith:rand_int(1, erlang:max(1,RawSize)); + false -> proper_arith:rand_int(0, RawSize) + end, + Size = case Len of + 1 -> RawSize - 1; + _ -> RawSize + end, + %% TODO: this produces a lot of types: maybe a simple 'div' is sufficient? + Sizes = proper_arith:distribute(Size, Len), + InnerTypes = [Gen(S) || S <- Sizes], + fixed_list_gen(InnerTypes). + +%% @private +-spec vector_gen(length(), proper_types:type()) -> [imm_instance()]. +vector_gen(Len, ElemType) -> + vector_gen_tr(Len, ElemType, []). + +-spec vector_gen_tr(length(), proper_types:type(), [imm_instance()]) -> + [imm_instance()]. +vector_gen_tr(0, _ElemType, AccList) -> + AccList; +vector_gen_tr(Left, ElemType, AccList) -> + vector_gen_tr(Left - 1, ElemType, [generate(ElemType) | AccList]). + +%% @private +-spec union_gen([proper_types:type(),...]) -> imm_instance(). +union_gen(Choices) -> + {_Choice,Type} = proper_arith:rand_choose(Choices), + generate(Type). + +%% @private +-spec weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +weighted_union_gen(FreqChoices) -> + {_Choice,Type} = proper_arith:freq_choose(FreqChoices), + generate(Type). + +%% @private +-spec safe_union_gen([proper_types:type(),...]) -> imm_instance(). +safe_union_gen(Choices) -> + {Choice,Type} = proper_arith:rand_choose(Choices), + try generate(Type) + catch + error:_ -> + safe_union_gen(proper_arith:list_remove(Choice, Choices)) + end. + +%% @private +-spec safe_weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +safe_weighted_union_gen(FreqChoices) -> + {Choice,Type} = proper_arith:freq_choose(FreqChoices), + try generate(Type) + catch + error:_ -> + safe_weighted_union_gen(proper_arith:list_remove(Choice, + FreqChoices)) + end. + +%% @private +-spec tuple_gen([proper_types:type()]) -> tuple(). +tuple_gen(Fields) -> + list_to_tuple(fixed_list_gen(Fields)). + +%% @private +-spec loose_tuple_gen(size(), proper_types:type()) -> proper_types:type(). +loose_tuple_gen(Size, ElemType) -> + ?LET(L, + proper_types:resize(Size, proper_types:list(ElemType)), + list_to_tuple(L)). + +%% @private +-spec loose_tuple_rev(tuple(), proper_types:type()) -> imm_instance(). +loose_tuple_rev(Tuple, ElemType) -> + CleanList = tuple_to_list(Tuple), + List = case proper_types:find_prop(reverse_gen, ElemType) of + {ok,{typed, ReverseGen}} -> + [ReverseGen(ElemType,X) || X <- CleanList]; + {ok,ReverseGen} -> [ReverseGen(X) || X <- CleanList]; + error -> CleanList + end, + {'$used', List, Tuple}. + +%% @private +-spec exactly_gen(T) -> T. +exactly_gen(X) -> + X. + +%% @private +-spec fixed_list_gen([proper_types:type()]) -> imm_instance() + ; ({[proper_types:type()],proper_types:type()}) -> + maybe_improper_list(imm_instance(), imm_instance() | []). +fixed_list_gen({ProperHead,ImproperTail}) -> + [generate(F) || F <- ProperHead] ++ generate(ImproperTail); +fixed_list_gen(ProperFields) -> + [generate(F) || F <- ProperFields]. + +%% @private +-spec function_gen(arity(), proper_types:type()) -> function(). +function_gen(Arity, RetType) -> + FunSeed = {proper_arith:rand_int(0, ?SEED_RANGE - 1), + proper_arith:rand_int(0, ?SEED_RANGE - 1)}, + create_fun(Arity, RetType, FunSeed). + +%% @private +-spec any_gen(size()) -> imm_instance(). +any_gen(Size) -> + case get('$any_type') of + undefined -> real_any_gen(Size); + {type,AnyType} -> generate(proper_types:resize(Size, AnyType)) + end. + +-spec real_any_gen(size()) -> imm_instance(). +real_any_gen(0) -> + SimpleTypes = [proper_types:integer(), proper_types:float(), + proper_types:atom()], + union_gen(SimpleTypes); +real_any_gen(Size) -> + FreqChoices = [{?ANY_SIMPLE_PROB,simple}, {?ANY_BINARY_PROB,binary}, + {?ANY_EXPAND_PROB,expand}], + case proper_arith:freq_choose(FreqChoices) of + {_,simple} -> + real_any_gen(0); + {_,binary} -> + generate(proper_types:resize(Size, proper_types:bitstring())); + {_,expand} -> + %% TODO: statistics of produced terms? + NumElems = proper_arith:rand_int(0, Size - 1), + ElemSizes = proper_arith:distribute(Size - 1, NumElems), + ElemTypes = [?LAZY(real_any_gen(S)) || S <- ElemSizes], + case proper_arith:rand_int(1,2) of + 1 -> fixed_list_gen(ElemTypes); + 2 -> tuple_gen(ElemTypes) + end + end. + +%% @private +-spec native_type_gen(mod_name(), string()) -> proper_types:type(). +native_type_gen(Mod, TypeStr) -> + case proper_typeserver:translate_type({Mod,TypeStr}) of + {ok,Type} -> Type; + {error,Reason} -> throw({'$typeserver',Reason}) + end. + + +%%------------------------------------------------------------------------------ +%% Function-generation functions +%%------------------------------------------------------------------------------ + +-spec create_fun(arity(), proper_types:type(), fun_seed()) -> function(). +create_fun(_Arity, _RetType, _FunSeed) -> + fun() -> throw('$arity_limit') end. + +%% @private +-spec get_ret_type(function()) -> proper_types:type(). +get_ret_type(Fun) -> + {arity,Arity} = erlang:fun_info(Fun, arity), + put('$get_ret_type', true), + RetType = apply(Fun, lists:duplicate(Arity,dummy)), + erase('$get_ret_type'), + RetType. diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl new file mode 100644 index 0000000000..89e6b34296 --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_internal.hrl @@ -0,0 +1,98 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2016 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Internal header file: This header is included in all PropEr source +%%% files. + +-include("compile_flags.hrl"). +-include("proper_common.hrl"). + + +%%------------------------------------------------------------------------------ +%% Activate strip_types parse transform +%%------------------------------------------------------------------------------ + +-ifdef(NO_TYPES). +-compile({parse_transform, strip_types}). +-endif. + +%%------------------------------------------------------------------------------ +%% Random generator selection +%%------------------------------------------------------------------------------ + +-ifdef(USE_SFMT). +-define(RANDOM_MOD, sfmt). +-define(SEED_NAME, sfmt_seed). +-else. +-define(RANDOM_MOD, random). +-define(SEED_NAME, random_seed). +-endif. + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(PROPERTY_PREFIX, "prop_"). + + +%%------------------------------------------------------------------------------ +%% Constants +%%------------------------------------------------------------------------------ + +-define(SEED_RANGE, 4294967296). +-define(MAX_ARITY, 20). +-define(MAX_TRIES_FACTOR, 5). +-define(ANY_SIMPLE_PROB, 3). +-define(ANY_BINARY_PROB, 1). +-define(ANY_EXPAND_PROB, 8). +-define(SMALL_RANGE_THRESHOLD, 16#FFFF). + + +%%------------------------------------------------------------------------------ +%% Common type aliases +%%------------------------------------------------------------------------------ + +%% TODO: Perhaps these should be moved inside modules. +-type mod_name() :: atom(). +-type fun_name() :: atom(). +-type size() :: non_neg_integer(). +-type length() :: non_neg_integer(). +-type position() :: pos_integer(). +-type frequency() :: pos_integer(). +-type seed() :: {non_neg_integer(), non_neg_integer(), non_neg_integer()}. + +-type abs_form() :: erl_parse:abstract_form(). +-type abs_expr() :: erl_parse:abstract_expr(). +-type abs_clause() :: erl_parse:abstract_clause(). + +%% TODO: Replace these with the appropriate types from stdlib. +-ifdef(AT_LEAST_19). +-type abs_type() :: erl_parse:abstract_type(). +-type abs_rec_field() :: term(). % erl_parse:af_field_decl(). +-else. +-type abs_type() :: term(). +-type abs_rec_field() :: term(). +-endif. + +-type loose_tuple(T) :: {} | {T} | {T,T} | {T,T,T} | {T,T,T,T} | {T,T,T,T,T} + | {T,T,T,T,T,T} | {T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T} + | {T,T,T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T,T,T} | tuple(). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl new file mode 100644 index 0000000000..6b154b813b --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_types.erl @@ -0,0 +1,1353 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Type manipulation functions and predefined types. +%%% +%%% == Basic types == +%%% This module defines all the basic types of the PropEr type system as +%%% functions. See the <a href="#index">function index</a> for an overview. +%%% +%%% Types can be combined in tuples or lists to produce other types. Exact +%%% values (such as exact numbers, atoms, binaries and strings) can be combined +%%% with types inside such structures, like in this example of the type of a +%%% tagged tuple: ``{'result', integer()}''. +%%% +%%% When including the PropEr header file, all +%%% <a href="#index">API functions</a> of this module are automatically +%%% imported, unless `PROPER_NO_IMPORTS' is defined. +%%% +%%% == Customized types == +%%% The following operators can be applied to basic types in order to produce +%%% new ones: +%%% +%%% <dl> +%%% <dt>`?LET(<Xs>, <Xs_type>, <In>)'</dt> +%%% <dd>To produce an instance of this type, all appearances of the variables +%%% in `<Xs>' are replaced inside `<In>' by their corresponding values in a +%%% randomly generated instance of `<Xs_type>'. It's OK for the `<In>' part to +%%% evaluate to a type - in that case, an instance of the inner type is +%%% generated recursively.</dd> +%%% <dt>`?SUCHTHAT(<X>, <Type>, <Condition>)'</dt> +%%% <dd>This produces a specialization of `<Type>', which only includes those +%%% members of `<Type>' that satisfy the constraint `<Condition>' - that is, +%%% those members for which the function `fun(<X>) -> <Condition> end' returns +%%% `true'. If the constraint is very strict - that is, only a small +%%% percentage of instances of `<Type>' pass the test - it will take a lot of +%%% tries for the instance generation subsystem to randomly produce a valid +%%% instance. This will result in slower testing, and testing may even be +%%% stopped short, in case the `constraint_tries' limit is reached (see the +%%% "Options" section in the documentation of the {@link proper} module). If +%%% this is the case, it would be more appropriate to generate valid instances +%%% of the specialized type using the `?LET' macro. Also make sure that even +%%% small instances can satisfy the constraint, since PropEr will only try +%%% small instances at the start of testing. If this is not possible, you can +%%% instruct PropEr to start at a larger size, by supplying a suitable value +%%% for the `start_size' option (see the "Options" section in the +%%% documentation of the {@link proper} module).</dd> +%%% <dt>`?SUCHTHATMAYBE(<X>, <Type>, <Condition>)'</dt> +%%% <dd>Equivalent to the `?SUCHTHAT' macro, but the constraint `<Condition>' +%%% is considered non-strict: if the `constraint_tries' limit is reached, the +%%% generator will just return an instance of `<Type>' instead of failing, +%%% even if that instance doesn't satisfy the constraint.</dd> +%%% <dt>`?SHRINK(<Generator>, <List_of_alt_gens>)'</dt> +%%% <dd>This creates a type whose instances are generated by evaluating the +%%% statement block `<Generator>' (this may evaluate to a type, which will +%%% then be generated recursively). If an instance of such a type is to be +%%% shrunk, the generators in `<List_of_alt_gens>' are first run to produce +%%% hopefully simpler instances of the type. Thus, the generators in the +%%% second argument should be simpler than the default. The simplest ones +%%% should be at the front of the list, since those are the generators +%%% preferred by the shrinking subsystem. Like the main `<Generator>', the +%%% alternatives may also evaluate to a type, which is generated recursively. +%%% </dd> +%%% <dt>`?LETSHRINK(<List_of_variables>, <List_of_types>, <Generator>)'</dt> +%%% <dd>This is created by combining a `?LET' and a `?SHRINK' macro. Instances +%%% are generated by applying a randomly generated list of values inside +%%% `<Generator>' (just like a `?LET', with the added constraint that the +%%% variables and types must be provided in a list - alternatively, +%%% `<List_of_types>' may be a list or vector type). When shrinking instances +%%% of such a type, the sub-instances that were combined to produce it are +%%% first tried in place of the failing instance.</dd> +%%% <dt>`?LAZY(<Generator>)'</dt> +%%% <dd>This construct returns a type whose only purpose is to delay the +%%% evaluation of `<Generator>' (`<Generator>' can return a type, which will +%%% be generated recursively). Using this, you can simulate the lazy +%%% generation of instances: +%%% ``` stream() -> ?LAZY(frequency([ {1,[]}, {3,[0|stream()]} ])). ''' +%%% The above type produces lists of zeroes with an average length of 3. Note +%%% that, had we not enclosed the generator with a `?LAZY' macro, the +%%% evaluation would continue indefinitely, due to the eager evaluation of +%%% the Erlang language.</dd> +%%% <dt>`non_empty(<List_or_binary_type>)'</dt> +%%% <dd>See the documentation for {@link non_empty/1}.</dd> +%%% <dt>`noshrink(<Type>)'</dt> +%%% <dd>See the documentation for {@link noshrink/1}.</dd> +%%% <dt>`default(<Default_value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link default/2}.</dd> +%%% <dt>`with_parameter(<Parameter>, <Value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameter/3}.</dd> +%%% <dt>`with_parameters(<Param_value_pairs>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameters/2}.</dd> +%%% </dl> +%%% +%%% == Size manipulation == +%%% The following operators are related to the `size' parameter, which controls +%%% the maximum size of produced instances. The actual size of a produced +%%% instance is chosen randomly, but can never exceed the value of the `size' +%%% parameter at the moment of generation. A more accurate definition is the +%%% following: the maximum instance of `size S' can never be smaller than the +%%% maximum instance of `size S-1'. The actual size of an instance is measured +%%% differently for each type: the actual size of a list is its length, while +%%% the actual size of a tree may be the number of its internal nodes. Some +%%% types, e.g. unions, have no notion of size, thus their generation is not +%%% influenced by the value of `size'. The `size' parameter starts at 1 and +%%% grows automatically during testing. +%%% +%%% <dl> +%%% <dt>`?SIZED(<S>, <Generator>)'</dt> +%%% <dd>Creates a new type, whose instances are produced by replacing all +%%% appearances of the `<S>' parameter inside the statement block +%%% `<Generator>' with the value of the `size' parameter. It's OK for the +%%% `<Generator>' to return a type - in that case, an instance of the inner +%%% type is generated recursively.</dd> +%%% <dt>`resize(<New_size>, <Type>)'</dt> +%%% <dd>See the documentation for {@link resize/2}.</dd> +%%% </dl> + +-module(proper_types). +-export([is_inst/2, is_inst/3]). + +-export([integer/2, float/2, atom/0, binary/0, binary/1, bitstring/0, + bitstring/1, list/1, vector/2, union/1, weighted_union/1, tuple/1, + loose_tuple/1, exactly/1, fixed_list/1, function/2, any/0, + shrink_list/1, safe_union/1, safe_weighted_union/1]). +-export([integer/0, non_neg_integer/0, pos_integer/0, neg_integer/0, range/2, + float/0, non_neg_float/0, number/0, boolean/0, byte/0, char/0, + list/0, tuple/0, string/0, wunion/1, term/0, timeout/0, arity/0]). +-export([int/0, nat/0, largeint/0, real/0, bool/0, choose/2, elements/1, + oneof/1, frequency/1, return/1, default/2, orderedlist/1, function0/1, + function1/1, function2/1, function3/1, function4/1, + weighted_default/2]). +-export([resize/2, non_empty/1, noshrink/1]). + +-export([cook_outer/1, is_type/1, equal_types/2, is_raw_type/1, to_binary/1, + from_binary/1, get_prop/2, find_prop/2, safe_is_instance/2, + is_instance/2, unwrap/1, weakly/1, strongly/1, satisfies_all/2, + new_type/2, subtype/2]). +-export([lazy/1, sized/1, bind/3, shrinkwith/2, add_constraint/3, + native_type/2, distlist/3, with_parameter/3, with_parameters/2, + parameter/1, parameter/2]). +-export([le/2]). + +-export_type([type/0, raw_type/0, extint/0, extnum/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Comparison with erl_types +%%------------------------------------------------------------------------------ + +%% Missing types +%% ------------------- +%% will do: +%% records, maybe_improper_list(T,S), nonempty_improper_list(T,S) +%% maybe_improper_list(), maybe_improper_list(T), iolist, iodata +%% don't need: +%% nonempty_{list,string,maybe_improper_list} +%% won't do: +%% pid, port, ref, identifier, none, no_return, module, mfa, node +%% array, dict, digraph, set, gb_tree, gb_set, queue, tid + +%% Missing type information +%% ------------------------ +%% bin types: +%% other unit sizes? what about size info? +%% functions: +%% generally some fun, unspecified number of arguments but specified +%% return type +%% any: +%% doesn't cover functions and improper lists + + +%%------------------------------------------------------------------------------ +%% Type declaration macros +%%------------------------------------------------------------------------------ + +-define(BASIC(PropList), new_type(PropList,basic)). +-define(WRAPPER(PropList), new_type(PropList,wrapper)). +-define(CONSTRUCTED(PropList), new_type(PropList,constructed)). +-define(CONTAINER(PropList), new_type(PropList,container)). +-define(SUBTYPE(Type,PropList), subtype(PropList,Type)). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_kind() :: 'basic' | 'wrapper' | 'constructed' | 'container' | atom(). +-type instance_test() :: fun((proper_gen:imm_instance()) -> boolean()) + | {'typed', + fun((proper_types:type(), + proper_gen:imm_instance()) -> boolean())}. +-type index() :: pos_integer(). +%% @alias +-type value() :: term(). +%% @private_type +%% @alias +-type extint() :: integer() | 'inf'. +%% @private_type +%% @alias +-type extnum() :: number() | 'inf'. +-type constraint_fun() :: fun((proper_gen:instance()) -> boolean()). + +-opaque type() :: {'$type', [type_prop()]}. +%% A type of the PropEr type system +%% @type raw_type(). You can consider this as an equivalent of {@type type()}. +-type raw_type() :: type() | [raw_type()] | loose_tuple(raw_type()) | term(). +-type type_prop_name() :: 'kind' | 'generator' | 'reverse_gen' | 'parts_type' + | 'combine' | 'alt_gens' | 'shrink_to_parts' + | 'size_transform' | 'is_instance' | 'shrinkers' + | 'noshrink' | 'internal_type' | 'internal_types' + | 'get_length' | 'split' | 'join' | 'get_indices' + | 'remove' | 'retrieve' | 'update' | 'constraints' + | 'parameters' | 'env' | 'subenv'. + +-type type_prop_value() :: term(). +-type type_prop() :: + {'kind', type_kind()} + | {'generator', proper_gen:generator()} + | {'reverse_gen', proper_gen:reverse_gen()} + | {'parts_type', type()} + | {'combine', proper_gen:combine_fun()} + | {'alt_gens', proper_gen:alt_gens()} + | {'shrink_to_parts', boolean()} + | {'size_transform', fun((size()) -> size())} + | {'is_instance', instance_test()} + | {'shrinkers', [proper_shrink:shrinker()]} + | {'noshrink', boolean()} + | {'internal_type', raw_type()} + | {'internal_types', tuple() | maybe_improper_list(type(),type() | [])} + %% The items returned by 'remove' must be of this type. + | {'get_length', fun((proper_gen:imm_instance()) -> length())} + %% If this is a container type, this should return the number of elements + %% it contains. + | {'split', fun((proper_gen:imm_instance()) -> [proper_gen:imm_instance()]) + | fun((length(),proper_gen:imm_instance()) -> + {proper_gen:imm_instance(),proper_gen:imm_instance()})} + %% If present, the appropriate form depends on whether get_length is + %% defined: if get_length is undefined, this must be in the one-argument + %% form (e.g. a tree should be split into its subtrees), else it must be + %% in the two-argument form (e.g. a list should be split in two at the + %% index provided). + | {'join', fun((proper_gen:imm_instance(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'get_indices', fun((proper_types:type(), + proper_gen:imm_instance()) -> [index()])} + %% If this is a container type, this should return a list of indices we + %% can use to remove or insert elements from the given instance. + | {'remove', fun((index(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'retrieve', fun((index(), proper_gen:imm_instance() | tuple() + | maybe_improper_list(type(),type() | [])) -> + value() | type())} + | {'update', fun((index(),value(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'constraints', [{constraint_fun(), boolean()}]} + %% A list of constraints on instances of this type: each constraint is a + %% tuple of a fun that must return 'true' for each valid instance and a + %% boolean field that specifies whether the condition is strict. + | {'parameters', [{atom(),value()}]} + | {'env', term()} + | {'subenv', term()}. + + +%%------------------------------------------------------------------------------ +%% Type manipulation functions +%%------------------------------------------------------------------------------ + +%% TODO: We shouldn't need the fully qualified type name in the range of these +%% functions. + +%% @private +%% TODO: just cook/1 ? +-spec cook_outer(raw_type()) -> proper_types:type(). +cook_outer(Type = {'$type',_Props}) -> + Type; +cook_outer(RawType) -> + if + is_tuple(RawType) -> tuple(tuple_to_list(RawType)); + %% CAUTION: this must handle improper lists + is_list(RawType) -> fixed_list(RawType); + %% default case (covers integers, floats, atoms, binaries, ...): + true -> exactly(RawType) + end. + +%% @private +-spec is_type(term()) -> boolean(). +is_type({'$type',_Props}) -> + true; +is_type(_) -> + false. + +%% @private +-spec equal_types(proper_types:type(), proper_types:type()) -> boolean(). +equal_types(SameType, SameType) -> + true; +equal_types(_, _) -> + false. + +%% @private +-spec is_raw_type(term()) -> boolean(). +is_raw_type({'$type',_TypeProps}) -> + true; +is_raw_type(X) -> + if + is_tuple(X) -> is_raw_type_list(tuple_to_list(X)); + is_list(X) -> is_raw_type_list(X); + true -> false + end. + +-spec is_raw_type_list(maybe_improper_list()) -> boolean(). +%% CAUTION: this must handle improper lists +is_raw_type_list(List) -> + proper_arith:safe_any(fun is_raw_type/1, List). + +%% @private +-spec to_binary(proper_types:type()) -> binary(). +to_binary(Type) -> + term_to_binary(Type). + +%% @private +-ifdef(AT_LEAST_17). +-spec from_binary(binary()) -> proper_types:type(). +-endif. +from_binary(Binary) -> + binary_to_term(Binary). + +-spec type_from_list([type_prop()]) -> proper_types:type(). +type_from_list(KeyValueList) -> + {'$type',KeyValueList}. + +-spec add_prop(type_prop_name(), type_prop_value(), proper_types:type()) -> + proper_types:type(). +add_prop(PropName, Value, {'$type',Props}) -> + {'$type',lists:keystore(PropName, 1, Props, {PropName, Value})}. + +-spec add_props([type_prop()], proper_types:type()) -> proper_types:type(). +add_props(PropList, {'$type',OldProps}) -> + {'$type', lists:foldl(fun({N,_}=NV,Acc) -> + lists:keystore(N, 1, Acc, NV) + end, OldProps, PropList)}. + +-spec append_to_prop(type_prop_name(), type_prop_value(), + proper_types:type()) -> proper_types:type(). +append_to_prop(PropName, Value, {'$type',Props}) -> + Val = case lists:keyfind(PropName, 1, Props) of + {PropName, V} -> + V; + _ -> + [] + end, + {'$type', lists:keystore(PropName, 1, Props, + {PropName, lists:reverse([Value|Val])})}. + +-spec append_list_to_prop(type_prop_name(), [type_prop_value()], + proper_types:type()) -> proper_types:type(). +append_list_to_prop(PropName, List, {'$type',Props}) -> + {PropName, Val} = lists:keyfind(PropName, 1, Props), + {'$type', lists:keystore(PropName, 1, Props, {PropName, Val++List})}. + +%% @private +-spec get_prop(type_prop_name(), proper_types:type()) -> type_prop_value(). +get_prop(PropName, {'$type',Props}) -> + {_PropName, Val} = lists:keyfind(PropName, 1, Props), + Val. + +%% @private +-spec find_prop(type_prop_name(), proper_types:type()) -> + {'ok',type_prop_value()} | 'error'. +find_prop(PropName, {'$type',Props}) -> + case lists:keyfind(PropName, 1, Props) of + {PropName, Value} -> + {ok, Value}; + _ -> + error + end. + +%% @private +-spec new_type([type_prop()], type_kind()) -> proper_types:type(). +new_type(PropList, Kind) -> + Type = type_from_list(PropList), + add_prop(kind, Kind, Type). + +%% @private +-spec subtype([type_prop()], proper_types:type()) -> proper_types:type(). +%% TODO: should the 'is_instance' function etc. be reset for subtypes? +subtype(PropList, Type) -> + add_props(PropList, Type). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType) -> + is_inst(Instance, RawType, 10). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type(), size()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType, Size) -> + proper:global_state_init_size(Size), + Result = safe_is_instance(Instance, RawType), + proper:global_state_erase(), + Result. + +%% @private +-spec safe_is_instance(proper_gen:imm_instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +safe_is_instance(ImmInstance, RawType) -> + try is_instance(ImmInstance, RawType) catch + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec is_instance(proper_gen:imm_instance(), raw_type()) -> boolean(). +%% TODO: If the second argument is not a type, let it pass (don't even check for +%% term equality?) - if it's a raw type, don't cook it, instead recurse +%% into it. +is_instance(ImmInstance, RawType) -> + CleanInstance = proper_gen:clean_instance(ImmInstance), + Type = cook_outer(RawType), + (case get_prop(kind, Type) of + wrapper -> wrapper_test(ImmInstance, Type); + constructed -> constructed_test(ImmInstance, Type); + _ -> false + end + orelse + case find_prop(is_instance, Type) of + {ok,{typed, IsInstance}} -> IsInstance(Type, ImmInstance); + {ok,IsInstance} -> IsInstance(ImmInstance); + error -> false + end) + andalso weakly(satisfies_all(CleanInstance, Type)). + +-spec wrapper_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +wrapper_test(ImmInstance, Type) -> + %% TODO: check if it's actually a raw type that's returned? + lists:any(fun(T) -> is_instance(ImmInstance, T) end, unwrap(Type)). + +%% @private +-ifdef(AT_LEAST_17). +-spec unwrap(proper_types:type()) -> [proper_types:type(),...]. +-endif. +%% TODO: check if it's actually a raw type that's returned? +unwrap(Type) -> + RawInnerTypes = proper_gen:alt_gens(Type) ++ [proper_gen:normal_gen(Type)], + [cook_outer(T) || T <- RawInnerTypes]. + +-spec constructed_test(proper_gen:imm_instance(), proper_types:type()) -> + boolean(). +constructed_test({'$used',ImmParts,ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + Combine = get_prop(combine, Type), + is_instance(ImmParts, PartsType) andalso + begin + %% TODO: check if it's actually a raw type that's returned? + %% TODO: move construction code to proper_gen + %% TODO: non-type => should we check for strict term equality? + RawInnerType = Combine(proper_gen:clean_instance(ImmParts)), + is_instance(ImmInstance, RawInnerType) + end; +constructed_test({'$to_part',ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + get_prop(shrink_to_parts, Type) =:= true andalso + %% TODO: we reject non-container types + get_prop(kind, PartsType) =:= container andalso + case {find_prop(internal_type,PartsType), + find_prop(internal_types,PartsType)} of + {{ok,EachPartType},error} -> + %% The parts are in a list or a vector. + is_instance(ImmInstance, EachPartType); + {error,{ok,PartTypesList}} -> + %% The parts are in a fixed list. + %% TODO: It should always be a proper list. + lists:any(fun(T) -> is_instance(ImmInstance,T) end, PartTypesList) + end; +constructed_test(_CleanInstance, _Type) -> + %% TODO: can we do anything better? + false. + +%% @private +-spec weakly({boolean(),boolean()}) -> boolean(). +weakly({B1,_B2}) -> B1. + +%% @private +-spec strongly({boolean(),boolean()}) -> boolean(). +strongly({_B1,B2}) -> B2. + +-spec satisfies(proper_gen:instance(), {constraint_fun(),boolean()}) + -> {boolean(),boolean()}. +satisfies(Instance, {Test,false}) -> + {true,Test(Instance)}; +satisfies(Instance, {Test,true}) -> + Result = Test(Instance), + {Result,Result}. + +%% @private +-spec satisfies_all(proper_gen:instance(), proper_types:type()) -> + {boolean(),boolean()}. +satisfies_all(Instance, Type) -> + case find_prop(constraints, Type) of + {ok, Constraints} -> + L = [satisfies(Instance, C) || C <- Constraints], + {L1,L2} = lists:unzip(L), + {lists:all(fun(B) -> B end, L1), lists:all(fun(B) -> B end, L2)}; + error -> + {true,true} + end. + + +%%------------------------------------------------------------------------------ +%% Type definition functions +%%------------------------------------------------------------------------------ + +%% @private +-spec lazy(proper_gen:nosize_generator()) -> proper_types:type(). +lazy(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec sized(proper_gen:sized_generator()) -> proper_types:type(). +sized(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec bind(raw_type(), proper_gen:combine_fun(), boolean()) -> + proper_types:type(). +bind(RawPartsType, Combine, ShrinkToParts) -> + PartsType = cook_outer(RawPartsType), + ?CONSTRUCTED([ + {parts_type, PartsType}, + {combine, Combine}, + {shrink_to_parts, ShrinkToParts} + ]). + +%% @private +-spec shrinkwith(proper_gen:nosize_generator(), proper_gen:alt_gens()) -> + proper_types:type(). +shrinkwith(Gen, DelaydAltGens) -> + ?WRAPPER([ + {generator, Gen}, + {alt_gens, DelaydAltGens} + ]). + +%% @private +-spec add_constraint(raw_type(), constraint_fun(), boolean()) -> + proper_types:type(). +add_constraint(RawType, Condition, IsStrict) -> + Type = cook_outer(RawType), + append_to_prop(constraints, {Condition,IsStrict}, Type). + +%% @private +-spec native_type(mod_name(), string()) -> proper_types:type(). +native_type(Mod, TypeStr) -> + ?WRAPPER([ + {generator, fun() -> proper_gen:native_type_gen(Mod,TypeStr) end} + ]). + + +%%------------------------------------------------------------------------------ +%% Basic types +%%------------------------------------------------------------------------------ + +%% @doc All integers between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to integers, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0 if `Low =< 0 =< High', or towards the bound with +%% the smallest absolute value otherwise. +-spec integer(extint(), extint()) -> proper_types:type(). +integer(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun integer_gen/2}}, + {is_instance, {typed, fun integer_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +integer_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:integer_gen(Size, Low, High). + +integer_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_integer(X) andalso le(Low, X) andalso le(X, High). + +number_shrinker(X, Type, S) -> + {Low, High} = get_prop(env, Type), + proper_shrink:number_shrinker(X, Low, High, S). + +%% @doc All floats between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to floats, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0.0 if `Low =< 0.0 =< High', or towards the bound +%% with the smallest absolute value otherwise. +-spec float(extnum(), extnum()) -> proper_types:type(). +float(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun float_gen/2}}, + {is_instance, {typed, fun float_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +float_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:float_gen(Size, Low, High). + +float_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_float(X) andalso le(Low, X) andalso le(X, High). + +%% @private +-spec le(extnum(), extnum()) -> boolean(). +le(inf, _B) -> true; +le(_A, inf) -> true; +le(A, B) -> A =< B. + +%% @doc All atoms. All atoms used internally by PropEr start with a '`$'', so +%% such atoms will never be produced as instances of this type. You should also +%% refrain from using such atoms in your code, to avoid a potential clash. +%% Instances shrink towards the empty atom, ''. +-spec atom() -> proper_types:type(). +atom() -> + ?WRAPPER([ + {generator, fun proper_gen:atom_gen/1}, + {reverse_gen, fun proper_gen:atom_rev/1}, + {size_transform, fun(Size) -> erlang:min(Size,255) end}, + {is_instance, fun atom_is_instance/1} + ]). + +atom_is_instance(X) -> + is_atom(X) + %% We return false for atoms starting with '$', since these are + %% atoms used internally and never produced by the atom generator. + andalso (X =:= '' orelse hd(atom_to_list(X)) =/= $$). + +%% @doc All binaries. Instances shrink towards the empty binary, `<<>>'. +-spec binary() -> proper_types:type(). +binary() -> + ?WRAPPER([ + {generator, fun proper_gen:binary_gen/1}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, fun erlang:is_binary/1} + ]). + +%% @doc All binaries with a byte size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards binaries of zeroes. +-spec binary(length()) -> proper_types:type(). +binary(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun binary_len_gen/1}}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, {typed, fun binary_len_is_instance/2}} + ]). + +binary_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:binary_len_gen(Len). + +binary_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_binary(X) andalso byte_size(X) =:= Len. + +%% @doc All bitstrings. Instances shrink towards the empty bitstring, `<<>>'. +-spec bitstring() -> proper_types:type(). +bitstring() -> + ?WRAPPER([ + {generator, fun proper_gen:bitstring_gen/1}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, fun erlang:is_bitstring/1} + ]). + +%% @doc All bitstrings with a bit size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards bitstrings of zeroes +-spec bitstring(length()) -> proper_types:type(). +bitstring(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun bitstring_len_gen/1}}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, {typed, fun bitstring_len_is_instance/2}} + ]). + +bitstring_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:bitstring_len_gen(Len). + +bitstring_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_bitstring(X) andalso bit_size(X) =:= Len. + +%% @doc All lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec list(ElemType::raw_type()) -> proper_types:type(). +% TODO: subtyping would be useful here (list, vector, fixed_list) +list(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {generator, {typed, fun list_gen/2}}, + {is_instance, {typed, fun list_is_instance/2}}, + {internal_type, ElemType}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +list_gen(Type, Size) -> + ElemType = get_prop(internal_type, Type), + proper_gen:list_gen(Size, ElemType). + +list_is_instance(Type, X) -> + ElemType = get_prop(internal_type, Type), + list_test(X, ElemType). + +%% @doc A type that generates exactly the list `List'. Instances shrink towards +%% shorter sublists of the original list. +-spec shrink_list([term()]) -> proper_types:type(). +shrink_list(List) -> + ?CONTAINER([ + {env, List}, + {generator, {typed, fun shrink_list_gen/1}}, + {is_instance, {typed, fun shrink_list_is_instance/2}}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2} + ]). + +shrink_list_gen(Type) -> + get_prop(env, Type). + +shrink_list_is_instance(Type, X) -> + List = get_prop(env, Type), + is_sublist(X, List). + +-spec is_sublist([term()], [term()]) -> boolean(). +is_sublist([], _) -> true; +is_sublist(_, []) -> false; +is_sublist([H|T1], [H|T2]) -> is_sublist(T1, T2); +is_sublist(Slice, [_|T2]) -> is_sublist(Slice, T2). + +-spec list_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +list_test(X, ElemType) -> + is_list(X) andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +%% @private +-spec list_get_indices(proper_gen:generator(), list()) -> [position()]. +list_get_indices(_, List) -> + lists:seq(1, length(List)). + +%% @private +%% This assumes that: +%% - instances of size S are always valid instances of size >S +%% - any recursive calls inside Gen are lazy +-spec distlist(size(), proper_gen:sized_generator(), boolean()) -> + proper_types:type(). +distlist(Size, Gen, NonEmpty) -> + ParentType = case NonEmpty of + true -> non_empty(list(Gen(Size))); + false -> list(Gen(Size)) + end, + ?SUBTYPE(ParentType, [ + {subenv, {Size, Gen, NonEmpty}}, + {generator, {typed, fun distlist_gen/1}} + ]). + +distlist_gen(Type) -> + {Size, Gen, NonEmpty} = get_prop(subenv, Type), + proper_gen:distlist_gen(Size, Gen, NonEmpty). + +%% @doc All lists of length `Len' containing elements of type `ElemType'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +-spec vector(length(), ElemType::raw_type()) -> proper_types:type(). +vector(Len, RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {env, Len}, + {generator, {typed, fun vector_gen/1}}, + {is_instance, {typed, fun vector_is_instance/2}}, + {internal_type, ElemType}, + {get_indices, fun vector_get_indices/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +vector_gen(Type) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + proper_gen:vector_gen(Len, ElemType). + +vector_is_instance(Type, X) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + is_list(X) + andalso length(X) =:= Len + andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +vector_get_indices(Type, _X) -> + lists:seq(1, get_prop(env, Type)). + +%% @doc The union of all types in `ListOfTypes'. `ListOfTypes' can't be empty. +%% The random instance generator is equally likely to choose any one of the +%% types in `ListOfTypes'. The shrinking subsystem will always try to shrink an +%% instance of a type union to an instance of the first type in `ListOfTypes', +%% thus you should write the simplest case first. +-spec union(ListOfTypes::[raw_type(),...]) -> proper_types:type(). +union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + ?BASIC([ + {env, Choices}, + {generator, {typed, fun union_gen/1}}, + {is_instance, {typed, fun union_is_instance/2}}, + {shrinkers, [fun union_shrinker_1/3, fun union_shrinker_2/3]} + ]). + +union_gen(Type) -> + Choices = get_prop(env,Type), + proper_gen:union_gen(Choices). + +union_is_instance(Type, X) -> + Choices = get_prop(env, Type), + lists:any(fun(C) -> is_instance(X, C) end, Choices). + +union_shrinker_1(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_first_choice_shrinker(X, Choices, S). + +union_shrinker_2(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_recursive_shrinker(X, Choices, S). + +%% @doc A specialization of {@link union/1}, where each type in `ListOfTypes' is +%% assigned a frequency. Frequencies must be Erlang expressions that evaluate to +%% positive integers. Types with larger frequencies are more likely to be chosen +%% by the random instance generator. The shrinking subsystem will ignore the +%% frequencies and try to shrink towards the first type in the list. +-spec weighted_union(ListOfTypes::[{frequency(),raw_type()},...]) -> + proper_types:type(). +weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + ?SUBTYPE(union(Choices), [ + {subenv, FreqChoices}, + {generator, {typed, fun weighted_union_gen/1}} + ]). + +weighted_union_gen(Gen) -> + FreqChoices = get_prop(subenv, Gen), + proper_gen:weighted_union_gen(FreqChoices). + +%% @private +-spec safe_union([raw_type(),...]) -> proper_types:type(). +safe_union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + subtype( + [{subenv, Choices}, + {generator, {typed, fun safe_union_gen/1}}], + union(Choices)). + +safe_union_gen(Type) -> + Choices = get_prop(subenv, Type), + proper_gen:safe_union_gen(Choices). + +%% @private +-spec safe_weighted_union([{frequency(),raw_type()},...]) -> + proper_types:type(). +safe_weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> + {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + subtype([{subenv, FreqChoices}, + {generator, {typed, fun safe_weighted_union_gen/1}}], + union(Choices)). + +safe_weighted_union_gen(Type) -> + FreqChoices = get_prop(subenv, Type), + proper_gen:safe_weighted_union_gen(FreqChoices). + +%% @doc All tuples whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a tuple of types. +-spec tuple(ListOfTypes::[raw_type()]) -> proper_types:type(). +tuple(RawFields) -> + Fields = [cook_outer(F) || F <- RawFields], + ?CONTAINER([ + {env, Fields}, + {generator, {typed, fun tuple_gen/1}}, + {is_instance, {typed, fun tuple_is_instance/2}}, + {internal_types, list_to_tuple(Fields)}, + {get_indices, fun tuple_get_indices/2}, + {retrieve, fun erlang:element/2}, + {update, fun tuple_update/3} + ]). + +tuple_gen(Type) -> + Fields = get_prop(env, Type), + proper_gen:tuple_gen(Fields). + +tuple_is_instance(Type, X) -> + Fields = get_prop(env, Type), + is_tuple(X) andalso fixed_list_test(tuple_to_list(X), Fields). + +tuple_get_indices(Type, _X) -> + lists:seq(1, length(get_prop(env, Type))). + +-spec tuple_update(index(), value(), tuple()) -> tuple(). +tuple_update(Index, NewElem, Tuple) -> + setelement(Index, Tuple, NewElem). + +%% @doc Tuples whose elements are all of type `ElemType'. +%% Instances shrink towards the 0-size tuple, `{}'. +-spec loose_tuple(ElemType::raw_type()) -> proper_types:type(). +loose_tuple(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?WRAPPER([ + {env, ElemType}, + {generator, {typed, fun loose_tuple_gen/2}}, + {reverse_gen, {typed, fun loose_tuple_rev/2}}, + {is_instance, {typed, fun loose_tuple_is_instance/2}} + ]). + +loose_tuple_gen(Type, Size) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_gen(Size, ElemType). + +loose_tuple_rev(Type, X) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_rev(X, ElemType). + +loose_tuple_is_instance(Type, X) -> + ElemType = get_prop(env, Type), + is_tuple(X) andalso list_test(tuple_to_list(X), ElemType). + +%% @doc Singleton type consisting only of `E'. `E' must be an evaluated term. +%% Also written simply as `E'. +-spec exactly(term()) -> proper_types:type(). +exactly(E) -> + ?BASIC([ + {env, E}, + {generator, {typed, fun exactly_gen/1}}, + {is_instance, {typed, fun exactly_is_instance/2}} + ]). + +exactly_gen(Type) -> + E = get_prop(env, Type), + proper_gen:exactly_gen(E). + +exactly_is_instance(Type, X) -> + E = get_prop(env, Type), + X =:= E. + +%% @doc All lists whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a list of types. +-spec fixed_list(ListOfTypes::maybe_improper_list(raw_type(),raw_type()|[])) -> + proper_types:type(). +fixed_list(MaybeImproperRawFields) -> + %% CAUTION: must handle improper lists + {Fields, Internal, Len, Retrieve, Update} = + case proper_arith:cut_improper_tail(MaybeImproperRawFields) of + % TODO: have cut_improper_tail return the length and use it in test? + {ProperRawHead, ImproperRawTail} -> + HeadLen = length(ProperRawHead), + CookedHead = [cook_outer(F) || F <- ProperRawHead], + CookedTail = cook_outer(ImproperRawTail), + {{CookedHead,CookedTail}, + CookedHead ++ CookedTail, + HeadLen + 1, + fun(I,L) -> improper_list_retrieve(I, L, HeadLen) end, + fun(I,V,L) -> improper_list_update(I, V, L, HeadLen) end}; + ProperRawFields -> + LocalFields = [cook_outer(F) || F <- ProperRawFields], + {LocalFields, + LocalFields, + length(ProperRawFields), + fun lists:nth/2, + fun proper_arith:list_update/3} + end, + ?CONTAINER([ + {env, {Fields, Len}}, + {generator, {typed, fun fixed_list_gen/1}}, + {is_instance, {typed, fun fixed_list_is_instance/2}}, + {internal_types, Internal}, + {get_indices, fun fixed_list_get_indices/2}, + {retrieve, Retrieve}, + {update, Update} + ]). + +fixed_list_gen(Type) -> + {Fields, _} = get_prop(env, Type), + proper_gen:fixed_list_gen(Fields). + +fixed_list_is_instance(Type, X) -> + {Fields, _} = get_prop(env, Type), + fixed_list_test(X, Fields). + +fixed_list_get_indices(Type, _X) -> + {_, Len} = get_prop(env, Type), + lists:seq(1, Len). + +-spec fixed_list_test(proper_gen:imm_instance(), + [proper_types:type()] | {[proper_types:type()], + proper_types:type()}) -> + boolean(). +fixed_list_test(X, {ProperHead,ImproperTail}) -> + is_list(X) andalso + begin + ProperHeadLen = length(ProperHead), + proper_arith:head_length(X) >= ProperHeadLen andalso + begin + {XHead,XTail} = lists:split(ProperHeadLen, X), + fixed_list_test(XHead, ProperHead) + andalso is_instance(XTail, ImproperTail) + end + end; +fixed_list_test(X, ProperFields) -> + is_list(X) + andalso length(X) =:= length(ProperFields) + andalso lists:all(fun({E,T}) -> is_instance(E, T) end, + lists:zip(X, ProperFields)). + +%% TODO: Move these 2 functions to proper_arith? +-spec improper_list_retrieve(index(), nonempty_improper_list(value(),value()), + pos_integer()) -> value(). +improper_list_retrieve(Index, List, HeadLen) -> + case Index =< HeadLen of + true -> lists:nth(Index, List); + false -> lists:nthtail(HeadLen, List) + end. + +-spec improper_list_update(index(), value(), + nonempty_improper_list(value(),value()), + pos_integer()) -> + nonempty_improper_list(value(),value()). +improper_list_update(Index, Value, List, HeadLen) -> + case Index =< HeadLen of + %% TODO: This happens to work, but is not implied by list_update's spec. + true -> proper_arith:list_update(Index, Value, List); + false -> lists:sublist(List, HeadLen) ++ Value + end. + +%% @doc All pure functions that map instances of `ArgTypes' to instances of +%% `RetType'. The syntax `function(Arity, RetType)' is also acceptable. +-spec function(ArgTypes::[raw_type()] | arity(), RetType::raw_type()) -> + proper_types:type(). +function(Arity, RawRetType) when is_integer(Arity), Arity >= 0, Arity =< 255 -> + RetType = cook_outer(RawRetType), + ?BASIC([ + {env, {Arity, RetType}}, + {generator, {typed, fun function_gen/1}}, + {is_instance, {typed, fun function_is_instance/2}} + ]); +function(RawArgTypes, RawRetType) -> + function(length(RawArgTypes), RawRetType). + +function_gen(Type) -> + {Arity, RetType} = get_prop(env, Type), + proper_gen:function_gen(Arity, RetType). + +function_is_instance(Type, X) -> + {Arity, RetType} = get_prop(env, Type), + is_function(X, Arity) + %% TODO: what if it's not a function we produced? + andalso equal_types(RetType, proper_gen:get_ret_type(X)). + +%% @doc All Erlang terms (that PropEr can produce). For reasons of efficiency, +%% functions are never produced as instances of this type.<br /> +%% CAUTION: Instances of this type are expensive to produce, shrink and instance- +%% check, both in terms of processing time and consumed memory. Only use this +%% type if you are certain that you need it. +-spec any() -> proper_types:type(). +any() -> + AllTypes = [integer(),float(),atom(),bitstring(),?LAZY(loose_tuple(any())), + ?LAZY(list(any()))], + ?SUBTYPE(union(AllTypes), [ + {generator, fun proper_gen:any_gen/1} + ]). + + +%%------------------------------------------------------------------------------ +%% Type aliases +%%------------------------------------------------------------------------------ + +%% @equiv integer(inf, inf) +-spec integer() -> proper_types:type(). +integer() -> integer(inf, inf). + +%% @equiv integer(0, inf) +-spec non_neg_integer() -> proper_types:type(). +non_neg_integer() -> integer(0, inf). + +%% @equiv integer(1, inf) +-spec pos_integer() -> proper_types:type(). +pos_integer() -> integer(1, inf). + +%% @equiv integer(inf, -1) +-spec neg_integer() -> proper_types:type(). +neg_integer() -> integer(inf, -1). + +%% @equiv integer(Low, High) +-spec range(extint(), extint()) -> proper_types:type(). +range(Low, High) -> integer(Low, High). + +%% @equiv float(inf, inf) +-spec float() -> proper_types:type(). +float() -> float(inf, inf). + +%% @equiv float(0.0, inf) +-spec non_neg_float() -> proper_types:type(). +non_neg_float() -> float(0.0, inf). + +%% @equiv union([integer(), float()]) +-spec number() -> proper_types:type(). +number() -> union([integer(), float()]). + +%% @doc The atoms `true' and `false'. Instances shrink towards `false'. +-spec boolean() -> proper_types:type(). +boolean() -> union(['false', 'true']). + +%% @equiv integer(0, 255) +-spec byte() -> proper_types:type(). +byte() -> integer(0, 255). + +%% @equiv integer(0, 16#10ffff) +-spec char() -> proper_types:type(). +char() -> integer(0, 16#10ffff). + +%% @equiv list(any()) +-spec list() -> proper_types:type(). +list() -> list(any()). + +%% @equiv loose_tuple(any()) +-spec tuple() -> proper_types:type(). +tuple() -> loose_tuple(any()). + +%% @equiv list(char()) +-spec string() -> proper_types:type(). +string() -> list(char()). + +%% @equiv weighted_union(FreqChoices) +-spec wunion([{frequency(),raw_type()},...]) -> proper_types:type(). +wunion(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv any() +-spec term() -> proper_types:type(). +term() -> any(). + +%% @equiv union([non_neg_integer() | infinity]) +-spec timeout() -> proper_types:type(). +timeout() -> union([non_neg_integer(), 'infinity']). + +%% @equiv integer(0, 255) +-spec arity() -> proper_types:type(). +arity() -> integer(0, 255). + + +%%------------------------------------------------------------------------------ +%% QuickCheck compatibility types +%%------------------------------------------------------------------------------ + +%% @doc Small integers (bound by the current value of the `size' parameter). +%% Instances shrink towards `0'. +-spec int() -> proper_types:type(). +int() -> ?SIZED(Size, integer(-Size,Size)). + +%% @doc Small non-negative integers (bound by the current value of the `size' +%% parameter). Instances shrink towards `0'. +-spec nat() -> proper_types:type(). +nat() -> ?SIZED(Size, integer(0,Size)). + +%% @equiv integer() +-spec largeint() -> proper_types:type(). +largeint() -> integer(). + +%% @equiv float() +-spec real() -> proper_types:type(). +real() -> float(). + +%% @equiv boolean() +-spec bool() -> proper_types:type(). +bool() -> boolean(). + +%% @equiv integer(Low, High) +-spec choose(extint(), extint()) -> proper_types:type(). +choose(Low, High) -> integer(Low, High). + +%% @equiv union(Choices) +-spec elements([raw_type(),...]) -> proper_types:type(). +elements(Choices) -> union(Choices). + +%% @equiv union(Choices) +-spec oneof([raw_type(),...]) -> proper_types:type(). +oneof(Choices) -> union(Choices). + +%% @equiv weighted_union(Choices) +-spec frequency([{frequency(),raw_type()},...]) -> proper_types:type(). +frequency(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv exactly(E) +-spec return(term()) -> proper_types:type(). +return(E) -> exactly(E). + +%% @doc Adds a default value, `Default', to `Type'. +%% The default serves as a primary shrinking target for instances, while it +%% is also chosen by the random instance generation subsystem half the time. +-spec default(raw_type(), raw_type()) -> proper_types:type(). +default(Default, Type) -> + union([Default, Type]). + +%% @doc All sorted lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec orderedlist(ElemType::raw_type()) -> proper_types:type(). +orderedlist(RawElemType) -> + ?LET(L, list(RawElemType), lists:sort(L)). + +%% @equiv function(0, RetType) +-spec function0(raw_type()) -> proper_types:type(). +function0(RetType) -> + function(0, RetType). + +%% @equiv function(1, RetType) +-spec function1(raw_type()) -> proper_types:type(). +function1(RetType) -> + function(1, RetType). + +%% @equiv function(2, RetType) +-spec function2(raw_type()) -> proper_types:type(). +function2(RetType) -> + function(2, RetType). + +%% @equiv function(3, RetType) +-spec function3(raw_type()) -> proper_types:type(). +function3(RetType) -> + function(3, RetType). + +%% @equiv function(4, RetType) +-spec function4(raw_type()) -> proper_types:type(). +function4(RetType) -> + function(4, RetType). + +%% @doc A specialization of {@link default/2}, where `Default' and `Type' are +%% assigned weights to be considered by the random instance generator. The +%% shrinking subsystem will ignore the weights and try to shrink using the +%% default value. +-spec weighted_default({frequency(),raw_type()}, {frequency(),raw_type()}) -> + proper_types:type(). +weighted_default(Default, Type) -> + weighted_union([Default, Type]). + + +%%------------------------------------------------------------------------------ +%% Additional type specification functions +%%------------------------------------------------------------------------------ + +%% @doc Overrides the `size' parameter used when generating instances of +%% `Type' with `NewSize'. Has no effect on size-less types, such as unions. +%% Also, this will not affect the generation of any internal types contained in +%% `Type', such as the elements of a list - those will still be generated +%% using the test-wide value of `size'. One use of this function is to modify +%% types to produce instances that grow faster or slower, like so: +%% ```?SIZED(Size, resize(Size * 2, list(integer()))''' +%% The above specifies a list type that grows twice as fast as normal lists. +-spec resize(size(), Type::raw_type()) -> proper_types:type(). +resize(NewSize, RawType) -> + Type = cook_outer(RawType), + case find_prop(size_transform, Type) of + {ok,Transform} -> + add_prop(size_transform, fun(_S) -> Transform(NewSize) end, Type); + error -> + add_prop(size_transform, fun(_S) -> NewSize end, Type) + end. + +%% @doc This is a predefined constraint that can be applied to random-length +%% list and binary types to ensure that the produced values are never empty. +%% +%% e.g. {@link list/0}, {@link string/0}, {@link binary/0}) +-spec non_empty(ListType::raw_type()) -> proper_types:type(). +non_empty(RawListType) -> + ?SUCHTHAT(L, RawListType, L =/= [] andalso L =/= <<>>). + +%% @doc Creates a new type which is equivalent to `Type', but whose instances +%% are never shrunk by the shrinking subsystem. +-spec noshrink(Type::raw_type()) -> proper_types:type(). +noshrink(RawType) -> + add_prop(noshrink, true, cook_outer(RawType)). + +%% @doc Associates the atom key `Parameter' with the value `Value' while +%% generating instances of `Type'. +-spec with_parameter(atom(), value(), Type::raw_type()) -> proper_types:type(). +with_parameter(Parameter, Value, RawType) -> + with_parameters([{Parameter,Value}], RawType). + +%% @doc Similar to {@link with_parameter/3}, but accepts a list of +%% `{Parameter, Value}' pairs. +-spec with_parameters([{atom(),value()}], Type::raw_type()) -> + proper_types:type(). +with_parameters(PVlist, RawType) -> + Type = cook_outer(RawType), + case find_prop(parameters, Type) of + {ok,Params} when is_list(Params) -> + append_list_to_prop(parameters, PVlist, Type); + error -> + add_prop(parameters, PVlist, Type) + end. + +%% @doc Returns the value associated with `Parameter', or `Default' in case +%% `Parameter' is not associated with any value. +-spec parameter(atom(), value()) -> value(). +parameter(Parameter, Default) -> + Parameters = + case erlang:get('$parameters') of + undefined -> []; + List -> List + end, + proplists:get_value(Parameter, Parameters, Default). + +%% @equiv parameter(Parameter, undefined) +-spec parameter(atom()) -> value(). +parameter(Parameter) -> + parameter(Parameter, undefined). diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl new file mode 100644 index 0000000000..b16075763f --- /dev/null +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl @@ -0,0 +1,2411 @@ +%%% Copyright 2010-2016 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2016 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Erlang type system - PropEr type system integration module. +%%% +%%% PropEr can parse types expressed in Erlang's type language and convert them +%%% to its own type format. Such expressions can be used instead of regular type +%%% constructors in the second argument of `?FORALL's. No extra notation is +%%% required; PropEr will detect which calls correspond to native types by +%%% applying a parse transform during compilation. This parse transform is +%%% automatically applied to any module that includes the `proper.hrl' header +%%% file. You can disable this feature by compiling your modules with +%%% `-DPROPER_NO_TRANS'. Note that this will currently also disable the +%%% automatic exporting of properties. +%%% +%%% The use of native types in properties is subject to the following usage +%%% rules: +%%% <ul> +%%% <li>Native types cannot be used outside of `?FORALL's.</li> +%%% <li>Inside `?FORALL's, native types can be combined with other native +%%% types, and even with PropEr types, inside tuples and lists (the constructs +%%% `[...]', `{...}' and `++' are all allowed).</li> +%%% <li>All other constructs of Erlang's built-in type system (e.g. `|' for +%%% union, `_' as an alias of `any()', `<<_:_>>' binary type syntax and +%%% `fun((...) -> ...)' function type syntax) are not allowed in `?FORALL's, +%%% because they are rejected by the Erlang parser.</li> +%%% <li>Anything other than a tuple constructor, list constructor, `++' +%%% application, local or remote call will automatically be considered a +%%% PropEr type constructor and not be processed further by the parse +%%% transform.</li> +%%% <li>Parametric native types are fully supported; of course, they can only +%%% appear instantiated in a `?FORALL'. The arguments of parametric native +%%% types are always interpreted as native types.</li> +%%% <li>Parametric PropEr types, on the other hand, can take any kind of +%%% argument. You can even mix native and PropEr types in the arguments of a +%%% PropEr type. For example, assuming that the following declarations are +%%% present: +%%% ``` my_proper_type() -> ?LET(...). +%%% -type my_native_type() :: ... .''' +%%% Then the following expressions are all legal: +%%% ``` vector(2, my_native_type()) +%%% function(0, my_native_type()) +%%% union([my_proper_type(), my_native_type()])''' </li> +%%% <li>Some type constructors can take native types as arguments (but only +%%% inside `?FORALL's): +%%% <ul> +%%% <li>`?SUCHTHAT', `?SUCHTHATMAYBE', `non_empty', `noshrink': these work +%%% with native types too</li> +%%% <li>`?LAZY', `?SHRINK', `resize', `?SIZED': these don't work with native +%%% types</li> +%%% <li>`?LET', `?LETSHRINK': only the top-level base type can be a native +%%% type</li> +%%% </ul></li> +%%% <li>Native type declarations in the `?FORALL's of a module can reference any +%%% custom type declared in a `-type' or `-opaque' attribute of the same +%%% module, as long as no module identifier is used.</li> +%%% <li>Typed records cannot be referenced inside `?FORALL's using the +%%% `#rec_name{}' syntax. To use a typed record in a `?FORALL', enclose the +%%% record in a custom type like so: +%%% ``` -type rec_name() :: #rec_name{}. ''' +%%% and use the custom type instead.</li> +%%% <li>`?FORALL's may contain references to self-recursive or mutually +%%% recursive native types, so long as each type in the hierarchy has a clear +%%% base case. +%%% Currently, PropEr requires that the toplevel of any recursive type +%%% declaration is either a (maybe empty) list or a union containing at least +%%% one choice that doesn't reference the type directly (it may, however, +%%% reference any of the types that are mutually recursive with it). This +%%% means, for example, that some valid recursive type declarations, such as +%%% this one: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none' | a()}. ''' +%%% are not accepted by PropEr. However, such types can be rewritten in a way +%%% that allows PropEr to parse them: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none'} | {'a',a()}. ''' +%%% This also means that recursive record declarations are not allowed: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% A little rewritting can usually remedy this problem as well: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{b :: 'nil'} | #rec{b :: rec()}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% </li> +%%% <li>Remote types may be referenced in a `?FORALL', so long as they are +%%% exported from the remote module. Currently, PropEr requires that any +%%% remote modules whose types are directly referenced from within properties +%%% are present in the code path at compile time, either compiled with +%%% `debug_info' enabled or in source form. If PropEr cannot find a remote +%%% module at all, finds only a compiled object file with no debug +%%% information or fails to compile the source file, all calls to that module +%%% will automatically be considered calls to PropEr type constructors.</li> +%%% <li>For native types to be translated correctly, both the module that +%%% contains the `?FORALL' declaration as well as any module that contains +%%% the declaration of a type referenced (directly or indirectly) from inside +%%% a `?FORALL' must be present in the code path at runtime, either compiled +%%% with `debug_info' enabled or in source form.</li> +%%% <li>Local types with the same name as an auto-imported BIF are not accepted +%%% by PropEr, unless the BIF in question has been declared in a +%%% `no_auto_import' option.</li> +%%% <li>When an expression can be interpreted both as a PropEr type and as a +%%% native type, the former takes precedence. This means that a function +%%% `foo()' will shadow a type `foo()' if they are both present in the module. +%%% The same rule applies to remote functions and types as well.</li> +%%% <li>The above may cause some confusion when list syntax is used: +%%% <ul> +%%% <li>The expression `[integer()]' can be interpreted both ways, so the +%%% PropEr way applies. Therefore, instances of this type will always be +%%% lists of length 1, not arbitrary integer lists, as would be expected +%%% when interpreting the expression as a native type.</li> +%%% <li>Assuming that a custom type foo/1 has been declared, the expression +%%% `foo([integer()])' can only be interpreted as a native type declaration, +%%% which means that the generic type of integer lists will be passed to +%%% `foo/1'.</li> +%%% </ul></li> +%%% <li>Currently, PropEr does not detect the following mistakes: +%%% <ul> +%%% <li>inline record-field specializations that reference non-existent +%%% fields</li> +%%% <li>type parameters that are not present in the RHS of a `-type' +%%% declaration</li> +%%% <li>using `_' as a type variable in the LHS of a `-type' declaration</li> +%%% <li>using the same variable in more than one position in the LHS of a +%%% `-type' declaration</li> +%%% </ul> +%%% </li> +%%% </ul> +%%% +%%% You can use <a href="#index">these</a> functions to try out the type +%%% translation subsystem. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_typeserver). +-behaviour(gen_server). +-export([demo_translate_type/2, demo_is_instance/3]). + +-export([start/0, restart/0, stop/0, create_spec_test/3, get_exp_specced/1, + is_instance/3, translate_type/1]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, + code_change/3]). +-export([get_exp_info/1, match/2]). + +-export_type([imm_type/0, mod_exp_types/0, mod_exp_funs/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(SRC_FILE_EXT, ".erl"). + +-ifdef(AT_LEAST_19). +-define(anno(L), erl_anno:new(L)). +-else. +-define(anno(L), L). +-endif. + +%% Starting with 18.0 we need to handle both 'type' and 'user_type' tags; +%% prior Erlang/OTP releases had only 'type' as a tag. +-define(IS_TYPE_TAG(T), (T =:= type orelse T =:= user_type)). + +%% CAUTION: all these must be sorted +-define(STD_TYPES_0, + [any,arity,atom,binary,bitstring,bool,boolean,byte,char,float,integer, + list,neg_integer,non_neg_integer,number,pos_integer,string,term, + timeout]). +-define(HARD_ADTS, + %% gb_trees:iterator and gb_sets:iterator are NOT hardcoded + [{{array,0},array}, {{array,1},proper_array}, + {{dict,0},dict}, {{dict,2},proper_dict}, + {{gb_set,0},gb_sets}, {{gb_set,1},proper_gb_sets}, + {{gb_tree,0},gb_trees}, {{gb_tree,2},proper_gb_trees}, + {{orddict,2},proper_orddict}, + {{ordset,1},proper_ordsets}, + {{queue,0},queue}, {{queue,1},proper_queue}, + {{set,0},sets}, {{set,1},proper_sets}]). +-define(HARD_ADT_MODS, + [{array, [{{array,0}, + {{type,0,record,[{atom,0,array}]},[]}}]}, + {dict, [{{dict,0}, + {{type,0,record,[{atom,0,dict}]},[]}}]}, + {gb_sets, [{{gb_set,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_set_node,[]}]},[]}}]}, + {gb_trees, [{{gb_tree,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_tree_node,[]}]},[]}}]}, + %% Our parametric ADTs are already declared as normal types, we just + %% need to change them to opaques. + {proper_array, [{{array,1},already_declared}]}, + {proper_dict, [{{dict,2},already_declared}]}, + {proper_gb_sets, [{{gb_set,1},already_declared}, + {{iterator,1},already_declared}]}, + {proper_gb_trees, [{{gb_tree,2},already_declared}, + {{iterator,2},already_declared}]}, + {proper_orddict, [{{orddict,2},already_declared}]}, + {proper_ordsets, [{{ordset,1},already_declared}]}, + {proper_queue, [{{queue,1},already_declared}]}, + {proper_sets, [{{set,1},already_declared}]}, + {queue, [{{queue,0}, + {{type,0,tuple,[{type,0,list,[]},{type,0,list,[]}]},[]}}]}, + {sets, [{{set,0}, + {{type,0,record,[{atom,0,set}]},[]}}]}]). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_name() :: atom(). +-type var_name() :: atom(). %% TODO: also integers? +-type field_name() :: atom(). + +-type type_kind() :: 'type' | 'record'. +-type type_ref() :: {type_kind(),type_name(),arity()}. +-ifdef(NO_MODULES_IN_OPAQUES). +-type substs_dict() :: dict(). %% dict(field_name(),ret_type()) +-else. +-type substs_dict() :: dict:dict(field_name(),ret_type()). +-endif. +-type full_type_ref() :: {mod_name(),type_kind(),type_name(), + [ret_type()] | substs_dict()}. +-type symb_info() :: 'not_symb' | {'orig_abs',abs_type()}. +-type type_repr() :: {'abs_type',abs_type(),[var_name()],symb_info()} + | {'cached',fin_type(),abs_type(),symb_info()} + | {'abs_record',[{field_name(),abs_type()}]}. +-type gen_fun() :: fun((size()) -> fin_type()). +-type rec_fun() :: fun(([gen_fun()],size()) -> fin_type()). +-type rec_arg() :: {boolean() | {'list',boolean(),rec_fun()},full_type_ref()}. +-type rec_args() :: [rec_arg()]. +-type ret_type() :: {'simple',fin_type()} | {'rec',rec_fun(),rec_args()}. +-type rec_fun_info() :: {pos_integer(),pos_integer(),[arity(),...], + [rec_fun(),...]}. + +-type imm_type_ref() :: {type_name(),arity()}. +-type hard_adt_repr() :: {abs_type(),[var_name()]} | 'already_declared'. +-type fun_ref() :: {fun_name(),arity()}. +-type fun_repr() :: fun_clause_repr(). +-type fun_clause_repr() :: {[abs_type()],abs_type()}. +-type proc_fun_ref() :: {fun_name(),[abs_type()],abs_type()}. +-type full_imm_type_ref() :: {mod_name(),type_name(),arity()}. +-type imm_stack() :: [full_imm_type_ref()]. +-type pat_field() :: 0 | 1 | atom(). +-type pattern() :: loose_tuple(pat_field()). +-type next_step() :: 'none' | 'take_head' | {'match_with',pattern()}. + +-ifdef(NO_MODULES_IN_OPAQUES). +%% @private_type +-type mod_exp_types() :: set(). %% set(imm_type_ref()) +-type mod_types() :: dict(). %% dict(type_ref(),type_repr()) +%% @private_type +-type mod_exp_funs() :: set(). %% set(fun_ref()) +-type mod_specs() :: dict(). %% dict(fun_ref(),fun_repr()) +-else. +%% @private_type +-type mod_exp_types() :: sets:set(imm_type_ref()). +-type mod_types() :: dict:dict(type_ref(),type_repr()). +%% @private_type +-type mod_exp_funs() :: sets:set(fun_ref()). +-type mod_specs() :: dict:dict(fun_ref(),fun_repr()). +-endif. + +-ifdef(NO_MODULES_IN_OPAQUES). +-record(state, + {cached = dict:new() :: dict(), %% dict(imm_type(),fin_type()) + exp_types = dict:new() :: dict(), %% dict(mod_name(),mod_exp_types()) + types = dict:new() :: dict(), %% dict(mod_name(),mod_types()) + exp_specs = dict:new() :: dict()}). %% dict(mod_name(),mod_specs()) +-else. +-record(state, + {cached = dict:new() :: dict:dict(imm_type(),fin_type()), + exp_types = dict:new() :: dict:dict(mod_name(),mod_exp_types()), + types = dict:new() :: dict:dict(mod_name(),mod_types()), + exp_specs = dict:new() :: dict:dict(mod_name(),mod_specs())}). +-endif. +-type state() :: #state{}. + +-record(mod_info, + {mod_exp_types = sets:new() :: mod_exp_types(), + mod_types = dict:new() :: mod_types(), + mod_opaques = sets:new() :: mod_exp_types(), + mod_exp_funs = sets:new() :: mod_exp_funs(), + mod_specs = dict:new() :: mod_specs()}). +-type mod_info() :: #mod_info{}. + +-type stack() :: [full_type_ref() | 'tuple' | 'list' | 'union' | 'fun']. +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_dict() :: dict(). %% dict(var_name(),ret_type()) +-else. +-type var_dict() :: dict:dict(var_name(),ret_type()). +-endif. +%% @private_type +-type imm_type() :: {mod_name(),string()}. +%% @alias +-type fin_type() :: proper_types:type(). +-type tagged_result(T) :: {'ok',T} | 'error'. +-type tagged_result2(T,S) :: {'ok',T,S} | 'error'. +%% @alias +-type rich_result(T) :: {'ok',T} | {'error',term()}. +-type rich_result2(T,S) :: {'ok',T,S} | {'error',term()}. +-type false_positive_mfas() :: proper:false_positive_mfas(). + +-type server_call() :: {'create_spec_test',mfa(),timeout(),false_positive_mfas()} + | {'get_exp_specced',mod_name()} + | {'get_type_repr',mod_name(),type_ref(),boolean()} + | {'translate_type',imm_type()}. +-type server_response() :: rich_result(proper:test()) + | rich_result([mfa()]) + | rich_result(type_repr()) + | rich_result(fin_type()). + + +%%------------------------------------------------------------------------------ +%% Server interface functions +%%------------------------------------------------------------------------------ + +%% @private +-spec start() -> 'ok'. +start() -> + {ok,TypeserverPid} = gen_server:start_link(?MODULE, dummy, []), + put('$typeserver_pid', TypeserverPid), + ok. + +%% @private +-spec restart() -> 'ok'. +restart() -> + TypeserverPid = get('$typeserver_pid'), + case (TypeserverPid =:= undefined orelse not is_process_alive(TypeserverPid)) of + true -> start(); + false -> ok + end. + +%% @private +-spec stop() -> 'ok'. +stop() -> + TypeserverPid = get('$typeserver_pid'), + erase('$typeserver_pid'), + gen_server:cast(TypeserverPid, stop). + +%% @private +-spec create_spec_test(mfa(), timeout(), false_positive_mfas()) -> rich_result(proper:test()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}). + +%% @private +-spec get_exp_specced(mod_name()) -> rich_result([mfa()]). +get_exp_specced(Mod) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_exp_specced,Mod}). + +-spec get_type_repr(mod_name(), type_ref(), boolean()) -> + rich_result(type_repr()). +get_type_repr(Mod, TypeRef, IsRemote) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_type_repr,Mod,TypeRef,IsRemote}). + +%% @private +-spec translate_type(imm_type()) -> rich_result(fin_type()). +translate_type(ImmType) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {translate_type,ImmType}). + +%% @doc Translates the native type expression `TypeExpr' (which should be +%% provided inside a string) into a PropEr type, which can then be passed to any +%% of the demo functions defined in the {@link proper_gen} module. PropEr acts +%% as if it found this type expression inside the code of module `Mod'. +-spec demo_translate_type(mod_name(), string()) -> rich_result(fin_type()). +demo_translate_type(Mod, TypeExpr) -> + start(), + Result = translate_type({Mod,TypeExpr}), + stop(), + Result. + +%% @doc Checks if `Term' is a valid instance of native type `TypeExpr' (which +%% should be provided inside a string). PropEr acts as if it found this type +%% expression inside the code of module `Mod'. +-spec demo_is_instance(term(), mod_name(), string()) -> + boolean() | {'error',term()}. +demo_is_instance(Term, Mod, TypeExpr) -> + case parse_type(TypeExpr) of + {ok,TypeForm} -> + start(), + Result = + %% Force the typeserver to load the module. + case translate_type({Mod,"integer()"}) of + {ok,_FinType} -> + try is_instance(Term, Mod, TypeForm) + catch + throw:{'$typeserver',Reason} -> {error, Reason} + end; + {error,_Reason} = Error -> + Error + end, + stop(), + Result; + {error,_Reason} = Error -> + Error + end. + + +%%------------------------------------------------------------------------------ +%% Implementation of gen_server interface +%%------------------------------------------------------------------------------ + +%% @private +-spec init(_) -> {'ok',state()}. +init(_) -> + {ok, #state{}}. + +%% @private +-spec handle_call(server_call(), _, state()) -> + {'reply',server_response(),state()}. +handle_call({create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}, _From, State) -> + case create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) of + {ok,Test,NewState} -> + {reply, {ok,Test}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_exp_specced,Mod}, _From, State) -> + case get_exp_specced(Mod, State) of + {ok,MFAs,NewState} -> + {reply, {ok,MFAs}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_type_repr,Mod,TypeRef,IsRemote}, _From, State) -> + case get_type_repr(Mod, TypeRef, IsRemote, State) of + {ok,TypeRepr,NewState} -> + {reply, {ok,TypeRepr}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({translate_type,ImmType}, _From, State) -> + case translate_type(ImmType, State) of + {ok,FinType,NewState} -> + {reply, {ok,FinType}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end. + +%% @private +-spec handle_cast('stop', state()) -> {'stop','normal',state()}. +handle_cast(stop, State) -> + {stop, normal, State}. + +%% @private +-spec handle_info(term(), state()) -> {'stop',{'received_info',term()},state()}. +handle_info(Info, State) -> + {stop, {received_info,Info}, State}. + +%% @private +-spec terminate(term(), state()) -> 'ok'. +terminate(_Reason, _State) -> + ok. + +%% @private +-spec code_change(term(), state(), _) -> {'ok',state()}. +code_change(_OldVsn, State, _) -> + {ok, State}. + + +%%------------------------------------------------------------------------------ +%% Top-level interface +%%------------------------------------------------------------------------------ + +-spec create_spec_test(mfa(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) -> + case get_exp_spec(MFA, State) of + {ok,FunRepr,NewState} -> + make_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, NewState); + {error,_Reason} = Error -> + Error + end. + +-spec get_exp_spec(mfa(), state()) -> rich_result2(fun_repr(),state()). +get_exp_spec({Mod,Fun,Arity} = MFA, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + case dict:find({Fun,Arity}, ModExpSpecs) of + {ok,FunRepr} -> + {ok, FunRepr, NewState}; + error -> + {error, {function_not_exported_or_specced,MFA}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec make_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +make_spec_test({Mod,_Fun,_Arity}=MFA, {Domain,_Range}=FunRepr, SpecTimeout, FalsePositiveMFAs, State) -> + case convert(Mod, {type,?anno(0),'$fixed_list',Domain}, State) of + {ok,FinType,NewState} -> + Test = ?FORALL(Args, FinType, apply_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, Args)), + {ok, Test, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec apply_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), term()) -> proper:test(). +apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiveMFAs, Args) -> + ?TIMEOUT(SpecTimeout, + begin + %% NOTE: only call apply/3 inside try/catch (do not trust ?MODULE:is_instance/3) + Result = + try apply(Mod, Fun, Args) of + X -> {ok, X} + catch + X:Y -> {X, Y} + end, + case Result of + {ok, Z} -> + case ?MODULE:is_instance(Z, Mod, Range) of + true -> + true; + false when is_function(FalsePositiveMFAs) -> + FalsePositiveMFAs(MFA, Args, {fail, Z}); + false -> + false + end; + Exception when is_function(FalsePositiveMFAs) -> + case FalsePositiveMFAs(MFA, Args, Exception) of + true -> + true; + false -> + error(Exception, erlang:get_stacktrace()) + end; + Exception -> + error(Exception, erlang:get_stacktrace()) + end + end). + +-spec get_exp_specced(mod_name(), state()) -> rich_result2([mfa()],state()). +get_exp_specced(Mod, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + ExpSpecced = [{Mod,F,A} || {F,A} <- dict:fetch_keys(ModExpSpecs)], + {ok, ExpSpecced, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec get_type_repr(mod_name(), type_ref(), boolean(), state()) -> + rich_result2(type_repr(),state()). +get_type_repr(Mod, {type,Name,Arity} = TypeRef, true, State) -> + case prepare_for_remote(Mod, Name, Arity, State) of + {ok,NewState} -> + get_type_repr(Mod, TypeRef, false, NewState); + {error,_Reason} = Error -> + Error + end; +get_type_repr(Mod, TypeRef, false, #state{types = Types} = State) -> + ModTypes = dict:fetch(Mod, Types), + case dict:find(TypeRef, ModTypes) of + {ok,TypeRepr} -> + {ok, TypeRepr, State}; + error -> + {error, {missing_type,Mod,TypeRef}} + end. + +-spec prepare_for_remote(mod_name(), type_name(), arity(), state()) -> + rich_result(state()). +prepare_for_remote(RemMod, Name, Arity, State) -> + case add_module(RemMod, State) of + {ok,#state{exp_types = ExpTypes} = NewState} -> + RemModExpTypes = dict:fetch(RemMod, ExpTypes), + case sets:is_element({Name,Arity}, RemModExpTypes) of + true -> {ok, NewState}; + false -> {error, {type_not_exported,{RemMod,Name,Arity}}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec translate_type(imm_type(), state()) -> rich_result2(fin_type(),state()). +translate_type({Mod,Str} = ImmType, #state{cached = Cached} = State) -> + case dict:find(ImmType, Cached) of + {ok,Type} -> + {ok, Type, State}; + error -> + case parse_type(Str) of + {ok,TypeForm} -> + case add_module(Mod, State) of + {ok,NewState} -> + case convert(Mod, TypeForm, NewState) of + {ok,FinType, + #state{cached = Cached} = FinalState} -> + NewCached = dict:store(ImmType, FinType, + Cached), + {ok, FinType, + FinalState#state{cached = NewCached}}; + {error,_Reason} = Error -> + Error + end; + {error,_Reason} = Error -> + Error + end; + {error,Reason} -> + {error, {parse_error,Str,Reason}} + end + end. + +-spec parse_type(string()) -> rich_result(abs_type()). +parse_type(Str) -> + TypeStr = "-type mytype() :: " ++ Str ++ ".", + case erl_scan:string(TypeStr) of + {ok,Tokens,_EndLocation} -> + case erl_parse:parse_form(Tokens) of + {ok,{attribute,_Line,type,{mytype,TypeExpr,[]}}} -> + {ok, TypeExpr}; + {error,_ErrorInfo} = Error -> + Error + end; + {error,ErrorInfo,_EndLocation} -> + {error, ErrorInfo} + end. + +-spec add_module(mod_name(), state()) -> rich_result(state()). +add_module(Mod, #state{exp_types = ExpTypes} = State) -> + case dict:is_key(Mod, ExpTypes) of + true -> + {ok, State}; + false -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + ModInfo = process_adts(Mod, RawModInfo), + {ok, store_mod_info(Mod, ModInfo, State)}; + {error,Reason} -> + {error, {cant_load_code,Mod,Reason}} + end + end. + +%% @private +-spec get_exp_info(mod_name()) -> rich_result2(mod_exp_types(),mod_exp_funs()). +get_exp_info(Mod) -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + {ok, RawModInfo#mod_info.mod_exp_types, ModExpFuns}; + {error,_Reason} = Error -> + Error + end. + +-spec get_code_and_exports(mod_name()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports(Mod) -> + case code:get_object_code(Mod) of + {Mod, ObjBin, _ObjFileName} -> + case get_chunks(ObjBin) of + {ok,_AbsCode,_ModExpFuns} = Result -> + Result; + {error,Reason} -> + get_code_and_exports_from_source(Mod, Reason) + end; + error -> + get_code_and_exports_from_source(Mod, cant_find_object_file) + end. + +-spec get_code_and_exports_from_source(mod_name(), term()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports_from_source(Mod, ObjError) -> + SrcFileName = atom_to_list(Mod) ++ ?SRC_FILE_EXT, + case code:where_is_file(SrcFileName) of + FullSrcFileName when is_list(FullSrcFileName) -> + Opts = [binary,debug_info,return_errors,{d,'PROPER_REMOVE_PROPS'}], + case compile:file(FullSrcFileName, Opts) of + {ok,Mod,Binary} -> + get_chunks(Binary); + {error,Errors,_Warnings} -> + {error, {ObjError,{cant_compile_source_file,Errors}}} + end; + non_existing -> + {error, {ObjError,cant_find_source_file}} + end. + +-spec get_chunks(string() | binary()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_chunks(ObjFile) -> + case beam_lib:chunks(ObjFile, [abstract_code,exports]) of + {ok,{_Mod,[{abstract_code,AbsCodeChunk},{exports,ExpFunsList}]}} -> + case AbsCodeChunk of + {raw_abstract_v1,AbsCode} -> + %% HACK: Add a declaration for iolist() to every module + {ok, add_iolist(AbsCode), sets:from_list(ExpFunsList)}; + no_abstract_code -> + {error, no_abstract_code}; + _ -> + {error, unsupported_abstract_code_format} + end; + {error,beam_lib,Reason} -> + {error, Reason} + end. + +-spec add_iolist([abs_form()]) -> [abs_form()]. +add_iolist(Forms) -> + IOListDef = + {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}, + IOListDecl = {attribute,0,type,{iolist,IOListDef,[]}}, + [IOListDecl | Forms]. + +-spec get_mod_info(mod_name(), [abs_form()], mod_exp_funs()) -> mod_info(). +get_mod_info(Mod, AbsCode, ModExpFuns) -> + StartModInfo = #mod_info{mod_exp_funs = ModExpFuns}, + ImmModInfo = lists:foldl(fun add_mod_info/2, StartModInfo, AbsCode), + #mod_info{mod_specs = AllModSpecs} = ImmModInfo, + IsExported = fun(FunRef,_FunRepr) -> sets:is_element(FunRef,ModExpFuns) end, + ModExpSpecs = dict:filter(IsExported, AllModSpecs), + ModInfo = ImmModInfo#mod_info{mod_specs = ModExpSpecs}, + case orddict:find(Mod, ?HARD_ADT_MODS) of + {ok,ModADTs} -> + #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo, + ModADTsSet = + sets:from_list([ImmTypeRef + || {ImmTypeRef,_HardADTRepr} <- ModADTs]), + NewModExpTypes = sets:union(ModExpTypes, ModADTsSet), + NewModTypes = lists:foldl(fun store_hard_adt/2, ModTypes, ModADTs), + NewModOpaques = sets:union(ModOpaques, ModADTsSet), + ModInfo#mod_info{mod_exp_types = NewModExpTypes, + mod_types = NewModTypes, + mod_opaques = NewModOpaques}; + error -> + ModInfo + end. + +-spec store_hard_adt({imm_type_ref(),hard_adt_repr()}, mod_types()) -> + mod_types(). +store_hard_adt({_ImmTypeRef,already_declared}, ModTypes) -> + ModTypes; +store_hard_adt({{Name,Arity},{TypeForm,VarNames}}, ModTypes) -> + TypeRef = {type,Name,Arity}, + TypeRepr = {abs_type,TypeForm,VarNames,not_symb}, + dict:store(TypeRef, TypeRepr, ModTypes). + +-spec add_mod_info(abs_form(), mod_info()) -> mod_info(). +add_mod_info({attribute,_Line,export_type,TypesList}, + #mod_info{mod_exp_types = ModExpTypes} = ModInfo) -> + NewModExpTypes = sets:union(sets:from_list(TypesList), ModExpTypes), + ModInfo#mod_info{mod_exp_types = NewModExpTypes}; +add_mod_info({attribute,_Line,type,{{record,RecName},Fields,[]}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + FieldInfo = [process_rec_field(F) || F <- Fields], + NewModTypes = dict:store({record,RecName,0}, {abs_record,FieldInfo}, + ModTypes), + ModInfo#mod_info{mod_types = NewModTypes}; +add_mod_info({attribute,Line,record,{RecName,Fields}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + case dict:is_key(RecName, ModTypes) of + true -> + ModInfo; + false -> % fake an opaque term by using the same Line as annotation + TypedRecord = {attribute,Line,type,{{record,RecName},Fields,[]}}, + add_mod_info(TypedRecord, ModInfo) + end; +add_mod_info({attribute,_Line,Kind,{Name,TypeForm,VarForms}}, + #mod_info{mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo) + when Kind =:= type; Kind =:= opaque -> + Arity = length(VarForms), + VarNames = [V || {var,_,V} <- VarForms], + %% TODO: No check whether variables are different, or non-'_'. + NewModTypes = dict:store({type,Name,Arity}, + {abs_type,TypeForm,VarNames,not_symb}, ModTypes), + NewModOpaques = + case Kind of + type -> ModOpaques; + opaque -> sets:add_element({Name,Arity}, ModOpaques) + end, + ModInfo#mod_info{mod_types = NewModTypes, mod_opaques = NewModOpaques}; +add_mod_info({attribute,_Line,spec,{RawFunRef,[RawFirstClause | _Rest]}}, + #mod_info{mod_specs = ModSpecs} = ModInfo) -> + FunRef = case RawFunRef of + {_Mod,Name,Arity} -> {Name,Arity}; + {_Name,_Arity} = F -> F + end, + %% TODO: We just take the first function clause. + FirstClause = process_fun_clause(RawFirstClause), + NewModSpecs = dict:store(FunRef, FirstClause, ModSpecs), + ModInfo#mod_info{mod_specs = NewModSpecs}; +add_mod_info(_Form, ModInfo) -> + ModInfo. + +-spec process_rec_field(abs_rec_field()) -> {field_name(),abs_type()}. +process_rec_field({record_field,_,{atom,_,FieldName}}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({record_field,_,{atom,_,FieldName},_Initialization}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({typed_record_field,RecField,FieldType}) -> + {FieldName,_} = process_rec_field(RecField), + {FieldName, FieldType}. + +-spec process_fun_clause(abs_type()) -> fun_clause_repr(). +process_fun_clause({type,_,'fun',[{type,_,product,Domain},Range]}) -> + {Domain, Range}; +process_fun_clause({type,_,bounded_fun,[MainClause,Constraints]}) -> + {RawDomain,RawRange} = process_fun_clause(MainClause), + VarSubsts = [{V,T} || {type,_,constraint, + [{atom,_,is_subtype},[{var,_,V},T]]} <- Constraints, + V =/= '_'], + VarSubstsDict = dict:from_list(VarSubsts), + Domain = [update_vars(A, VarSubstsDict, false) || A <- RawDomain], + Range = update_vars(RawRange, VarSubstsDict, false), + {Domain, Range}. + +-spec store_mod_info(mod_name(), mod_info(), state()) -> state(). +store_mod_info(Mod, #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_specs = ImmModExpSpecs}, + #state{exp_types = ExpTypes, types = Types, + exp_specs = ExpSpecs} = State) -> + NewExpTypes = dict:store(Mod, ModExpTypes, ExpTypes), + NewTypes = dict:store(Mod, ModTypes, Types), + ModExpSpecs = dict:map(fun unbound_to_any/2, ImmModExpSpecs), + NewExpSpecs = dict:store(Mod, ModExpSpecs, ExpSpecs), + State#state{exp_types = NewExpTypes, types = NewTypes, + exp_specs = NewExpSpecs}. + +-spec unbound_to_any(fun_ref(), fun_repr()) -> fun_repr(). +unbound_to_any(_FunRef, {Domain,Range}) -> + EmptySubstsDict = dict:new(), + NewDomain = [update_vars(A,EmptySubstsDict,true) || A <- Domain], + NewRange = update_vars(Range, EmptySubstsDict, true), + {NewDomain, NewRange}. + + +%%------------------------------------------------------------------------------ +%% ADT translation functions +%%------------------------------------------------------------------------------ + +-spec process_adts(mod_name(), mod_info()) -> mod_info(). +process_adts(Mod, + #mod_info{mod_exp_types = ModExpTypes, mod_opaques = ModOpaques, + mod_specs = ModExpSpecs} = ModInfo) -> + %% TODO: No warning on unexported opaques. + case sets:to_list(sets:intersection(ModExpTypes,ModOpaques)) of + [] -> + ModInfo; + ModADTs -> + %% TODO: No warning on unexported API functions. + ModExpSpecsList = [{Name,Domain,Range} + || {{Name,_Arity},{Domain,Range}} + <- dict:to_list(ModExpSpecs)], + AddADT = fun(ADT,Acc) -> add_adt(Mod,ADT,Acc,ModExpSpecsList) end, + lists:foldl(AddADT, ModInfo, ModADTs) + end. + +-spec add_adt(mod_name(), imm_type_ref(), mod_info(), [proc_fun_ref()]) -> + mod_info(). +add_adt(Mod, {Name,Arity}, #mod_info{mod_types = ModTypes} = ModInfo, + ModExpFunSpecs) -> + ADTRef = {type,Name,Arity}, + {abs_type,InternalRepr,VarNames,not_symb} = dict:fetch(ADTRef, ModTypes), + FullADTRef = {Mod,Name,Arity}, + %% TODO: No warning on unsuitable range. + SymbCalls1 = [get_symb_call(FullADTRef,Spec) || Spec <- ModExpFunSpecs], + %% TODO: No warning on bad use of variables. + SymbCalls2 = [fix_vars(FullADTRef,Call,RangeVars,VarNames) + || {ok,Call,RangeVars} <- SymbCalls1], + case [Call || {ok,Call} <- SymbCalls2] of + [] -> + %% TODO: No warning on no acceptable spec. + ModInfo; + SymbCalls3 -> + NewADTRepr = {abs_type,{type,0,union,SymbCalls3},VarNames, + {orig_abs,InternalRepr}}, + NewModTypes = dict:store(ADTRef, NewADTRepr, ModTypes), + ModInfo#mod_info{mod_types = NewModTypes} + end. + +-spec get_symb_call(full_imm_type_ref(), proc_fun_ref()) -> + tagged_result2(abs_type(),[var_name()]). +get_symb_call({Mod,_TypeName,_Arity} = FullADTRef, {FunName,Domain,Range}) -> + A = ?anno(0), + BaseCall = {type,A,tuple,[{atom,A,'$call'},{atom,A,Mod},{atom,A,FunName}, + {type,A,'$fixed_list',Domain}]}, + unwrap_range(FullADTRef, BaseCall, Range, false). + +-spec unwrap_range(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_range(FullADTRef, Call, {paren_type,_,[Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {ann_type,_,[_Var,Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {type,_,list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,maybe_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, + {type,_,nonempty_maybe_improper_list,[Cont,_Term]}, TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(_FullADTRef, _Call, {type,_,tuple,any}, _TestRun) -> + error; +unwrap_range(FullADTRef, Call, {type,_,tuple,FieldForms}, TestRun) -> + Translates = fun(T) -> unwrap_range(FullADTRef,none,T,true) =/= error end, + case proper_arith:find_first(Translates, FieldForms) of + none -> + error; + {TargetPos,TargetElem} -> + Pattern = get_pattern(TargetPos, FieldForms), + case TestRun of + true -> + NewCall = + case Call of + none -> {match_with,Pattern}; + _ -> Call + end, + {ok, NewCall, []}; + false -> + AbsPattern = term_to_singleton_type(Pattern), + A = ?anno(0), + NewCall = + {type,A,tuple, + [{atom,A,'$call'},{atom,A,?MODULE},{atom,A,match}, + {type,A,'$fixed_list',[AbsPattern,Call]}]}, + unwrap_range(FullADTRef, NewCall, TargetElem, TestRun) + end + end; +unwrap_range(FullADTRef, Call, {type,_,union,Choices}, TestRun) -> + TestedChoices = [unwrap_range(FullADTRef,none,C,true) || C <- Choices], + NotError = fun(error) -> false; (_) -> true end, + case proper_arith:find_first(NotError, TestedChoices) of + none -> + error; + {_ChoicePos,{ok,none,_RangeVars}} -> + error; + {ChoicePos,{ok,NextStep,_RangeVars}} -> + {A, [ChoiceElem|B]} = lists:split(ChoicePos-1, Choices), + OtherChoices = A ++ B, + DistinctChoice = + case NextStep of + take_head -> + fun cant_have_head/1; + {match_with,Pattern} -> + fun(C) -> cant_match(Pattern, C) end + end, + case {lists:all(DistinctChoice,OtherChoices), TestRun} of + {true,true} -> + {ok, NextStep, []}; + {true,false} -> + unwrap_range(FullADTRef, Call, ChoiceElem, TestRun); + {false,_} -> + error + end + end; +unwrap_range({_Mod,SameName,Arity}, Call, {type,_,SameName,ArgForms}, + _TestRun) -> + RangeVars = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(ArgForms) =:= Arity andalso length(RangeVars) =:= Arity of + true -> {ok, Call, RangeVars}; + false -> error + end; +unwrap_range({SameMod,SameName,_Arity} = FullADTRef, Call, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + TestRun) -> + unwrap_range(FullADTRef, Call, {type,?anno(0),SameName,ArgForms}, TestRun); +unwrap_range(_FullADTRef, _Call, _Range, _TestRun) -> + error. + +-spec unwrap_list(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_list(FullADTRef, Call, HeadType, TestRun) -> + NewCall = + case TestRun of + true -> + case Call of + none -> take_head; + _ -> Call + end; + false -> + {type,0,tuple,[{atom,0,'$call'},{atom,0,erlang},{atom,0,hd}, + {type,0,'$fixed_list',[Call]}]} + end, + unwrap_range(FullADTRef, NewCall, HeadType, TestRun). + +-spec fix_vars(full_imm_type_ref(), abs_type(), [var_name()], [var_name()]) -> + tagged_result(abs_type()). +fix_vars(FullADTRef, Call, RangeVars, VarNames) -> + NotAnyVar = fun(V) -> V =/= '_' end, + case no_duplicates(VarNames) andalso lists:all(NotAnyVar,VarNames) of + true -> + RawUsedVars = + collect_vars(FullADTRef, Call, [[V] || V <- RangeVars]), + UsedVars = [lists:usort(L) || L <- RawUsedVars], + case correct_var_use(UsedVars) of + true -> + PairAll = fun(L,Y) -> [{X,{var,0,Y}} || X <- L] end, + VarSubsts = + lists:flatten(lists:zipwith(PairAll,UsedVars,VarNames)), + VarSubstsDict = dict:from_list(VarSubsts), + {ok, update_vars(Call,VarSubstsDict,true)}; + false -> + error + end; + false -> + error + end. + +-spec no_duplicates(list()) -> boolean(). +no_duplicates(L) -> + length(lists:usort(L)) =:= length(L). + +-spec correct_var_use([[var_name() | 0]]) -> boolean(). +correct_var_use(UsedVars) -> + NoNonVarArgs = fun([0|_]) -> false; (_) -> true end, + lists:all(NoNonVarArgs, UsedVars) + andalso no_duplicates(lists:flatten(UsedVars)). + +-spec collect_vars(full_imm_type_ref(), abs_type(), [[var_name() | 0]]) -> + [[var_name() | 0]]. +collect_vars(FullADTRef, {paren_type,_,[Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(FullADTRef, {ann_type,_,[_Var,Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(_FullADTRef, {type,_,tuple,any}, UsedVars) -> + UsedVars; +collect_vars({_Mod,SameName,Arity} = FullADTRef, {type,_,SameName,ArgForms}, + UsedVars) -> + case length(ArgForms) =:= Arity of + true -> + VarArgs = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(VarArgs) =:= Arity of + true -> + AddToList = fun(X,L) -> [X | L] end, + lists:zipwith(AddToList, VarArgs, UsedVars); + false -> + [[0|L] || L <- UsedVars] + end; + false -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars) + end; +collect_vars(FullADTRef, {type,_,_Name,ArgForms}, UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars({SameMod,SameName,_Arity} = FullADTRef, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + UsedVars) -> + collect_vars(FullADTRef, {type,?anno(0),SameName,ArgForms}, UsedVars); +collect_vars(FullADTRef, {remote_type,_,[_RemModForm,_NameForm,ArgForms]}, + UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars(_FullADTRef, _Call, UsedVars) -> + UsedVars. + +-spec multi_collect_vars(full_imm_type_ref(), [abs_type()], + [[var_name() | 0]]) -> [[var_name() | 0]]. +multi_collect_vars({_Mod,_Name,Arity} = FullADTRef, Forms, UsedVars) -> + NoUsedVars = lists:duplicate(Arity, []), + MoreUsedVars = [collect_vars(FullADTRef,T,NoUsedVars) || T <- Forms], + CombineVars = fun(L1,L2) -> lists:zipwith(fun erlang:'++'/2, L1, L2) end, + lists:foldl(CombineVars, UsedVars, MoreUsedVars). + +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_substs_dict() :: dict(). +-else. +-type var_substs_dict() :: dict:dict(var_name(),abs_type()). +-endif. +-spec update_vars(abs_type(), var_substs_dict(), boolean()) -> abs_type(). +update_vars({paren_type,Line,[Type]}, VarSubstsDict, UnboundToAny) -> + {paren_type, Line, [update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({ann_type,Line,[Var,Type]}, VarSubstsDict, UnboundToAny) -> + {ann_type, Line, [Var,update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({var,Line,VarName} = Call, VarSubstsDict, UnboundToAny) -> + case dict:find(VarName, VarSubstsDict) of + {ok,SubstType} -> + SubstType; + error when UnboundToAny =:= false -> + Call; + error when UnboundToAny =:= true -> + {type,Line,any,[]} + end; +update_vars({remote_type,Line,[RemModForm,NameForm,ArgForms]}, VarSubstsDict, + UnboundToAny) -> + NewArgForms = [update_vars(A,VarSubstsDict,UnboundToAny) || A <- ArgForms], + {remote_type, Line, [RemModForm,NameForm,NewArgForms]}; +update_vars({T,_,tuple,any} = Call, _VarSubstsDict, _UnboundToAny) when ?IS_TYPE_TAG(T) -> + Call; +update_vars({T,Line,Name,ArgForms}, VarSubstsDict, UnboundToAny) when ?IS_TYPE_TAG(T) -> + NewArgForms = [update_vars(A,VarSubstsDict,UnboundToAny) || A <- ArgForms], + {T, Line, Name, NewArgForms}; +update_vars(Call, _VarSubstsDict, _UnboundToAny) -> + Call. + + +%%------------------------------------------------------------------------------ +%% Match-related functions +%%------------------------------------------------------------------------------ + +-spec get_pattern(position(), [abs_type()]) -> pattern(). +get_pattern(TargetPos, FieldForms) -> + {0,RevPattern} = lists:foldl(fun add_field/2, {TargetPos,[]}, FieldForms), + list_to_tuple(lists:reverse(RevPattern)). + +-spec add_field(abs_type(), {non_neg_integer(),[pat_field()]}) -> + {non_neg_integer(),[pat_field(),...]}. +add_field(_Type, {1,Acc}) -> + {0, [1|Acc]}; +add_field({atom,_,Tag}, {Left,Acc}) -> + {erlang:max(0,Left-1), [Tag|Acc]}; +add_field(_Type, {Left,Acc}) -> + {erlang:max(0,Left-1), [0|Acc]}. + +%% @private +-spec match(pattern(), tuple()) -> term(). +match(Pattern, Term) when tuple_size(Pattern) =:= tuple_size(Term) -> + match(tuple_to_list(Pattern), tuple_to_list(Term), none, false); +match(_Pattern, _Term) -> + throw(no_match). + +-spec match([pat_field()], [term()], 'none' | {'ok',T}, boolean()) -> T. +match([], [], {ok,Target}, _TypeMode) -> + Target; +match([0|PatRest], [_|ToMatchRest], Acc, TypeMode) -> + match(PatRest, ToMatchRest, Acc, TypeMode); +match([1|PatRest], [Target|ToMatchRest], none, TypeMode) -> + match(PatRest, ToMatchRest, {ok,Target}, TypeMode); +match([Tag|PatRest], [X|ToMatchRest], Acc, TypeMode) when is_atom(Tag) -> + MatchesTag = + case TypeMode of + true -> can_be_tag(Tag, X); + false -> Tag =:= X + end, + case MatchesTag of + true -> match(PatRest, ToMatchRest, Acc, TypeMode); + false -> throw(no_match) + end. + +%% CAUTION: these must be sorted +-define(NON_ATOM_TYPES, + [arity,binary,bitstring,byte,char,float,'fun',function,integer,iodata, + iolist,list,maybe_improper_list,mfa,neg_integer,nil,no_return, + non_neg_integer,none,nonempty_improper_list,nonempty_list, + nonempty_maybe_improper_list,nonempty_string,number,pid,port, + pos_integer,range,record,reference,string,tuple]). +-define(NON_TUPLE_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,iodata,iolist,list,maybe_improper_list, + neg_integer,nil,no_return,node,non_neg_integer,none, + nonempty_improper_list,nonempty_list,nonempty_maybe_improper_list, + nonempty_string,number,pid,port,pos_integer,range,reference,string, + timeout]). +-define(NO_HEAD_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,mfa,module,neg_integer,nil,no_return,node, + non_neg_integer,none,number,pid,port,pos_integer,range,record, + reference,timeout,tuple]). + +-spec can_be_tag(atom(), abs_type()) -> boolean(). +can_be_tag(Tag, {ann_type,_,[_Var,Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {paren_type,_,[Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {atom,_,Atom}) -> + Tag =:= Atom; +can_be_tag(_Tag, {integer,_,_Int}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg1,_Arg2}) -> + false; +can_be_tag(Tag, {type,_,BName,[]}) when BName =:= bool; BName =:= boolean -> + is_boolean(Tag); +can_be_tag(Tag, {type,_,timeout,[]}) -> + Tag =:= infinity; +can_be_tag(Tag, {type,_,union,Choices}) -> + lists:any(fun(C) -> can_be_tag(Tag,C) end, Choices); +can_be_tag(_Tag, {type,_,Name,_Args}) -> + not ordsets:is_element(Name, ?NON_ATOM_TYPES); +can_be_tag(_Tag, _Type) -> + true. + +-spec cant_match(pattern(), abs_type()) -> boolean(). +cant_match(Pattern, {ann_type,_,[_Var,Type]}) -> + cant_match(Pattern, Type); +cant_match(Pattern, {paren_type,_,[Type]}) -> + cant_match(Pattern, Type); +cant_match(_Pattern, {atom,_,_Atom}) -> + true; +cant_match(_Pattern, {integer,_,_Int}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_match(Pattern, {type,Anno,mfa,[]}) -> + MFA_Ts = [{type,Anno,atom,[]}, {type,Anno,atom,[]}, {type,Anno,arity,[]}], + cant_match(Pattern, {type,Anno,tuple,MFA_Ts}); +cant_match(Pattern, {type,_,union,Choices}) -> + lists:all(fun(C) -> cant_match(Pattern,C) end, Choices); +cant_match(_Pattern, {type,_,tuple,any}) -> + false; +cant_match(Pattern, {type,_,tuple,Fields}) -> + tuple_size(Pattern) =/= length(Fields) orelse + try match(tuple_to_list(Pattern), Fields, none, true) of + _ -> false + catch + throw:no_match -> true + end; +cant_match(_Pattern, {type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NON_TUPLE_TYPES); +cant_match(_Pattern, _Type) -> + false. + +-spec cant_have_head(abs_type()) -> boolean(). +cant_have_head({ann_type,_,[_Var,Type]}) -> + cant_have_head(Type); +cant_have_head({paren_type,_,[Type]}) -> + cant_have_head(Type); +cant_have_head({atom,_,_Atom}) -> + true; +cant_have_head({integer,_,_Int}) -> + true; +cant_have_head({op,_,_Op,_Arg}) -> + true; +cant_have_head({op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_have_head({type,_,union,Choices}) -> + lists:all(fun cant_have_head/1, Choices); +cant_have_head({type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NO_HEAD_TYPES); +cant_have_head(_Type) -> + false. + +%% Only covers atoms, integers and tuples, i.e. those that can be specified +%% through singleton types. +-spec term_to_singleton_type(atom() | integer() + | loose_tuple(atom() | integer())) -> abs_type(). +term_to_singleton_type(Atom) when is_atom(Atom) -> + {atom,?anno(0),Atom}; +term_to_singleton_type(Int) when is_integer(Int), Int >= 0 -> + {integer,?anno(0),Int}; +term_to_singleton_type(Int) when is_integer(Int), Int < 0 -> + A = ?anno(0), + {op,A,'-',{integer,A,-Int}}; +term_to_singleton_type(Tuple) when is_tuple(Tuple) -> + Fields = tuple_to_list(Tuple), + {type,?anno(0),tuple,[term_to_singleton_type(F) || F <- Fields]}. + + +%%------------------------------------------------------------------------------ +%% Instance testing functions +%%------------------------------------------------------------------------------ + +%% CAUTION: this must be sorted +-define(EQUIV_TYPES, + [{arity, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {bool, {type,0,boolean,[]}}, + {byte, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {char, {type,0,range,[{integer,0,0},{integer,0,16#10ffff}]}}, + {function, {type,0,'fun',[]}}, + {identifier, {type,0,union,[{type,0,pid,[]},{type,0,port,[]}, + {type,0,reference,[]}]}}, + {iodata, {type,0,union,[{type,0,binary,[]},{type,0,iolist,[]}]}}, + {iolist, {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}}, + {list, {type,0,list,[{type,0,any,[]}]}}, + {maybe_improper_list, {type,0,maybe_improper_list,[{type,0,any,[]}, + {type,0,any,[]}]}}, + {mfa, {type,0,tuple,[{type,0,atom,[]},{type,0,atom,[]}, + {type,0,arity,[]}]}}, + {node, {type,0,atom,[]}}, + {nonempty_list, {type,0,nonempty_list,[{type,0,any,[]}]}}, + {nonempty_maybe_improper_list, {type,0,nonempty_maybe_improper_list, + [{type,0,any,[]},{type,0,any,[]}]}}, + {nonempty_string, {type,0,nonempty_list,[{type,0,char,[]}]}}, + {string, {type,0,list,[{type,0,char,[]}]}}, + {term, {type,0,any,[]}}, + {timeout, {type,0,union,[{atom,0,infinity}, + {type,0,non_neg_integer,[]}]}}]). + +%% @private +%% TODO: Most of these functions accept an extended form of abs_type(), namely +%% the addition of a custom wrapper: {'from_mod',mod_name(),...} +-spec is_instance(term(), mod_name(), abs_type()) -> boolean(). +is_instance(X, Mod, TypeForm) -> + is_instance(X, Mod, TypeForm, []). + +-spec is_instance(term(), mod_name(), abs_type(), imm_stack()) -> boolean(). +is_instance(X, _Mod, {from_mod,OrigMod,Type}, Stack) -> + is_instance(X, OrigMod, Type, Stack); +is_instance(_X, _Mod, {var,_,'_'}, _Stack) -> + true; +is_instance(_X, _Mod, {var,_,Name}, _Stack) -> + %% All unconstrained spec vars have been replaced by 'any()' and we always + %% replace the variables on the RHS of types before recursing into them. + %% Provided that '-type' declarations contain no unbound variables, we + %% don't expect to find any non-'_' variables while recursing. + throw({'$typeserver',{unbound_var_in_type_declaration,Name}}); +is_instance(X, Mod, {ann_type,_,[_Var,Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {paren_type,_,[Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, + Stack) -> + is_custom_instance(X, Mod, RemMod, Name, ArgForms, true, Stack); +is_instance(SameAtom, _Mod, {atom,_,SameAtom}, _Stack) -> + true; +is_instance(SameInt, _Mod, {integer,_,SameInt}, _Stack) -> + true; +is_instance(X, _Mod, {op,_,_Op,_Arg} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(X, _Mod, {op,_,_Op,_Arg1,_Arg2} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(_X, _Mod, {type,_,any,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,atom,[]}, _Stack) -> + is_atom(X); +is_instance(X, _Mod, {type,_,binary,[]}, _Stack) -> + is_binary(X); +is_instance(X, _Mod, {type,_,binary,[BaseExpr,UnitExpr]}, _Stack) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,Base} when Base >= 0 -> + case eval_int(UnitExpr) of + {ok,Unit} when Unit >= 0 -> + case is_bitstring(X) of + true -> + BitSizeX = bit_size(X), + case Unit =:= 0 of + true -> + BitSizeX =:= Base; + false -> + BitSizeX >= Base + andalso + (BitSizeX - Base) rem Unit =:= 0 + end; + false -> false + end; + _ -> + abs_expr_error(invalid_unit, UnitExpr) + end; + _ -> + abs_expr_error(invalid_base, BaseExpr) + end; +is_instance(X, _Mod, {type,_,bitstring,[]}, _Stack) -> + is_bitstring(X); +is_instance(X, _Mod, {type,_,boolean,[]}, _Stack) -> + is_boolean(X); +is_instance(X, _Mod, {type,_,float,[]}, _Stack) -> + is_float(X); +is_instance(X, _Mod, {type,_,'fun',[]}, _Stack) -> + is_function(X); +%% TODO: how to check range type? random inputs? special case for 0-arity? +is_instance(X, _Mod, {type,_,'fun',[{type,_,any,[]},_Range]}, _Stack) -> + is_function(X); +is_instance(X, _Mod, {type,_,'fun',[{type,_,product,Domain},_Range]}, _Stack) -> + is_function(X, length(Domain)); +is_instance(X, _Mod, {type,_,integer,[]}, _Stack) -> + is_integer(X); +is_instance(X, Mod, {type,_,list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, true, true, false); +is_instance(X, Mod, {type,_,maybe_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, true, true, true); +is_instance(X, _Mod, {type,_,module,[]}, _Stack) -> + is_atom(X) orelse + is_tuple(X) andalso X =/= {} andalso is_atom(element(1,X)); +is_instance([], _Mod, {type,_,nil,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,neg_integer,[]}, _Stack) -> + is_integer(X) andalso X < 0; +is_instance(X, _Mod, {type,_,non_neg_integer,[]}, _Stack) -> + is_integer(X) andalso X >= 0; +is_instance(X, Mod, {type,_,nonempty_list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, false, true, false); +is_instance(X, Mod, {type,_,nonempty_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, false, false, true); +is_instance(X, Mod, {type,_,nonempty_maybe_improper_list,[Cont,Term]}, + _Stack) -> + list_test(X, Mod, Cont, Term, false, true, true); +is_instance(X, _Mod, {type,_,number,[]}, _Stack) -> + is_number(X); +is_instance(X, _Mod, {type,_,pid,[]}, _Stack) -> + is_pid(X); +is_instance(X, _Mod, {type,_,port,[]}, _Stack) -> + is_port(X); +is_instance(X, _Mod, {type,_,pos_integer,[]}, _Stack) -> + is_integer(X) andalso X > 0; +is_instance(_X, _Mod, {type,_,product,_Elements}, _Stack) -> + throw({'$typeserver',{internal,product_in_is_instance}}); +is_instance(X, _Mod, {type,_,range,[LowExpr,HighExpr]}, _Stack) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + X >= Low andalso X =< High; + _ -> + abs_expr_error(invalid_range, LowExpr, HighExpr) + end; +is_instance(X, Mod, {type,_,record,[{atom,_,Name} = NameForm | RawSubsts]}, + Stack) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + SubstsDict = dict:from_list(Substs), + case get_type_repr(Mod, {record,Name,0}, false) of + {ok,{abs_record,OrigFields}} -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + is_instance(X, Mod, {type,?anno(0),tuple,[NameForm|Fields]}, Stack); + {error,Reason} -> + throw({'$typeserver',Reason}) + end; +is_instance(X, _Mod, {type,_,reference,[]}, _Stack) -> + is_reference(X); +is_instance(X, _Mod, {type,_,tuple,any}, _Stack) -> + is_tuple(X); +is_instance(X, Mod, {type,_,tuple,Fields}, _Stack) -> + is_tuple(X) andalso tuple_test(tuple_to_list(X), Mod, Fields); +is_instance(X, Mod, {type,_,union,Choices}, Stack) -> + IsInstance = fun(Choice) -> is_instance(X,Mod,Choice,Stack) end, + lists:any(IsInstance, Choices); +is_instance(X, Mod, {T,_,Name,[]}, Stack) when ?IS_TYPE_TAG(T) -> + case orddict:find(Name, ?EQUIV_TYPES) of + {ok,EquivType} -> + is_instance(X, Mod, EquivType, Stack); + error -> + is_maybe_hard_adt(X, Mod, Name, [], Stack) + end; +is_instance(X, Mod, {T,_,Name,ArgForms}, Stack) when ?IS_TYPE_TAG(T) -> + is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack); +is_instance(_X, _Mod, _Type, _Stack) -> + false. + +-spec is_int_const(term(), abs_expr()) -> boolean(). +is_int_const(X, Expr) -> + case eval_int(Expr) of + {ok,Int} -> + X =:= Int; + error -> + abs_expr_error(invalid_int_const, Expr) + end. + +%% TODO: We implicitly add the '| []' at the termination of maybe_improper_list. +%% TODO: We ignore a '[]' termination in improper_list. +-spec list_test(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_test(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper) -> + is_list(X) andalso + list_rec(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper). + +-spec list_rec(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_rec([], _Mod, _Content, _Termination, CanEmpty, CanProper, _CanImproper) -> + CanEmpty andalso CanProper; +list_rec([X | Rest], Mod, Content, Termination, _CanEmpty, CanProper, + CanImproper) -> + is_instance(X, Mod, Content, []) andalso + list_rec(Rest, Mod, Content, Termination, true, CanProper, CanImproper); +list_rec(X, Mod, _Content, Termination, _CanEmpty, _CanProper, CanImproper) -> + CanImproper andalso is_instance(X, Mod, Termination, []). + +-spec tuple_test([term()], mod_name(), [abs_type()]) -> boolean(). +tuple_test([], _Mod, []) -> + true; +tuple_test([X | XTail], Mod, [T | TTail]) -> + is_instance(X, Mod, T, []) andalso tuple_test(XTail, Mod, TTail); +tuple_test(_, _Mod, _) -> + false. + +-spec is_maybe_hard_adt(term(), mod_name(), type_name(), [abs_type()], + imm_stack()) -> boolean(). +is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack) -> + case orddict:find({Name,length(ArgForms)}, ?HARD_ADTS) of + {ok,ADTMod} -> + is_custom_instance(X, Mod, ADTMod, Name, ArgForms, true, Stack); + error -> + is_custom_instance(X, Mod, Mod, Name, ArgForms, false, Stack) + end. + +-spec is_custom_instance(term(), mod_name(), mod_name(), type_name(), + [abs_type()], boolean(), imm_stack()) -> boolean(). +is_custom_instance(X, Mod, RemMod, Name, RawArgForms, IsRemote, Stack) -> + ArgForms = case Mod =/= RemMod of + true -> [{from_mod,Mod,A} || A <- RawArgForms]; + false -> RawArgForms + end, + Arity = length(ArgForms), + FullTypeRef = {RemMod,Name,Arity}, + case lists:member(FullTypeRef, Stack) of + true -> + throw({'$typeserver',{self_reference,FullTypeRef}}); + false -> + TypeRef = {type,Name,Arity}, + AbsType = get_abs_type(RemMod, TypeRef, ArgForms, IsRemote), + is_instance(X, RemMod, AbsType, [FullTypeRef|Stack]) + end. + +-spec get_abs_type(mod_name(), type_ref(), [abs_type()], boolean()) -> + abs_type(). +get_abs_type(RemMod, TypeRef, ArgForms, IsRemote) -> + case get_type_repr(RemMod, TypeRef, IsRemote) of + {ok,TypeRepr} -> + {FinalAbsType,SymbInfo,VarNames} = + case TypeRepr of + {cached,_FinType,FAT,SI} -> {FAT,SI,[]}; + {abs_type,FAT,VN,SI} -> {FAT,SI,VN} + end, + AbsType = + case SymbInfo of + not_symb -> FinalAbsType; + {orig_abs,OrigAbsType} -> OrigAbsType + end, + VarSubstsDict = dict:from_list(lists:zip(VarNames,ArgForms)), + update_vars(AbsType, VarSubstsDict, false); + {error,Reason} -> + throw({'$typeserver',Reason}) + end. + +-spec abs_expr_error(atom(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr) -> + {error,Reason} = expr_error(ImmReason, Expr), + throw({'$typeserver',Reason}). + +-spec abs_expr_error(atom(), abs_expr(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr1, Expr2) -> + {error,Reason} = expr_error(ImmReason, Expr1, Expr2), + throw({'$typeserver',Reason}). + + +%%------------------------------------------------------------------------------ +%% Type translation functions +%%------------------------------------------------------------------------------ + +-spec convert(mod_name(), abs_type(), state()) -> + rich_result2(fin_type(),state()). +convert(Mod, TypeForm, State) -> + case convert(Mod, TypeForm, State, [], dict:new()) of + {ok,{simple,Type},NewState} -> + {ok, Type, NewState}; + {ok,{rec,_RecFun,_RecArgs},_NewState} -> + {error, {internal,rec_returned_to_toplevel}}; + {error,_Reason} = Error -> + Error + end. + +-spec convert(mod_name(), abs_type(), state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert(Mod, {paren_type,_,[Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(Mod, {ann_type,_,[_Var,Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(_Mod, {var,_,'_'}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:any()}, State}; +convert(_Mod, {var,_,VarName}, State, _Stack, VarDict) -> + case dict:find(VarName, VarDict) of + %% TODO: do we need to check if we are at toplevel of a recursive? + {ok,RetType} -> {ok, RetType, State}; + error -> {error, {unbound_var,VarName}} + end; +convert(Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, State, + Stack, VarDict) -> + case prepare_for_remote(RemMod, Name, length(ArgForms), State) of + {ok,NewState} -> + convert_custom(Mod,RemMod,Name,ArgForms,NewState,Stack,VarDict); + {error,_Reason} = Error -> + Error + end; +convert(_Mod, {atom,_,Atom}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly(Atom)}, State}; +convert(_Mod, {integer,_,_Int} = IntExpr, State, _Stack, _VarDict) -> + convert_integer(IntExpr, State); +convert(_Mod, {op,_,_Op,_Arg} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {op,_,_Op,_Arg1,_Arg2} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {type,_,binary,[BaseExpr,UnitExpr]}, State, _Stack, _VarDict) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,0} -> + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,proper_types:exactly(<<>>)}, State}; + {ok,1} -> {ok, {simple,proper_types:bitstring()}, State}; + {ok,8} -> {ok, {simple,proper_types:binary()}, State}; + {ok,N} when N > 0 -> + Gen = ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,Gen}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + {ok,Base} when Base > 0 -> + Head = proper_types:bitstring(Base), + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,Head}, State}; + {ok,1} -> + Tail = proper_types:bitstring(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,8} -> + Tail = proper_types:binary(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,N} when N > 0 -> + Tail = + ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + _ -> + expr_error(invalid_base, BaseExpr) + end; +convert(_Mod, {type,_,range,[LowExpr,HighExpr]}, State, _Stack, _VarDict) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + {ok, {simple,proper_types:integer(Low,High)}, State}; + _ -> + expr_error(invalid_range, LowExpr, HighExpr) + end; +convert(_Mod, {type,_,nil,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly([])}, State}; +convert(Mod, {type,_,list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, false, ElemForm, State, Stack, VarDict); +convert(Mod, {type,_,nonempty_list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, true, ElemForm, State, Stack, VarDict); +convert(_Mod, {type,_,nonempty_list,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:list())}, State}; +convert(_Mod, {type,_,nonempty_string,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:string())}, State}; +convert(_Mod, {type,_,tuple,any}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:tuple()}, State}; +convert(Mod, {type,_,tuple,ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, false, State, Stack, VarDict); +convert(Mod, {type,_,'$fixed_list',ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, true, State, Stack, VarDict); +convert(Mod, {type,_,record,[{atom,_,Name}|FieldForms]}, State, Stack, + VarDict) -> + convert_record(Mod, Name, FieldForms, State, Stack, VarDict); +convert(Mod, {type,_,union,ChoiceForms}, State, Stack, VarDict) -> + convert_union(Mod, ChoiceForms, State, Stack, VarDict); +convert(Mod, {type,_,'fun',[{type,_,product,Domain},Range]}, State, Stack, + VarDict) -> + convert_fun(Mod, length(Domain), Range, State, Stack, VarDict); +%% TODO: These types should be replaced with accurate types. +%% TODO: Add support for nonempty_improper_list/2. +convert(Mod, {type,Anno,maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,Anno,list,[]}, State, Stack, VarDict); +convert(Mod, {type,A,maybe_improper_list,[Cont,_Ter]}, State, Stack, VarDict) -> + convert(Mod, {type,A,list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,A,nonempty_maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,A,nonempty_list,[]}, State, Stack, VarDict); +convert(Mod, {type,A,nonempty_maybe_improper_list,[Cont,_Term]}, State, Stack, + VarDict) -> + convert(Mod, {type,A,nonempty_list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,A,iodata,[]}, State, Stack, VarDict) -> + RealType = {type,A,union,[{type,A,binary,[]},{type,A,iolist,[]}]}, + convert(Mod, RealType, State, Stack, VarDict); +convert(Mod, {T,_,Name,[]}, State, Stack, VarDict) when ?IS_TYPE_TAG(T) -> + case ordsets:is_element(Name, ?STD_TYPES_0) of + true -> + {ok, {simple,proper_types:Name()}, State}; + false -> + convert_maybe_hard_adt(Mod, Name, [], State, Stack, VarDict) + end; +convert(Mod, {T,_,Name,ArgForms}, State, Stack, VarDict) when ?IS_TYPE_TAG(T) -> + convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict); +convert(_Mod, TypeForm, _State, _Stack, _VarDict) -> + {error, {unsupported_type,TypeForm}}. + +-spec concat_bitstrings([bitstring()]) -> bitstring(). +concat_bitstrings(BitStrings) -> + concat_bitstrings_tr(BitStrings, <<>>). + +-spec concat_bitstrings_tr([bitstring()], bitstring()) -> bitstring(). +concat_bitstrings_tr([], Acc) -> + Acc; +concat_bitstrings_tr([BitString | Rest], Acc) -> + concat_bitstrings_tr(Rest, <<Acc/bits,BitString/bits>>). + +-spec concat_binary_gens(fin_type(), fin_type()) -> fin_type(). +concat_binary_gens(HeadType, TailType) -> + ?LET({H,T}, {HeadType,TailType}, <<H/bits,T/bits>>). + +-spec convert_fun(mod_name(), arity(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_fun(Mod, Arity, Range, State, Stack, VarDict) -> + case convert(Mod, Range, State, ['fun' | Stack], VarDict) of + {ok,{simple,RangeType},NewState} -> + {ok, {simple,proper_types:function(Arity,RangeType)}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> convert_rec_fun(Arity, RecFun, RecArgs, NewState) + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_fun(arity(), rec_fun(), rec_args(), state()) -> + {'ok',ret_type(),state()}. +convert_rec_fun(Arity, RecFun, RecArgs, State) -> + %% We bind the generated value by size. + NewRecFun = + fun(GenFuns,Size) -> + proper_types:function(Arity, RecFun(GenFuns,Size)) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +-spec convert_list(mod_name(), boolean(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_list(Mod, NonEmpty, ElemForm, State, Stack, VarDict) -> + case convert(Mod, ElemForm, State, [list | Stack], VarDict) of + {ok,{simple,ElemType},NewState} -> + InnerType = proper_types:list(ElemType), + FinType = case NonEmpty of + true -> proper_types:non_empty(InnerType); + false -> InnerType + end, + {ok, {simple,FinType}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case {at_toplevel(RecArgs,Stack), NonEmpty} of + {true,true} -> + base_case_error(Stack); + {true,false} -> + NewRecFun = + fun(GenFuns,Size) -> + ElemGen = fun(S) -> ?LAZY(RecFun(GenFuns,S)) end, + proper_types:distlist(Size, ElemGen, false) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, NewState}; + {false,_} -> + {NewRecFun,NewRecArgs} = + convert_rec_list(RecFun, RecArgs, NonEmpty), + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_rec_list(RecFun, [{true,FullTypeRef}] = RecArgs, NonEmpty) -> + {NewRecFun,_NormalRecArgs} = + convert_normal_rec_list(RecFun, RecArgs, NonEmpty), + AltRecFun = + fun([InstListGen],Size) -> + InstTypesList = + proper_types:get_prop(internal_types, InstListGen(Size)), + proper_types:fixed_list([RecFun([fun(_Size) -> I end],0) + || I <- InstTypesList]) + end, + NewRecArgs = [{{list,NonEmpty,AltRecFun},FullTypeRef}], + {NewRecFun, NewRecArgs}; +convert_rec_list(RecFun, RecArgs, NonEmpty) -> + convert_normal_rec_list(RecFun, RecArgs, NonEmpty). + +-spec convert_normal_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_normal_rec_list(RecFun, RecArgs, NonEmpty) -> + NewRecFun = fun(GenFuns,Size) -> + ElemGen = fun(S) -> RecFun(GenFuns, S) end, + proper_types:distlist(Size, ElemGen, NonEmpty) + end, + NewRecArgs = clean_rec_args(RecArgs), + {NewRecFun, NewRecArgs}. + +-spec convert_tuple(mod_name(), [abs_type()], boolean(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_tuple(Mod, ElemForms, ToList, State, Stack, VarDict) -> + case process_list(Mod, ElemForms, State, [tuple | Stack], VarDict) of + {ok,RetTypes,NewState} -> + case combine_ret_types(RetTypes, {tuple,ToList}) of + {simple,_FinType} = RetType -> + {ok, RetType, NewState}; + {rec,_RecFun,RecArgs} = RetType -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> {ok, RetType, NewState} + end + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_union(mod_name(), [abs_type()], state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_union(Mod, ChoiceForms, State, Stack, VarDict) -> + case process_list(Mod, ChoiceForms, State, [union | Stack], VarDict) of + {ok,RawChoices,NewState} -> + ProcessChoice = fun(T,A) -> process_choice(T,A,Stack) end, + {RevSelfRecs,RevNonSelfRecs,RevNonRecs} = + lists:foldl(ProcessChoice, {[],[],[]}, RawChoices), + case {lists:reverse(RevSelfRecs),lists:reverse(RevNonSelfRecs), + lists:reverse(RevNonRecs)} of + {_SelfRecs,[],[]} -> + base_case_error(Stack); + {[],NonSelfRecs,NonRecs} -> + {ok, combine_ret_types(NonRecs ++ NonSelfRecs, union), + NewState}; + {SelfRecs,NonSelfRecs,NonRecs} -> + {BCaseRecFun,BCaseRecArgs} = + case combine_ret_types(NonRecs ++ NonSelfRecs, union) of + {simple,BCaseType} -> + {fun([],_Size) -> BCaseType end,[]}; + {rec,BCRecFun,BCRecArgs} -> + {BCRecFun,BCRecArgs} + end, + NumBCaseGens = length(BCaseRecArgs), + [ParentRef | _Upper] = Stack, + FallbackRecFun = fun([SelfGen],_Size) -> SelfGen(0) end, + FallbackRecArgs = [{false,ParentRef}], + FallbackRetType = {rec,FallbackRecFun,FallbackRecArgs}, + {rec,RCaseRecFun,RCaseRecArgs} = + combine_ret_types([FallbackRetType] ++ SelfRecs + ++ NonSelfRecs, wunion), + NewRecFun = + fun(AllGens,Size) -> + {BCaseGens,RCaseGens} = + lists:split(NumBCaseGens, AllGens), + case Size of + 0 -> BCaseRecFun(BCaseGens,0); + _ -> RCaseRecFun(RCaseGens,Size) + end + end, + NewRecArgs = BCaseRecArgs ++ RCaseRecArgs, + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec process_choice(ret_type(), {[ret_type()],[ret_type()],[ret_type()]}, + stack()) -> {[ret_type()],[ret_type()],[ret_type()]}. +process_choice({simple,_} = RetType, {SelfRecs,NonSelfRecs,NonRecs}, _Stack) -> + {SelfRecs, NonSelfRecs, [RetType | NonRecs]}; +process_choice({rec,RecFun,RecArgs}, {SelfRecs,NonSelfRecs,NonRecs}, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> + case partition_by_toplevel(RecArgs, Stack, true) of + {[],[],_,_} -> + NewRecArgs = clean_rec_args(RecArgs), + {[{rec,RecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs}; + {SelfRecArgs,SelfPos,OtherRecArgs,_OtherPos} -> + NumInstances = length(SelfRecArgs), + IsListInst = fun({true,_FTRef}) -> false + ; ({{list,_NE,_AltRecFun},_FTRef}) -> true + end, + NewRecFun = + case proper_arith:filter(IsListInst,SelfRecArgs) of + {[],[]} -> + no_list_inst_rec_fun(RecFun,NumInstances, + SelfPos); + {[{{list,NonEmpty,AltRecFun},_}],[ListInstPos]} -> + list_inst_rec_fun(AltRecFun,NumInstances, + SelfPos,NonEmpty,ListInstPos) + end, + [{_B,SelfRef} | _] = SelfRecArgs, + NewRecArgs = + [{false,SelfRef} | clean_rec_args(OtherRecArgs)], + {[{rec,NewRecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs} + end; + false -> + NewRecArgs = clean_rec_args(RecArgs), + {SelfRecs, [{rec,RecFun,NewRecArgs} | NonSelfRecs], NonRecs} + end. + +-spec no_list_inst_rec_fun(rec_fun(), pos_integer(), [position()]) -> rec_fun(). +no_list_inst_rec_fun(RecFun, NumInstances, SelfPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + Instances, + %% Size distribution will be a little off if both normal and + %% instance-accepting generators are present. + lists:duplicate(NumInstances, SelfGen(Size div NumInstances)), + begin + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + AllGens = proper_arith:insert(InstGens, SelfPos, OtherGens), + RecFun(AllGens, Size) + end) + end. + +-spec list_inst_rec_fun(rec_fun(), pos_integer(), [position()], boolean(), + position()) -> rec_fun(). +list_inst_rec_fun(AltRecFun, NumInstances, SelfPos, NonEmpty, ListInstPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + AllInsts, + lists:duplicate(NumInstances - 1, SelfGen(Size div NumInstances)) + ++ proper_types:distlist(Size div NumInstances, SelfGen, NonEmpty), + begin + {Instances,InstList} = lists:split(NumInstances - 1, AllInsts), + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + InstTypesList = [proper_types:exactly(I) || I <- InstList], + InstListGen = + fun(_Size) -> proper_types:fixed_list(InstTypesList) end, + AllInstGens = proper_arith:list_insert(ListInstPos, InstListGen, + InstGens), + AllGens = proper_arith:insert(AllInstGens, SelfPos, OtherGens), + AltRecFun(AllGens, Size) + end) + end. + +-spec convert_maybe_hard_adt(mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict) -> + Arity = length(ArgForms), + case orddict:find({Name,Arity}, ?HARD_ADTS) of + {ok,Mod} -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict); + {ok,ADTMod} -> + A = ?anno(0), + ADT = {remote_type,A,[{atom,A,ADTMod},{atom,A,Name},ArgForms]}, + convert(Mod, ADT, State, Stack, VarDict); + error -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict) + end. + +-spec convert_custom(mod_name(), mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> rich_result2(ret_type(),state()). +convert_custom(Mod, RemMod, Name, ArgForms, State, Stack, VarDict) -> + case process_list(Mod, ArgForms, State, Stack, VarDict) of + {ok,Args,NewState} -> + Arity = length(Args), + TypeRef = {type,Name,Arity}, + FullTypeRef = {RemMod,type,Name,Args}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_record(mod_name(), type_name(), [abs_type()], state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_record(Mod, Name, RawSubsts, State, Stack, VarDict) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + {SubstFields,SubstTypeForms} = lists:unzip(Substs), + case process_list(Mod, SubstTypeForms, State, Stack, VarDict) of + {ok,SubstTypes,NewState} -> + SubstsDict = dict:from_list(lists:zip(SubstFields, SubstTypes)), + TypeRef = {record,Name,0}, + FullTypeRef = {Mod,record,Name,SubstsDict}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_type(type_ref(), full_type_ref(), state(), stack()) -> + rich_result2(ret_type(),state()). +convert_type(TypeRef, {Mod,_Kind,_Name,_Spec} = FullTypeRef, State, Stack) -> + case stack_position(FullTypeRef, Stack) of + none -> + case get_type_repr(Mod, TypeRef, false, State) of + {ok,TypeRepr,NewState} -> + convert_new_type(TypeRef, FullTypeRef, TypeRepr, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; + 1 -> + base_case_error(Stack); + _Pos -> + {ok, {rec,fun([Gen],Size) -> Gen(Size) end,[{true,FullTypeRef}]}, + State} + end. + +-spec convert_new_type(type_ref(), full_type_ref(), type_repr(), state(), + stack()) -> rich_result2(ret_type(),state()). +convert_new_type(_TypeRef, {_Mod,type,_Name,[]}, + {cached,FinType,_TypeForm,_SymbInfo}, State, _Stack) -> + {ok, {simple,FinType}, State}; +convert_new_type(TypeRef, {Mod,type,_Name,Args} = FullTypeRef, + {abs_type,TypeForm,Vars,SymbInfo}, State, Stack) -> + VarDict = dict:from_list(lists:zip(Vars, Args)), + case convert(Mod, TypeForm, State, [FullTypeRef | Stack], VarDict) of + {ok, {simple,ImmFinType}, NewState} -> + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + FinalState = case Vars of + [] -> cache_type(Mod, TypeRef, FinType, TypeForm, + SymbInfo, NewState); + _ -> NewState + end, + {ok, {simple,FinType}, FinalState}; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; +convert_new_type(_TypeRef, {Mod,record,Name,SubstsDict} = FullTypeRef, + {abs_record,OrigFields}, State, Stack) -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + case convert_tuple(Mod, [{atom,0,Name} | Fields], false, State, + [FullTypeRef | Stack], dict:new()) of + {ok, {simple,_FinType}, _NewState} = Result -> + Result; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, not_symb, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end. + +-spec cache_type(mod_name(), type_ref(), fin_type(), abs_type(), symb_info(), + state()) -> state(). +cache_type(Mod, TypeRef, FinType, TypeForm, SymbInfo, + #state{types = Types} = State) -> + TypeRepr = {cached,FinType,TypeForm,SymbInfo}, + ModTypes = dict:fetch(Mod, Types), + NewModTypes = dict:store(TypeRef, TypeRepr, ModTypes), + NewTypes = dict:store(Mod, NewModTypes, Types), + State#state{types = NewTypes}. + +-spec convert_maybe_rec(full_type_ref(), symb_info(), rec_fun(), rec_args(), + state(), stack()) -> rich_result2(ret_type(),state()). +convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, + State) + end. + +-spec safe_convert_maybe_rec(full_type_ref(),symb_info(),rec_fun(),rec_args(), + state()) -> rich_result2(ret_type(),state()). +safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State) -> + case partition_rec_args(FullTypeRef, RecArgs, false) of + {[],[],_,_} -> + {ok, {rec,RecFun,RecArgs}, State}; + {MyRecArgs,MyPos,OtherRecArgs,_OtherPos} -> + case lists:all(fun({B,_T}) -> B =:= false end, MyRecArgs) of + true -> convert_rec_type(SymbInfo, RecFun, MyPos, OtherRecArgs, + State); + false -> {error, {internal,true_rec_arg_reached_type}} + end + end. + +-spec convert_rec_type(symb_info(), rec_fun(), [position()], rec_args(), + state()) -> {ok, ret_type(), state()}. +convert_rec_type(SymbInfo, RecFun, MyPos, [], State) -> + NumRecArgs = length(MyPos), + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + RecFun(GenFuns, erlang:max(0,Size - 1)) + end + end, + SizedGen = y(M), + ImmFinType = ?SIZED(Size,SizedGen(Size + 1)), + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + {ok, {simple,FinType}, State}; +convert_rec_type(_SymbInfo, RecFun, MyPos, OtherRecArgs, State) -> + NumRecArgs = length(MyPos), + NewRecFun = + fun(OtherGens,TopSize) -> + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + AllGens = + proper_arith:insert(GenFuns, MyPos, OtherGens), + RecFun(AllGens, erlang:max(0,Size - 1)) + end + end, + (y(M))(TopSize) + end, + NewRecArgs = clean_rec_args(OtherRecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +%% Y Combinator: Read more at http://bc.tech.coop/blog/070611.html. +-spec y(fun((fun((T) -> S)) -> fun((T) -> S))) -> fun((T) -> S). +y(M) -> + G = fun(F) -> + M(fun(A) -> (F(F))(A) end) + end, + G(G). + +-spec process_list(mod_name(), [abs_type() | ret_type()], state(), stack(), + var_dict()) -> rich_result2([ret_type()],state()). +process_list(Mod, RawTypes, State, Stack, VarDict) -> + Process = fun({simple,_FinType} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + ({rec,_RecFun,_RecArgs} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + (TypeForm, {ok,Types,State1}) -> + case convert(Mod, TypeForm, State1, Stack, VarDict) of + {ok,Type,State2} -> {ok,[Type|Types],State2}; + {error,_} = Err -> Err + end; + (_RawType, {error,_} = Err) -> + Err + end, + case lists:foldl(Process, {ok,[],State}, RawTypes) of + {ok,RevTypes,NewState} -> + {ok, lists:reverse(RevTypes), NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec convert_integer(abs_expr(), state()) -> rich_result2(ret_type(),state()). +convert_integer(Expr, State) -> + case eval_int(Expr) of + {ok,Int} -> {ok, {simple,proper_types:exactly(Int)}, State}; + error -> expr_error(invalid_int_const, Expr) + end. + +-spec eval_int(abs_expr()) -> tagged_result(integer()). +eval_int(Expr) -> + NoBindings = erl_eval:new_bindings(), + try erl_eval:expr(Expr, NoBindings) of + {value,Value,_NewBindings} when is_integer(Value) -> + {ok, Value}; + _ -> + error + catch + error:_ -> + error + end. + +-spec expr_error(atom(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr) -> + {error, {Reason,lists:flatten(erl_pp:expr(Expr))}}. + +-spec expr_error(atom(), abs_expr(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr1, Expr2) -> + Str1 = lists:flatten(erl_pp:expr(Expr1)), + Str2 = lists:flatten(erl_pp:expr(Expr2)), + {error, {Reason,Str1,Str2}}. + +-spec base_case_error(stack()) -> {'error',term()}. +%% TODO: This might confuse, since it doesn't record the arguments to parametric +%% types or the type subsitutions of a record. +base_case_error([{Mod,type,Name,Args} | _Upper]) -> + Arity = length(Args), + {error, {no_base_case,{Mod,type,Name,Arity}}}; +base_case_error([{Mod,record,Name,_SubstsDict} | _Upper]) -> + {error, {no_base_case,{Mod,record,Name}}}. + + +%%------------------------------------------------------------------------------ +%% Helper datatypes handling functions +%%------------------------------------------------------------------------------ + +-spec stack_position(full_type_ref(), stack()) -> 'none' | pos_integer(). +stack_position(FullTypeRef, Stack) -> + SameType = fun(A) -> same_full_type_ref(A,FullTypeRef) end, + case proper_arith:find_first(SameType, Stack) of + {Pos,_} -> Pos; + none -> none + end. + +-spec partition_by_toplevel(rec_args(), stack(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_by_toplevel(RecArgs, [], _OnlyInstanceAccepting) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [_Parent | _Upper], _OnlyInstanceAccepting) + when is_atom(_Parent) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [Parent | _Upper], OnlyInstanceAccepting) -> + partition_rec_args(Parent, RecArgs, OnlyInstanceAccepting). + +-spec at_toplevel(rec_args(), stack()) -> boolean(). +at_toplevel(RecArgs, Stack) -> + case partition_by_toplevel(RecArgs, Stack, false) of + {[],[],_,_} -> false; + _ -> true + end. + +-spec partition_rec_args(full_type_ref(), rec_args(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_rec_args(FullTypeRef, RecArgs, OnlyInstanceAccepting) -> + SameType = + case OnlyInstanceAccepting of + true -> fun({false,_T}) -> false + ; ({_B,T}) -> same_full_type_ref(T,FullTypeRef) end; + false -> fun({_B,T}) -> same_full_type_ref(T,FullTypeRef) end + end, + proper_arith:partition(SameType, RecArgs). + +%% Tuples can be of 0 arity, unions of 1 and wunions at least of 2. +-spec combine_ret_types([ret_type()], {'tuple',boolean()} | 'union' + | 'wunion') -> ret_type(). +combine_ret_types(RetTypes, EnclosingType) -> + case lists:all(fun is_simple_ret_type/1, RetTypes) of + true -> + %% This should never happen for wunion. + Combine = case EnclosingType of + {tuple,false} -> fun proper_types:tuple/1; + {tuple,true} -> fun proper_types:fixed_list/1; + union -> fun proper_types:union/1 + end, + FinTypes = [T || {simple,T} <- RetTypes], + {simple, Combine(FinTypes)}; + false -> + NumTypes = length(RetTypes), + {RevRecFuns,RevRecArgsList,NumRecs} = + lists:foldl(fun add_ret_type/2, {[],[],0}, RetTypes), + RecFuns = lists:reverse(RevRecFuns), + RecArgsList = lists:reverse(RevRecArgsList), + RecArgLens = [length(RecArgs) || RecArgs <- RecArgsList], + RecFunInfo = {NumTypes,NumRecs,RecArgLens,RecFuns}, + FlatRecArgs = lists:flatten(RecArgsList), + {NewRecFun,NewRecArgs} = + case EnclosingType of + {tuple,ToList} -> + {tuple_rec_fun(RecFunInfo,ToList), + soft_clean_rec_args(FlatRecArgs,RecFunInfo,ToList)}; + union -> + {union_rec_fun(RecFunInfo),clean_rec_args(FlatRecArgs)}; + wunion -> + {wunion_rec_fun(RecFunInfo), + clean_rec_args(FlatRecArgs)} + end, + {rec, NewRecFun, NewRecArgs} + end. + +-spec tuple_rec_fun(rec_fun_info(), boolean()) -> rec_fun(). +tuple_rec_fun({_NumTypes,NumRecs,RecArgLens,RecFuns}, ToList) -> + Combine = case ToList of + true -> fun proper_types:fixed_list/1; + false -> fun proper_types:tuple/1 + end, + fun(AllGFs,TopSize) -> + Size = TopSize div NumRecs, + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun erlang:apply/2, + Combine(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec union_rec_fun(rec_fun_info()) -> rec_fun(). +union_rec_fun({_NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(F,A) -> ?LAZY(apply(F,A)) end, + proper_types:union(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec wunion_rec_fun(rec_fun_info()) -> rec_fun(). +wunion_rec_fun({NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(W,F,A) -> {W,?LAZY(apply(F,A))} end, + RecWeight = erlang:max(1, Size div (NumTypes - 1)), + Weights = [1 | lists:duplicate(NumTypes - 1, RecWeight)], + WeightedChoices = lists:zipwith3(ZipFun, Weights, RecFuns, ArgsList), + proper_types:wunion(WeightedChoices) + end. + +-spec add_ret_type(ret_type(), {[rec_fun()],[rec_args()],non_neg_integer()}) -> + {[rec_fun()],[rec_args()],non_neg_integer()}. +add_ret_type({simple,FinType}, {RecFuns,RecArgsList,NumRecs}) -> + {[fun([],_) -> FinType end | RecFuns], [[] | RecArgsList], NumRecs}; +add_ret_type({rec,RecFun,RecArgs}, {RecFuns,RecArgsList,NumRecs}) -> + {[RecFun | RecFuns], [RecArgs | RecArgsList], NumRecs + 1}. + +-spec is_simple_ret_type(ret_type()) -> boolean(). +is_simple_ret_type({simple,_FinType}) -> + true; +is_simple_ret_type({rec,_RecFun,_RecArgs}) -> + false. + +-spec clean_rec_args(rec_args()) -> rec_args(). +clean_rec_args(RecArgs) -> + [{false,F} || {_B,F} <- RecArgs]. + +-spec soft_clean_rec_args(rec_args(), rec_fun_info(), boolean()) -> rec_args(). +soft_clean_rec_args(RecArgs, RecFunInfo, ToList) -> + soft_clean_rec_args_tr(RecArgs, [], RecFunInfo, ToList, false, 1). + +-spec soft_clean_rec_args_tr(rec_args(), rec_args(), rec_fun_info(), boolean(), + boolean(), position()) -> rec_args(). +soft_clean_rec_args_tr([], Acc, _RecFunInfo, _ToList, _FoundListInst, _Pos) -> + lists:reverse(Acc); +soft_clean_rec_args_tr([{{list,_NonEmpty,_AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, true, Pos) -> + NewArg = {false,FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([{{list,NonEmpty,AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, false, Pos) -> + {NumTypes,NumRecs,RecArgLens,RecFuns} = RecFunInfo, + AltRecFunPos = get_group(Pos, RecArgLens), + AltRecFuns = proper_arith:list_update(AltRecFunPos, AltRecFun, RecFuns), + AltRecFunInfo = {NumTypes,NumRecs,RecArgLens,AltRecFuns}, + NewArg = {{list,NonEmpty,tuple_rec_fun(AltRecFunInfo,ToList)},FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([Arg | Rest], Acc, RecFunInfo, ToList, FoundListInst, + Pos) -> + soft_clean_rec_args_tr(Rest, [Arg | Acc], RecFunInfo, ToList, FoundListInst, + Pos+1). + +-spec get_group(pos_integer(), [non_neg_integer()]) -> pos_integer(). +get_group(Pos, AllMembers) -> + get_group_tr(Pos, AllMembers, 1). + +-spec get_group_tr(pos_integer(), [non_neg_integer()], pos_integer()) -> + pos_integer(). +get_group_tr(Pos, [Members | Rest], GroupNum) -> + case Pos =< Members of + true -> GroupNum; + false -> get_group_tr(Pos - Members, Rest, GroupNum + 1) + end. + +-spec same_full_type_ref(full_type_ref(), term()) -> boolean(). +same_full_type_ref({SameMod,type,SameName,Args1}, + {SameMod,type,SameName,Args2}) -> + length(Args1) =:= length(Args2) + andalso lists:all(fun({A,B}) -> same_ret_type(A,B) end, + lists:zip(Args1, Args2)); +same_full_type_ref({SameMod,record,SameName,SubstsDict1}, + {SameMod,record,SameName,SubstsDict2}) -> + same_substs_dict(SubstsDict1, SubstsDict2); +same_full_type_ref(_, _) -> + false. + +-spec same_ret_type(ret_type(), ret_type()) -> boolean(). +same_ret_type({simple,FinType1}, {simple,FinType2}) -> + same_fin_type(FinType1, FinType2); +same_ret_type({rec,RecFun1,RecArgs1}, {rec,RecFun2,RecArgs2}) -> + NumRecArgs = length(RecArgs1), + length(RecArgs2) =:= NumRecArgs + andalso lists:all(fun({A1,A2}) -> same_rec_arg(A1,A2,NumRecArgs) end, + lists:zip(RecArgs1,RecArgs2)) + andalso same_rec_fun(RecFun1, RecFun2, NumRecArgs); +same_ret_type(_, _) -> + false. + +%% TODO: Is this too strict? +-spec same_rec_arg(rec_arg(), rec_arg(), arity()) -> boolean(). +same_rec_arg({{list,SameBool,AltRecFun1},FTRef1}, + {{list,SameBool,AltRecFun2},FTRef2}, NumRecArgs) -> + same_rec_fun(AltRecFun1, AltRecFun2, NumRecArgs) + andalso same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({true,FTRef1}, {true,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({false,FTRef1}, {false,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg(_, _, _NumRecArgs) -> + false. + +-spec same_substs_dict(substs_dict(), substs_dict()) -> boolean(). +same_substs_dict(SubstsDict1, SubstsDict2) -> + SameKVPair = fun({{_K,V1},{_K,V2}}) -> same_ret_type(V1,V2); + (_) -> false + end, + SubstsKVList1 = lists:sort(dict:to_list(SubstsDict1)), + SubstsKVList2 = lists:sort(dict:to_list(SubstsDict2)), + length(SubstsKVList1) =:= length(SubstsKVList2) + andalso lists:all(SameKVPair, lists:zip(SubstsKVList1,SubstsKVList2)). + +-spec same_fin_type(fin_type(), fin_type()) -> boolean(). +same_fin_type(Type1, Type2) -> + proper_types:equal_types(Type1, Type2). + +-spec same_rec_fun(rec_fun(), rec_fun(), arity()) -> boolean(). +same_rec_fun(RecFun1, RecFun2, NumRecArgs) -> + %% It's ok that we return a type, even if there's a 'true' for use of + %% an instance. + GenFun = fun(_Size) -> proper_types:exactly('$dummy') end, + GenFuns = lists:duplicate(NumRecArgs,GenFun), + same_fin_type(RecFun1(GenFuns,0), RecFun2(GenFuns,0)). diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 58060361af..02e1625965 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2003-2015. All Rights Reserved. +%% Copyright Ericsson AB 2003-2016. All Rights Reserved. %% %% Licensed under the Apache License, Version 2.0 (the "License"); %% you may not use this file except in compliance with the License. @@ -4611,7 +4611,7 @@ t_from_form({type, _L, 'fun', [{type, _, any}, Range]}, TypeNames, t_from_form({type, _L, 'fun', [{type, _, product, Domain}, Range]}, TypeNames, ET, S, MR, V, D, L) -> {Dom1, L1} = list_from_form(Domain, TypeNames, ET, S, MR, V, D, L), - {Ran1, L2} = t_from_form(Range, TypeNames, ET, S, MR, V, D - 1, L1), + {Ran1, L2} = t_from_form(Range, TypeNames, ET, S, MR, V, D, L1), {t_fun(Dom1, Ran1), L2}; t_from_form({type, _L, identifier, []}, _TypeNames, _ET, _S, _MR, _V, _D, L) -> {t_identifier(), L}; diff --git a/lib/hipe/test/hipe_SUITE.erl b/lib/hipe/test/hipe_SUITE.erl index 9319b710d9..a5b3924aa8 100644 --- a/lib/hipe/test/hipe_SUITE.erl +++ b/lib/hipe/test/hipe_SUITE.erl @@ -19,9 +19,6 @@ -compile([export_all]). -include_lib("common_test/include/ct.hrl"). -suite() -> - [{ct_hooks, [ts_install_cth]}]. - all() -> [app, appup]. diff --git a/lib/runtime_tools/c_src/Makefile.in b/lib/runtime_tools/c_src/Makefile.in index 70b48daf97..4530a83aee 100644 --- a/lib/runtime_tools/c_src/Makefile.in +++ b/lib/runtime_tools/c_src/Makefile.in @@ -91,7 +91,7 @@ $(OBJDIR): $(LIBDIR): -@mkdir -p $(LIBDIR) -$(OBJDIR)/%$(TYPEMARKER).o: %.c +$(OBJDIR)/%$(TYPEMARKER).o: %.c dyntrace_lttng.h $(V_CC) -c -o $@ $(ALL_CFLAGS) $< $(LIBDIR)/%$(TYPEMARKER).@DED_EXT@: $(OBJDIR)/%$(TYPEMARKER).o diff --git a/lib/runtime_tools/c_src/dyntrace.c b/lib/runtime_tools/c_src/dyntrace.c index 0ef8eaf4d3..0178d95efb 100644 --- a/lib/runtime_tools/c_src/dyntrace.c +++ b/lib/runtime_tools/c_src/dyntrace.c @@ -29,7 +29,13 @@ #include "sys.h" #include "dtrace-wrapper.h" #if defined(USE_DYNAMIC_TRACE) && (defined(USE_DTRACE) || defined(USE_SYSTEMTAP)) -#define HAVE_USE_DTRACE 1 +# define HAVE_USE_DTRACE 1 +#endif +#if defined(USE_LTTNG) +# define HAVE_USE_LTTNG 1 +# define TRACEPOINT_DEFINE +# define TRACEPOINT_CREATE_PROBES +# include "dyntrace_lttng.h" #endif void dtrace_nifenv_str(ErlNifEnv *env, char *process_buf); @@ -60,11 +66,56 @@ static ERL_NIF_TERM user_trace_s1(ErlNifEnv* env, int argc, const ERL_NIF_TERM a static ERL_NIF_TERM user_trace_i4s4(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); static ERL_NIF_TERM user_trace_n(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + +#ifdef HAVE_USE_LTTNG +static ERL_NIF_TERM trace_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM trace_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); + +static ERL_NIF_TERM enabled_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +static ERL_NIF_TERM enabled_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]); +#endif + + static ErlNifFunc nif_funcs[] = { {"available", 0, available}, {"user_trace_s1", 1, user_trace_s1}, {"user_trace_i4s4", 9, user_trace_i4s4}, - {"user_trace_n", 10, user_trace_n} + {"user_trace_n", 10, user_trace_n}, +#ifdef HAVE_USE_LTTNG + {"trace_procs", 6, trace_procs}, + {"trace_ports", 6, trace_ports}, + {"trace_running_procs", 6, trace_running_procs}, + {"trace_running_ports", 6, trace_running_ports}, + {"trace_call", 6, trace_call}, + {"trace_send", 6, trace_send}, + {"trace_receive", 6, trace_receive}, + {"trace_garbage_collection", 6, trace_garbage_collection}, + {"enabled_procs", 3, enabled_procs}, + {"enabled_ports", 3, enabled_ports}, + {"enabled_running_procs", 3, enabled_running_procs}, + {"enabled_running_ports", 3, enabled_running_ports}, + {"enabled_call", 3, enabled_call}, + {"enabled_send", 3, enabled_send}, + {"enabled_receive", 3, enabled_receive}, + {"enabled_garbage_collection", 3, enabled_garbage_collection}, +#endif + {"enabled", 3, enabled}, + {"trace", 5, trace}, + {"trace", 6, trace} }; ERL_NIF_INIT(dyntrace, nif_funcs, load, NULL, NULL, NULL) @@ -76,6 +127,61 @@ static ERL_NIF_TERM atom_not_available; static ERL_NIF_TERM atom_badarg; static ERL_NIF_TERM atom_ok; +static ERL_NIF_TERM atom_trace; +static ERL_NIF_TERM atom_seq_trace; +static ERL_NIF_TERM atom_remove; +static ERL_NIF_TERM atom_discard; + +#ifdef HAVE_USE_LTTNG + +/* gc atoms */ + +static ERL_NIF_TERM atom_gc_minor_start; +static ERL_NIF_TERM atom_gc_minor_end; +static ERL_NIF_TERM atom_gc_major_start; +static ERL_NIF_TERM atom_gc_major_end; + +static ERL_NIF_TERM atom_old_heap_block_size; /* for debug */ +static ERL_NIF_TERM atom_heap_block_size; /* for debug */ + +/* process 'procs' */ + +static ERL_NIF_TERM atom_spawn; +static ERL_NIF_TERM atom_exit; +static ERL_NIF_TERM atom_register; +static ERL_NIF_TERM atom_unregister; +static ERL_NIF_TERM atom_link; +static ERL_NIF_TERM atom_unlink; +static ERL_NIF_TERM atom_getting_linked; +static ERL_NIF_TERM atom_getting_unlinked; + +/* process 'running' and 'exiting' */ + +static ERL_NIF_TERM atom_in; +static ERL_NIF_TERM atom_out; +static ERL_NIF_TERM atom_in_exiting; +static ERL_NIF_TERM atom_out_exiting; +static ERL_NIF_TERM atom_out_exited; + +/* process messages 'send' and 'receive' */ + +static ERL_NIF_TERM atom_send; +static ERL_NIF_TERM atom_receive; +static ERL_NIF_TERM atom_send_to_non_existing_process; + +/* ports 'ports' */ + +static ERL_NIF_TERM atom_open; +static ERL_NIF_TERM atom_closed; + +/* 'call' */ + +static ERL_NIF_TERM atom_call; +static ERL_NIF_TERM atom_return_from; +static ERL_NIF_TERM atom_return_to; +static ERL_NIF_TERM atom_exception_from; +#endif + static int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info) { atom_true = enif_make_atom(env,"true"); @@ -85,6 +191,61 @@ static int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info) atom_badarg = enif_make_atom(env,"badarg"); atom_ok = enif_make_atom(env,"ok"); + atom_trace = enif_make_atom(env,"trace"); + atom_seq_trace = enif_make_atom(env,"seq_trace"); + atom_remove = enif_make_atom(env,"remove"); + atom_discard = enif_make_atom(env,"discard"); + +#ifdef HAVE_USE_LTTNG + + /* gc */ + + atom_gc_minor_start = enif_make_atom(env,"gc_minor_start"); + atom_gc_minor_end = enif_make_atom(env,"gc_minor_end"); + atom_gc_major_start = enif_make_atom(env,"gc_major_start"); + atom_gc_major_end = enif_make_atom(env,"gc_major_end"); + + atom_old_heap_block_size = enif_make_atom(env,"old_heap_block_size"); + atom_heap_block_size = enif_make_atom(env,"heap_block_size"); + + /* process 'proc' */ + + atom_spawn = enif_make_atom(env,"spawn"); + atom_exit = enif_make_atom(env,"exit"); + atom_register = enif_make_atom(env,"register"); + atom_unregister = enif_make_atom(env,"unregister"); + atom_link = enif_make_atom(env,"link"); + atom_unlink = enif_make_atom(env,"unlink"); + atom_getting_unlinked = enif_make_atom(env,"getting_unlinked"); + atom_getting_linked = enif_make_atom(env,"getting_linked"); + + /* process 'running' and 'exiting' */ + + atom_in = enif_make_atom(env,"in"); + atom_out = enif_make_atom(env,"out"); + atom_in_exiting = enif_make_atom(env,"in_exiting"); + atom_out_exiting = enif_make_atom(env,"out_exiting"); + atom_out_exited = enif_make_atom(env,"out_exited"); + + /* process messages 'send' and 'receive' */ + + atom_send = enif_make_atom(env,"send"); + atom_receive = enif_make_atom(env,"receive"); + atom_send_to_non_existing_process = enif_make_atom(env,"send_to_non_existing_process"); + + /* ports 'ports' */ + + atom_open = enif_make_atom(env,"open"); + atom_closed = enif_make_atom(env,"closed"); + + /* 'call' */ + + atom_call = enif_make_atom(env,"call"); + atom_return_from = enif_make_atom(env,"return_from"); + atom_return_to = enif_make_atom(env,"return_to"); + atom_exception_from = enif_make_atom(env,"exception_from"); +#endif + return 0; } @@ -123,3 +284,442 @@ static ERL_NIF_TERM user_trace_n(ErlNifEnv* env, int argc, const ERL_NIF_TERM ar return atom_error; #endif } + +static ERL_NIF_TERM enabled(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ +#ifdef HAVE_USE_LTTNG + ASSERT(argc == 3); + return atom_trace; +#endif + return atom_remove; +} + +static ERL_NIF_TERM trace(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + return atom_ok; +} + +#ifdef HAVE_USE_LTTNG +static ERL_NIF_TERM enabled_garbage_collection(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_gc_minor_start && LTTNG_ENABLED(gc_minor_start)) { + return atom_trace; + } else if (argv[0] == atom_gc_minor_end && LTTNG_ENABLED(gc_minor_end)) { + return atom_trace; + } else if (argv[0] == atom_gc_major_start && LTTNG_ENABLED(gc_major_start)) { + return atom_trace; + } else if (argv[0] == atom_gc_major_end && LTTNG_ENABLED(gc_major_end)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_garbage_collection(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + ERL_NIF_TERM gci, tup; + const ERL_NIF_TERM *vals; + int arity; + unsigned long ohbsz, nhbsz, size; + + ASSERT(argc == 6); + + /* Assume gc info order does not change */ + gci = argv[3]; + + /* get reclaimed or need */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + enif_get_ulong(env, vals[1], &size); + + /* get old heap block size */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + ASSERT(vals[0] == atom_old_heap_block_size); + enif_get_ulong(env, vals[1], &ohbsz); + + /* get new heap block size */ + enif_get_list_cell(env, gci, &tup, &gci); + enif_get_tuple(env, tup, &arity, &vals); + ASSERT(arity == 2); + ASSERT(vals[0] == atom_heap_block_size); + enif_get_ulong(env, vals[1], &nhbsz); + + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_gc_minor_start) { + LTTNG4(gc_minor_start, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_minor_end) { + LTTNG4(gc_minor_end, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_major_start) { + LTTNG4(gc_major_start, pid, size, nhbsz, ohbsz); + } else if (argv[0] == atom_gc_major_end) { + LTTNG4(gc_major_end, pid, size, nhbsz, ohbsz); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_call(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_call && LTTNG_ENABLED(function_call)) + return atom_trace; + else if (argv[0] == atom_return_from && LTTNG_ENABLED(function_return)) + return atom_trace; + else if (argv[0] == atom_exception_from && LTTNG_ENABLED(function_exception)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_call(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + unsigned int len; + char undef[] = "undefined"; + + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_call) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + if (enif_is_list(env, tuple[2])) { + enif_get_list_length(env, tuple[2], &len); + } else { + enif_get_uint(env, tuple[2], &len); + } + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_call, pid, mfa, 0); + } else { + LTTNG3(function_call, pid, undef, 0); + } + } else if (argv[0] == atom_return_from) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_return, pid, mfa, 0); + } else { + LTTNG3(function_return, pid, undef, 0); + } + } else if (argv[0] == atom_return_to) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_return, pid, mfa, 0); + } else { + LTTNG3(function_return, pid, undef, 0); + } + } else if (argv[0] == atom_exception_from) { + const ERL_NIF_TERM* tuple; + int arity; + lttng_decl_mfabuf(mfa); + char class[LTTNG_BUFFER_SZ]; + + enif_get_tuple(env, argv[4], &arity, &tuple); + erts_snprintf(class, LTTNG_BUFFER_SZ, "%T", tuple[0]); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + enif_get_uint(env, tuple[2], &len); + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(function_exception, pid, mfa, class); + } else { + LTTNG3(function_exception, pid, undef, class); + } + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_send(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + if (LTTNG_ENABLED(message_send)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_send(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_pid_to_str(argv[2], pid); + + if (argv[0] == atom_send) { + lttng_decl_procbuf(to); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[4], to); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG3(message_send, pid, to, msg); + } else if (argv[0] == atom_send_to_non_existing_process) { + lttng_decl_procbuf(to); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[4], to); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + /* mark it as non existing ? */ + + LTTNG3(message_send, pid, to, msg); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_receive(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + if (LTTNG_ENABLED(message_receive)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_receive(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + if (argv[0] == atom_receive) { + lttng_decl_procbuf(pid); + char msg[LTTNG_BUFFER_SZ]; + + lttng_pid_to_str(argv[2], pid); + erts_snprintf(msg, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG2(message_receive, pid, msg); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_procs(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_spawn && LTTNG_ENABLED(process_spawn)) { + return atom_trace; + } else if (argv[0] == atom_register && LTTNG_ENABLED(process_register)) { + return atom_trace; + } else if (argv[0] == atom_unregister && LTTNG_ENABLED(process_register)) { + return atom_trace; + } else if (argv[0] == atom_link && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_unlink && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_linked && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_unlinked && LTTNG_ENABLED(process_link)) { + return atom_trace; + } else if (argv[0] == atom_exit && LTTNG_ENABLED(process_exit)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_decl_procbuf(to); + + lttng_pid_to_str(argv[2], pid); + + /* spawn */ + if (argv[0] == atom_spawn) { + char undef[] = "undefined"; + const ERL_NIF_TERM* tuple; + int arity; + unsigned int len; + lttng_decl_mfabuf(mfa); + + lttng_pid_to_str(argv[3], to); + + if (enif_get_tuple(env, argv[4], &arity, &tuple)) { + if (enif_is_list(env, tuple[2])) { + enif_get_list_length(env, tuple[2], &len); + } else { + enif_get_uint(env, tuple[2], &len); + } + lttng_mfa_to_str(tuple[0], tuple[1], len, mfa); + LTTNG3(process_spawn, to, pid, mfa); + } else { + LTTNG3(process_spawn, to, pid, undef); + } + + /* register */ + } else if (argv[0] == atom_register) { + char name[LTTNG_BUFFER_SZ]; + erts_snprintf(name, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG3(process_register, pid, name, "register"); + } else if (argv[0] == atom_unregister) { + char name[LTTNG_BUFFER_SZ]; + erts_snprintf(name, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG3(process_register, pid, name, "unregister"); + /* link */ + } else if (argv[0] == atom_link) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, pid, to, "link"); + } else if (argv[0] == atom_unlink) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, pid, to, "unlink"); + } else if (argv[0] == atom_getting_linked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, to, pid, "link"); + } else if (argv[0] == atom_getting_unlinked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(process_link, to, pid, "unlink"); + /* exit */ + } else if (argv[0] == atom_exit) { + char reason[LTTNG_BUFFER_SZ]; + erts_snprintf(reason, LTTNG_BUFFER_SZ, "%T", argv[3]); + LTTNG2(process_exit, pid, reason); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_ports(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (argv[0] == atom_open && LTTNG_ENABLED(port_open)) { + return atom_trace; + } else if (argv[0] == atom_link && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_unlink && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_linked && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_getting_unlinked && LTTNG_ENABLED(port_link)) { + return atom_trace; + } else if (argv[0] == atom_closed && LTTNG_ENABLED(port_exit)) { + return atom_trace; + } + + return atom_discard; +} + +static ERL_NIF_TERM trace_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_portbuf(port); + lttng_decl_procbuf(to); + + lttng_portid_to_str(argv[2], port); + + /* open and closed */ + if (argv[0] == atom_open) { + char driver[LTTNG_BUFFER_SZ]; + lttng_decl_procbuf(pid); + lttng_pid_to_str(argv[3], pid); + + erts_snprintf(driver, LTTNG_BUFFER_SZ, "%T", argv[4]); + LTTNG3(port_open, pid, driver, port); + } else if (argv[0] == atom_closed) { + char reason[LTTNG_BUFFER_SZ]; + erts_snprintf(reason, LTTNG_BUFFER_SZ, "%T", argv[3]); + + LTTNG2(port_exit, port, reason); + /* link */ + } else if (argv[0] == atom_link) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, port, to, "link"); + } else if (argv[0] == atom_unlink) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, port, to, "unlink"); + } else if (argv[0] == atom_getting_linked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, to, port, "link"); + } else if (argv[0] == atom_getting_unlinked) { + lttng_pid_to_str(argv[3], to); + LTTNG3(port_link, to, port, "unlink"); + } + return atom_ok; +} + +static ERL_NIF_TERM enabled_running_procs(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (LTTNG_ENABLED(process_scheduled)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_running_procs(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + const ERL_NIF_TERM* tuple; + char *mfastr = "undefined"; + int arity; + lttng_decl_mfabuf(mfa); + + lttng_pid_to_str(argv[2], pid); + + if (enif_get_tuple(env, argv[3], &arity, &tuple)) { + int val; + enif_get_int(env, tuple[2], &val); + lttng_mfa_to_str(tuple[0], tuple[1], val, mfa); + mfastr = mfa; + } + /* running processes */ + if (argv[0] == atom_in) { + LTTNG3(process_scheduled, pid, mfastr, "in"); + } else if (argv[0] == atom_out) { + LTTNG3(process_scheduled, pid, mfastr, "out"); + /* exiting */ + } else if (argv[0] == atom_in_exiting) { + LTTNG3(process_scheduled, pid, mfastr, "in_exiting"); + } else if (argv[0] == atom_out_exiting) { + LTTNG3(process_scheduled, pid, mfastr, "out_exiting"); + } else if (argv[0] == atom_out_exited) { + LTTNG3(process_scheduled, pid, mfastr, "out_exited"); + } + + return atom_ok; +} + +static ERL_NIF_TERM enabled_running_ports(ErlNifEnv *env, int argc, const ERL_NIF_TERM argv[]) +{ + ASSERT(argc == 3); + + if (LTTNG_ENABLED(port_scheduled)) + return atom_trace; + + return atom_discard; +} + +static ERL_NIF_TERM trace_running_ports(ErlNifEnv* env, int argc, const ERL_NIF_TERM argv[]) +{ + lttng_decl_procbuf(pid); + lttng_decl_mfabuf(where); + + lttng_portid_to_str(argv[2], pid); + erts_snprintf(where, LTTNG_BUFFER_SZ, "%T", argv[3]); + + /* running ports */ + if (argv[0] == atom_in) { + LTTNG3(port_scheduled, pid, where, "in"); + } else if (argv[0] == atom_out) { + LTTNG3(port_scheduled, pid, where, "out"); + /* exiting */ + } else if (argv[0] == atom_in_exiting) { + LTTNG3(port_scheduled, pid, where, "in_exiting"); + } else if (argv[0] == atom_out_exiting) { + LTTNG3(port_scheduled, pid, where, "out_exiting"); + } else if (argv[0] == atom_out_exited) { + LTTNG3(port_scheduled, pid, where, "out_exited"); + } + return atom_ok; +} +#endif diff --git a/lib/runtime_tools/c_src/dyntrace_lttng.h b/lib/runtime_tools/c_src/dyntrace_lttng.h new file mode 100644 index 0000000000..3550a1cab5 --- /dev/null +++ b/lib/runtime_tools/c_src/dyntrace_lttng.h @@ -0,0 +1,367 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 2016. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ + +#undef TRACEPOINT_PROVIDER +#define TRACEPOINT_PROVIDER com_ericsson_dyntrace + +#if !defined(DYNTRACE_LTTNG_H) || defined(TRACEPOINT_HEADER_MULTI_READ) +#define DYNTRACE_LTTNG_H + +#include <lttng/tracepoint.h> + +#define LTTNG1(Name, Arg1) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1)) + +#define LTTNG2(Name, Arg1, Arg2) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2)) + +#define LTTNG3(Name, Arg1, Arg2, Arg3) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3)) + +#define LTTNG4(Name, Arg1, Arg2, Arg3, Arg4) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3), (Arg4)) + +#define LTTNG5(Name, Arg1, Arg2, Arg3, Arg4, Arg5) \ + tracepoint(com_ericsson_dyntrace, Name, (Arg1), (Arg2), (Arg3), (Arg4), (Arg5)) + +#define LTTNG_ENABLED(Name) \ + tracepoint_enabled(com_ericsson_dyntrace, Name) + +#define LTTNG_BUFFER_SZ (256) +#define LTTNG_PROC_BUFFER_SZ (16) +#define LTTNG_PORT_BUFFER_SZ (20) +#define LTTNG_MFA_BUFFER_SZ (256) + +#define lttng_decl_procbuf(Name) \ + char Name[LTTNG_PROC_BUFFER_SZ] + +#define lttng_decl_portbuf(Name) \ + char Name[LTTNG_PORT_BUFFER_SZ] + +#define lttng_decl_mfabuf(Name) \ + char Name[LTTNG_MFA_BUFFER_SZ] + +#define lttng_pid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PROC_BUFFER_SZ, "%T", (pid)) + +#define lttng_portid_to_str(pid, name) \ + erts_snprintf(name, LTTNG_PORT_BUFFER_SZ, "%T", (pid)) + +#define lttng_proc_to_str(p, name) \ + lttng_pid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PID), name) + +#define lttng_port_to_str(p, name) \ + lttng_portid_to_str(((p) ? (p)->common.id : ERTS_INVALID_PORT), name) + +#define lttng_mfa_to_str(m,f,a, Name) \ + erts_snprintf(Name, LTTNG_MFA_BUFFER_SZ, "%T:%T/%lu", (Eterm)(m), (Eterm)(f), (Uint)(a)) + +/* Process scheduling */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_spawn, + TP_ARGS( + char*, p, + char*, parent, + char*, mfa + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(parent, parent) + ctf_string(entry, mfa) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_link, + TP_ARGS( + char*, from, + char*, to, + char*, type + ), + TP_FIELDS( + ctf_string(from, from) + ctf_string(to, to) + ctf_string(type, type) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_exit, + TP_ARGS( + char*, p, + char*, reason + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(reason, reason) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_register, + TP_ARGS( + char*, pid, + char*, name, + char*, type + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(name, name) + ctf_string(type, type) + ) +) + +/* Scheduled */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + process_scheduled, + TP_ARGS( + char*, p, + char*, mfa, + char*, type + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(entry, mfa) + ctf_string(type, type) + ) +) + +/* Ports */ + + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_open, + TP_ARGS( + char*, pid, + char*, driver, + char*, port + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(driver, driver) + ctf_string(port, port) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_exit, + TP_ARGS( + char*, port, + char*, reason + ), + TP_FIELDS( + ctf_string(port, port) + ctf_string(reason, reason) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_link, + TP_ARGS( + char*, from, + char*, to, + char*, type + ), + TP_FIELDS( + ctf_string(from, from) + ctf_string(to, to) + ctf_string(type, type) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + port_scheduled, + TP_ARGS( + char*, p, + char*, op, + char*, type + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_string(entry, op) + ctf_string(type, type) + ) +) + +/* Call tracing */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_call, + TP_ARGS( + char*, pid, + char*, mfa, + unsigned int, depth + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_integer(unsigned int, depth, depth) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_return, + TP_ARGS( + char*, pid, + char*, mfa, + unsigned int, depth + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_integer(unsigned int, depth, depth) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + function_exception, + TP_ARGS( + char*, pid, + char*, mfa, + char*, type + ), + TP_FIELDS( + ctf_string(pid, pid) + ctf_string(entry, mfa) + ctf_string(class, type) + ) +) + +/* Process messages */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + message_send, + TP_ARGS( + char*, sender, + char*, receiver, + char*, msg + ), + TP_FIELDS( + ctf_string(from, sender) + ctf_string(to, receiver) + ctf_string(message, msg) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + message_receive, + TP_ARGS( + char*, receiver, + char*, msg + ), + TP_FIELDS( + ctf_string(to, receiver) + ctf_string(message, msg) + ) +) + +/* Process Memory */ + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_minor_start, + TP_ARGS( + char*, p, + unsigned long, need, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, need, need) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_minor_end, + TP_ARGS( + char*, p, + unsigned long, reclaimed, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, reclaimed, reclaimed) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_major_start, + TP_ARGS( + char*, p, + unsigned long, need, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, need, need) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +TRACEPOINT_EVENT( + com_ericsson_dyntrace, + gc_major_end, + TP_ARGS( + char*, p, + unsigned long, reclaimed, + unsigned long, nh, + unsigned long, oh + ), + TP_FIELDS( + ctf_string(pid, p) + ctf_integer(unsigned long, reclaimed, reclaimed) + ctf_integer(unsigned long, heap, nh) + ctf_integer(unsigned long, old_heap, oh) + ) +) + +#endif /* DYNTRACE_LTTNG_H */ + +#undef TRACEPOINT_INCLUDE +#define TRACEPOINT_INCLUDE "./dyntrace_lttng.h" + +/* This part must be outside protection */ +#include <lttng/tracepoint-event.h> diff --git a/lib/runtime_tools/doc/src/LTTng.xml b/lib/runtime_tools/doc/src/LTTng.xml new file mode 100644 index 0000000000..eab1848e88 --- /dev/null +++ b/lib/runtime_tools/doc/src/LTTng.xml @@ -0,0 +1,245 @@ +<?xml version="1.0" encoding="utf8" ?> +<!DOCTYPE chapter SYSTEM "chapter.dtd"> +<chapter> + <header> + <copyright> + <year>2016</year><year>2016</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + </legalnotice> + + <title>LTTng and Erlang/OTP</title> + <prepared></prepared> + <responsible></responsible> + <docno></docno> + <approved></approved> + <checked></checked> + <date>2016-04-27</date> + <rev></rev> + <file>LTTng.xml</file> + </header> + + <section> + <title>Introduction</title> + <p>The Linux Trace Toolkit: next generation is an open source system software package + for correlated tracing of the Linux kernel, user applications and libraries. </p> + <p>For more information, please visit <url href="http://lttng.org">http://lttng.org</url></p> + </section> + + <section> + <title>Building Erlang/OTP with LTTng support</title> + <p> + Configure and build Erlang with LTTng support: + </p> + <p>For LTTng to work properly with Erlang/OTP you need + the following packages installed:</p> + + <list type="bulleted"> + <item><p>LTTng-tools: a command line interface to control tracing sessions.</p></item> + <item><p>LTTng-UST: user space tracing library.</p></item> + </list> + + <p>On Ubuntu this can be installed via <c>aptitude</c>:</p> + + <code type="none">$ sudo aptitude install lttng-tools liblttng-ust-dev</code> + <p>See <url href="http://lttng.org/docs/#doc-installing-lttng">Installing LTTng</url> + for more information on how to install LTTng on your system.</p> + + <p>After LTTng is properly installed on the system Erlang/OTP can be built with LTTng support.</p> + + +<code type="none">$ ./configure --with-dynamic-trace=lttng +$ make </code> + </section> + + <section> + <title>Dyntrace Tracepoints</title> + <p>All tracepoints are in the domain of <c>com_ericsson_dyntrace</c></p> + <p>All Erlang types are the string equivalent in LTTng.</p> + + <p><em>process_spawn</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>parent : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_spawn: { cpu_id = 3 }, { pid = "<0.131.0>", parent = "<0.130.0>", entry = "erlang:apply/2" }</code></p> + + <p><em>process_link</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>from : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>type : string</c> :: <c>"link" | "unlink"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_link: { cpu_id = 3 }, { from = "<0.130.0>", to = "<0.131.0>", type = "link" }</code></p> + + + <p><em>process_exit</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reason : string</c> :: Exit reason. Ex. <c>"normal"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_exit: { cpu_id = 3 }, { pid = "<0.130.0>", reason = "normal" }</code></p> + + <p><em>process_register</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>name : string</c> :: Registered name. Ex. <c>"error_logger"</c></item> + <item><c>type : string</c> :: <c>"register" | "unregister"</c></item> + </list> + <p>Example:</p> + <p><code type="none">process_register: { cpu_id = 0 }, { pid = "<0.128.0>", name = "dyntrace_lttng_SUITE" type = "register" }</code></p> + + <p><em>process_scheduled</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>type : string</c> :: <c>"in" | "out" | "in_exiting" | "out_exiting" | "out_exited"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">process_scheduled: { cpu_id = 0 }, { pid = "<0.136.0>", entry = "erlang:apply/2", type = "in" }</code></p> + + + <p><em>port_open</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>driver : string</c> :: Driver name. Ex. <c>"efile"</c></item> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">port_open: { cpu_id = 5 }, { pid = "<0.131.0>", driver = "'/bin/sh -s unix:cmd'", port = "#Port<0.1887>" }</code></p> + + <p><em>port_exit</em></p> + <list type="bulleted"> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + <item><c>reason : string</c> :: Exit reason. Ex. <c>"normal"</c></item> + </list> + <p>Example:</p> + <p><code type="none">port_exit: { cpu_id = 5 }, { port = "#Port<0.1887>", reason = "normal" }</code></p> + + <p><em>port_link</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>from : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>type : string</c> :: <c>"link" | "unlink"</c></item> + </list> + <p>Example:</p> + <p><code type="none">port_link: { cpu_id = 5 }, { from = "#Port<0.1887>", to = "<0.131.0>", type = "unlink" }</code></p> + + <p><em>port_scheduled</em></p> + <list type="bulleted"> + <item><c>port : string</c> :: Port ID. Ex. <c>"#Port<0.1031>"</c></item> + <item><c>entry : string</c> :: Callback. Ex. <c>"open"</c></item> + <item><c>type : string</c> :: <c>"in" | "out" | "in_exiting" | "out_exiting" | "out_exited"</c></item> + </list> + + <p>Example:</p> + <p><code type="none">port_scheduled: { cpu_id = 5 }, { pid = "#Port<0.1905>", entry = "close", type = "out" }</code></p> + + <p><em>function_call</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>depth : integer</c> :: Stack depth. Ex. <c>0</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_call: { cpu_id = 5 }, { pid = "<0.145.0>", entry = "dyntrace_lttng_SUITE:'-t_call/1-fun-1-'/0", depth = 0 }</code></p> + + <p><em>function_return</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>depth : integer</c> :: Stack depth. Ex. <c>0</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_return: { cpu_id = 5 }, { pid = "<0.145.0>", entry = "dyntrace_lttng_SUITE:waiter/0", depth = 0 }</code></p> + + <p><em>function_exception</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>entry : string</c> :: Code Location. Ex. <c>"lists:sort/1"</c></item> + <item><c>class : string</c> :: Error reason. Ex. <c>"error"</c></item> + </list> + <p>Example:</p> + <p><code type="none">function_exception: { cpu_id = 5 }, { pid = "<0.144.0>", entry = "t:call_exc/1", class = "error" }</code></p> + + <p><em>message_send</em></p> + <list type="bulleted"> + <item><c>from : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>message : string</c> :: Message sent. Ex. <c>"{<0.162.0>,ok}"</c></item> + </list> + <p>Example:</p> + <p><code type="none">message_send: { cpu_id = 3 }, { from = "#Port<0.1938>", to = "<0.160.0>", message = "{#Port<0.1938>,eof}" }</code></p> + + <p><em>message_receive</em></p> + <list type="bulleted"> + <item><c>to : string</c> :: Process ID or Port ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>message : string</c> :: Message received. Ex. <c>"{<0.162.0>,ok}"</c></item> + </list> + <p>Example:</p> + <p><code type="none">message_receive: { cpu_id = 7 }, { to = "<0.167.0>", message = "{<0.165.0>,ok}" }</code></p> + + <p><em>gc_minor_start</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>need : integer</c> :: Heap need. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_minor_start: { cpu_id = 0 }, { pid = "<0.172.0>", need = 0, heap = 610, old_heap = 0 }</code></p> + + <p><em>gc_minor_end</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reclaimed : integer</c> :: Heap reclaimed. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_minor_end: { cpu_id = 0 }, { pid = "<0.172.0>", reclaimed = 120, heap = 1598, old_heap = 1598 }</code></p> + + <p><em>gc_major_start</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>need : integer</c> :: Heap need. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_major_start: { cpu_id = 0 }, { pid = "<0.172.0>", need = 8, heap = 2586, old_heap = 1598 }</code></p> + + <p><em>gc_major_end</em></p> + <list type="bulleted"> + <item><c>pid : string</c> :: Process ID. Ex. <c>"<0.131.0>"</c></item> + <item><c>reclaimed : integer</c> :: Heap reclaimed. Ex. <c>2</c></item> + <item><c>heap : integer</c> :: Young heap word size. Ex. <c>233</c></item> + <item><c>old_heap : integer</c> :: Old heap word size. Ex. <c>233</c></item> + </list> + <p>Example:</p> + <p><code type="none">gc_major_end: { cpu_id = 0 }, { pid = "<0.172.0>", reclaimed = 240, heap = 4185, old_heap = 0 }</code></p> + + </section> + + <section> + <title>Examples</title> + </section> +</chapter> diff --git a/lib/runtime_tools/doc/src/Makefile b/lib/runtime_tools/doc/src/Makefile index 0a590ff9ec..5ce40bb995 100644 --- a/lib/runtime_tools/doc/src/Makefile +++ b/lib/runtime_tools/doc/src/Makefile @@ -45,7 +45,7 @@ XML_REF3_FILES = dbg.xml dyntrace.xml erts_alloc_config.xml system_information.x XML_REF6_FILES = runtime_tools_app.xml XML_PART_FILES = part_notes.xml part_notes_history.xml part.xml -XML_CHAPTER_FILES = notes.xml notes_history.xml +XML_CHAPTER_FILES = notes.xml notes_history.xml LTTng.xml GENERATED_XML_FILES = DTRACE.xml SYSTEMTAP.xml diff --git a/lib/runtime_tools/doc/src/part.xml b/lib/runtime_tools/doc/src/part.xml index 14e8b71c83..34acf69fc8 100644 --- a/lib/runtime_tools/doc/src/part.xml +++ b/lib/runtime_tools/doc/src/part.xml @@ -34,6 +34,7 @@ <p><em>Runtime Tools</em></p> </description> + <xi:include href="LTTng.xml"/> <xi:include href="DTRACE.xml"/> <xi:include href="SYSTEMTAP.xml"/> </part> diff --git a/lib/runtime_tools/src/dyntrace.erl b/lib/runtime_tools/src/dyntrace.erl index f7dbef6929..28e6d67d96 100644 --- a/lib/runtime_tools/src/dyntrace.erl +++ b/lib/runtime_tools/src/dyntrace.erl @@ -41,6 +41,28 @@ pn/1, pn/2, pn/3, pn/4, pn/5, pn/6, pn/7, pn/8, pn/9]). -export([put_tag/1, get_tag/0, get_tag_data/0, spread_tag/1, restore_tag/1]). +-export([trace/5, + trace/6, + trace_procs/6, + trace_ports/6, + trace_running_procs/6, + trace_running_ports/6, + trace_call/6, + trace_send/6, + trace_receive/6, + trace_garbage_collection/6]). + +-export([enabled_procs/3, + enabled_ports/3, + enabled_running_procs/3, + enabled_running_ports/3, + enabled_call/3, + enabled_send/3, + enabled_receive/3, + enabled_garbage_collection/3, + enabled/3]). + + -export([user_trace_i4s4/9]). % Know what you're doing! -on_load(on_load/0). @@ -125,6 +147,63 @@ user_trace_i4s4(_, _, _, _, _, _, _, _, _) -> user_trace_n(_, _, _, _, _, _, _, _, _, _) -> erlang:nif_error(nif_not_loaded). +trace(_TracerState, _Label, _SeqTraceInfo, _, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_procs(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_ports(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_running_procs(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_running_ports(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_call(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_send(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_receive(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +trace_garbage_collection(_TraceTag, _TracerState, _Tracee, _FirstTraceTerm, _SecondTraceTerm, _Opts) -> + erlang:nif_error(nif_not_loaded). + +enabled(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_procs(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_ports(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_running_procs(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_running_ports(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_call(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_send(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_receive(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + +enabled_garbage_collection(_TraceTag, _TracerState, _Tracee) -> + erlang:nif_error(nif_not_loaded). + %%% %%% Erlang support functions %%% diff --git a/lib/runtime_tools/test/Makefile b/lib/runtime_tools/test/Makefile index 432a361468..61377ea09e 100644 --- a/lib/runtime_tools/test/Makefile +++ b/lib/runtime_tools/test/Makefile @@ -4,6 +4,7 @@ include $(ERL_TOP)/make/$(TARGET)/otp.mk MODULES = \ dyntrace_SUITE \ + dyntrace_lttng_SUITE \ runtime_tools_SUITE \ system_information_SUITE \ dbg_SUITE \ diff --git a/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl b/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl new file mode 100644 index 0000000000..e6c147b003 --- /dev/null +++ b/lib/runtime_tools/test/dyntrace_lttng_SUITE.erl @@ -0,0 +1,377 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2012-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(dyntrace_lttng_SUITE). +-include_lib("common_test/include/ct.hrl"). + +-export([all/0, suite/0]). +-export([init_per_suite/1, end_per_suite/1]). +-export([init_per_testcase/2, end_per_testcase/2]). + +%% Test cases +-export([t_lttng_list/1, + t_procs/1, + t_ports/1, + t_running_process/1, + t_running_port/1, + t_call/1, + t_call_return_to/1, + t_call_silent/1, + t_send/1, + t_receive/1, + t_garbage_collection/1, + t_all/1]). + +suite() -> + [{ct_hooks,[ts_install_cth]}, + {timetrap, {seconds, 10}}]. + +all() -> + [t_lttng_list, + t_procs, + t_ports, + t_running_process, + t_running_port, + t_call, + t_call_return_to, + t_call_silent, + t_send, + t_receive, + t_garbage_collection, + t_all]. + + +init_per_suite(Config) -> + case erlang:system_info(dynamic_trace) of + lttng -> + ensure_lttng_stopped("--all"), + Config; + _ -> + {skip, "No LTTng configured on system."} + end. + +end_per_suite(_Config) -> + ensure_lttng_stopped("--all"), + ok. + +init_per_testcase(Case, Config) -> + %% ensure loaded + _ = dyntrace:module_info(), + Name = atom_to_list(Case), + ok = ensure_lttng_started(Name, Config), + [{session, Name}|Config]. + +end_per_testcase(Case, _Config) -> + Name = atom_to_list(Case), + ok = ensure_lttng_stopped(Name), + ok. + +%% tracepoints +%% +%% com_ericsson_dyntrace:gc_major_end +%% com_ericsson_dyntrace:gc_major_start +%% com_ericsson_dyntrace:gc_minor_end +%% com_ericsson_dyntrace:gc_minor_start +%% com_ericsson_dyntrace:message_receive +%% com_ericsson_dyntrace:message_send +%% -com_ericsson_dyntrace:message_queued +%% com_ericsson_dyntrace:function_exception +%% com_ericsson_dyntrace:function_return +%% com_ericsson_dyntrace:function_call +%% com_ericsson_dyntrace:port_link +%% com_ericsson_dyntrace:port_exit +%% com_ericsson_dyntrace:port_open +%% com_ericsson_dyntrace:port_scheduled +%% com_ericsson_dyntrace:process_scheduled +%% com_ericsson_dyntrace:process_register +%% com_ericsson_dyntrace:process_exit +%% com_ericsson_dyntrace:process_link +%% com_ericsson_dyntrace:process_spawn +%% +%% Testcases +%% + +t_lttng_list(_Config) -> + {ok, _} = cmd("lttng list -u"), + ok. + +t_procs(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:process_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},procs]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(1000), + + _ = erlang:trace(all, false, [procs]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:process_spawn", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_register", Res), + ok. + +t_ports(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:port_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},ports]), + + _ = os:cmd("ls"), + + _ = erlang:trace(all, false, [{tracer, dyntrace, []},ports]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:port_open", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_exit", Res), + ok. + +t_running_process(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:process_scheduled", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},running]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(1000), + + _ = erlang:trace(all, false, [running]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:process_scheduled", Res), + ok. + +t_running_port(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:port_scheduled", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},running_ports]), + + _ = os:cmd("ls"), + _ = os:cmd("ls"), + + _ = erlang:trace(all, false, [running_ports]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:port_scheduled", Res), + ok. + + +t_call(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, [{'_',[],[{exception_trace}]}], [local]), + + DontLink = spawn(fun() -> foo_clause_exception(nope) end), + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + + timer:sleep(10), + undefined = erlang:process_info(DontLink), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + ok = check_tracepoint("com_ericsson_dyntrace:function_return", Res), + ok = check_tracepoint("com_ericsson_dyntrace:function_exception", Res), + ok. + +t_send(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:message_send", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},send]), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + _ = os:cmd("ls"), + timer:sleep(10), + + _ = erlang:trace(all, false, [send]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:message_send", Res), + ok. + +t_call_return_to(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call, return_to]), + _ = erlang:trace_pattern({lists, '_', '_'}, true, [local]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, true, [local]), + + Pid = spawn_link(fun() -> gcfier(10) end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace_pattern({lists, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call,return_to]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + ok. + +t_call_silent(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:function_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []}, call, silent]), + _ = erlang:trace_pattern({?MODULE, '_', '_'}, [{'_',[],[{exception_trace}]}], [local]), + + DontLink = spawn(fun() -> foo_clause_exception(nope) end), + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + + timer:sleep(10), + undefined = erlang:process_info(DontLink), + + _ = erlang:trace_pattern({?MODULE, '_', '_'}, false, [local]), + _ = erlang:trace(all, false, [call]), + Res = lttng_stop_and_view(Config), + notfound = check_tracepoint("com_ericsson_dyntrace:function_call", Res), + notfound = check_tracepoint("com_ericsson_dyntrace:function_return", Res), + notfound = check_tracepoint("com_ericsson_dyntrace:function_exception", Res), + ok. + + +t_receive(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:message_receive", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},'receive']), + + Pid = spawn_link(fun() -> waiter() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + _ = erlang:trace(all, false, ['receive']), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:message_receive", Res), + ok. + +t_garbage_collection(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:gc_*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},garbage_collection]), + + Pid = spawn_link(fun() -> gcfier() end), + Pid ! {self(), ok}, + ok = receive {Pid,ok} -> ok end, + timer:sleep(10), + _ = erlang:trace(all, false, [garbage_collection]), + Res = lttng_stop_and_view(Config), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_end", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_end", Res), + ok. + +t_all(Config) when is_list(Config) -> + ok = lttng_start_event("com_ericsson_dyntrace:*", Config), + _ = erlang:trace(new, true, [{tracer, dyntrace, []},all]), + + Pid1 = spawn_link(fun() -> waiter() end), + Pid1 ! {self(), ok}, + ok = receive {Pid1,ok} -> ok end, + + Pid2 = spawn_link(fun() -> gcfier() end), + Pid2 ! {self(), ok}, + ok = receive {Pid2,ok} -> ok end, + _ = os:cmd("ls"), + _ = os:cmd("ls"), + timer:sleep(10), + + _ = erlang:trace(all, false, [all]), + Res = lttng_stop_and_view(Config), + + ok = check_tracepoint("com_ericsson_dyntrace:process_spawn", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_register", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_open", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_link", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_exit", Res), + ok = check_tracepoint("com_ericsson_dyntrace:process_scheduled", Res), + ok = check_tracepoint("com_ericsson_dyntrace:port_scheduled", Res), + ok = check_tracepoint("com_ericsson_dyntrace:message_send", Res), + ok = check_tracepoint("com_ericsson_dyntrace:message_receive", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_major_end", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_start", Res), + ok = check_tracepoint("com_ericsson_dyntrace:gc_minor_end", Res), + ok. + + +%% aux + +gcfier() -> + gcfier(10000). +gcfier(N) -> + receive + {Pid, ok} -> + _ = lists:reverse(lists:seq(1,N)), + true = erlang:garbage_collect(), + Pid ! {self(), ok} + end. + + +waiter() -> + true = register(?MODULE, self()), + receive + {Pid, ok} -> + Child = spawn(fun() -> receive ok -> ok end end), + link(Child), + unlink(Child), + _ = lists:seq(1,1000), + Child ! ok, + true = unregister(?MODULE), + Pid ! {self(),ok} + end. + +foo_clause_exception({1,2}) -> badness. + +%% lttng +lttng_stop_and_view(Config) -> + Path = proplists:get_value(priv_dir, Config), + Name = proplists:get_value(session, Config), + {ok,_} = cmd("lttng stop " ++ Name), + {ok,Res} = cmd("lttng view " ++ Name ++ " --trace-path=" ++ Path), + Res. + +check_tracepoint(TP, Data) -> + case re:run(Data, TP, [global]) of + {match, _} -> ok; + _ -> notfound + end. + +lttng_start_event(Event, Config) -> + Name = proplists:get_value(session, Config), + {ok, _} = cmd("lttng enable-event -u " ++ Event ++ " --session=" ++ Name), + {ok, _} = cmd("lttng start " ++ Name), + ok. + +ensure_lttng_started(Name, Config) -> + Out = case proplists:get_value(priv_dir, Config) of + undefined -> []; + Path -> "--output="++Path++" " + end, + {ok,_} = cmd("lttng create " ++ Out ++ Name), + ok. + +ensure_lttng_stopped(Name) -> + {ok,_} = cmd("lttng stop"), + {ok,_} = cmd("lttng destroy " ++ Name), + ok. + +cmd(Cmd) -> + io:format("<< ~ts~n", [Cmd]), + Res = os:cmd(Cmd), + io:format(">> ~ts~n", [Res]), + {ok,Res}. diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl index f9da748fef..b21eedc625 100644 --- a/lib/tools/src/fprof.erl +++ b/lib/tools/src/fprof.erl @@ -1629,15 +1629,24 @@ trace_handler({trace_ts, Pid, in, {_M, _F, Args} = MFArgs, TS} = Trace, TS; %% %% gc_start -trace_handler({trace_ts, Pid, gc_start, _Func, TS} = Trace, - Table, _, Dump) -> +trace_handler({trace_ts, Pid, gc_minor_start, _Func, TS} = Trace, Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_start(Table, Pid, TS), + TS; + +trace_handler({trace_ts, Pid, gc_major_start, _Func, TS} = Trace, Table, _, Dump) -> dump_stack(Dump, get(Pid), Trace), trace_gc_start(Table, Pid, TS), TS; + %% %% gc_end -trace_handler({trace_ts, Pid, gc_end, _Func, TS} = Trace, - Table, _, Dump) -> +trace_handler({trace_ts, Pid, gc_minor_end, _Func, TS} = Trace, Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_end(Table, Pid, TS), + TS; + +trace_handler({trace_ts, Pid, gc_major_end, _Func, TS} = Trace, Table, _, Dump) -> dump_stack(Dump, get(Pid), Trace), trace_gc_end(Table, Pid, TS), TS; diff --git a/lib/tools/test/fprof_SUITE.erl b/lib/tools/test/fprof_SUITE.erl index e18d384b52..affb45b7a6 100644 --- a/lib/tools/test/fprof_SUITE.erl +++ b/lib/tools/test/fprof_SUITE.erl @@ -949,8 +949,8 @@ handle_trace({trace_ts,Pid,return_to,MFA,TS},P) -> end, put({Pid,last_ts},TS), P; -handle_trace({trace_ts,Pid,gc_start,_,TS},P) -> - ?dbg("~p",[{{gc_start,Pid},get(Pid)}]), +handle_trace({trace_ts,Pid,gc_minor_start,_,TS},P) -> + ?dbg("~p",[{{gc_minor_start,Pid},get(Pid)}]), case get(Pid) of [suspend|_] = Stack -> T = ts_sub(TS,get({Pid,last_ts})), @@ -970,8 +970,40 @@ handle_trace({trace_ts,Pid,gc_start,_,TS},P) -> end, put({Pid,last_ts},TS), P; -handle_trace({trace_ts,Pid,gc_end,_,TS},P) -> - ?dbg("~p",[{{gc_end,Pid},get(Pid)}]), +handle_trace({trace_ts,Pid,gc_major_start,_,TS},P) -> + ?dbg("~p",[{{gc_minor_start,Pid},get(Pid)}]), + case get(Pid) of + [suspend|_] = Stack -> + T = ts_sub(TS,get({Pid,last_ts})), + insert(Pid,garbage_collect), + update_acc(Pid,Stack,T), + put(Pid,[garbage_collect|Stack]); + [CallingMFA|_] = Stack -> + T = ts_sub(TS,get({Pid,last_ts})), + insert(Pid,garbage_collect), + update_own(Pid,CallingMFA,T), + update_acc(Pid,Stack,T), + put(Pid,[garbage_collect|Stack]); + undefined -> + put(first_ts,TS), + put(Pid,[garbage_collect]), + insert(Pid,garbage_collect) + end, + put({Pid,last_ts},TS), + P; +handle_trace({trace_ts,Pid,gc_minor_end,_,TS},P) -> + ?dbg("~p",[{{gc_minor_end,Pid},get(Pid)}]), + T = ts_sub(TS,get({Pid,last_ts})), + case get(Pid) of + [garbage_collect|RestOfStack] = Stack -> + update_own(Pid,garbage_collect,T), + update_acc(Pid,Stack,T), + put(Pid,RestOfStack) + end, + put({Pid,last_ts},TS), + P; +handle_trace({trace_ts,Pid,gc_major_end,_,TS},P) -> + ?dbg("~p",[{{gc_major_end,Pid},get(Pid)}]), T = ts_sub(TS,get({Pid,last_ts})), case get(Pid) of [garbage_collect|RestOfStack] = Stack -> |