Implement process_info(Pid, current_{location,stacktrace})

3 files changed, 216 insertions, 32 deletions

diff --git a/erts/emulator/beam/atom.names b/erts/emulator/beam/atom.names
index 68d64fb7b0..e7308dbf43 100644
--- a/erts/emulator/beam/atom.names
+++ b/erts/emulator/beam/atom.names
@@ -156,6 +156,8 @@ atom cr
 atom crlf
 atom creation
 atom current_function
+atom current_location
+atom current_stacktrace
 atom data
 atom debug_flags
 atom delay_trap
diff --git a/erts/emulator/beam/erl_bif_info.c b/erts/emulator/beam/erl_bif_info.c
index 6a74596f76..e17325b64f 100644
--- a/erts/emulator/beam/erl_bif_info.c
+++ b/erts/emulator/beam/erl_bif_info.c
@@ -120,6 +120,10 @@ static char erts_system_version[] = ("Erlang " ERLANG_OTP_RELEASE
 #endif
 
 static Eterm
+current_function(Process* p, Process* rp, Eterm** hpp, int full_info);
+static Eterm current_stacktrace(Process* p, Process* rp, Eterm** hpp);
+
+static Eterm
 bld_bin_list(Uint **hpp, Uint *szp, ErlOffHeap* oh)
 {
     struct erl_off_heap_header* ohh;
@@ -554,6 +558,8 @@ static Eterm pi_args[] = {
     am_suspending,
     am_min_heap_size,
     am_min_bin_vheap_size,
+    am_current_location,
+    am_current_stacktrace,
 #ifdef HYBRID
     am_message_binary
 #endif
@@ -602,8 +608,10 @@ pi_arg2ix(Eterm arg)
     case am_suspending:				return 26;
     case am_min_heap_size:			return 27;
     case am_min_bin_vheap_size:			return 28;
+    case am_current_location:			return 29;
+    case am_current_stacktrace:			return 30;
 #ifdef HYBRID
-    case am_message_binary:			return 29;
+    case am_message_binary:			return 31;
 #endif
     default:					return -1;
     }
@@ -1006,35 +1014,15 @@ process_info_aux(Process *BIF_P,
 	break;
 
     case am_current_function:
-	if (rp->current == NULL) {
-	    rp->current = find_function_from_pc(rp->i);
-	}
-	if (rp->current == NULL) {
-	    hp = HAlloc(BIF_P, 3);
-	    res = am_undefined;
-	} else {
-	    BeamInstr* current;
-
-	    if (rp->current[0] == am_erlang &&
-		rp->current[1] == am_process_info &&
-		(rp->current[2] == 1 || rp->current[2] == 2) &&
-		(current = find_function_from_pc(rp->cp)) != NULL) {
-
-		/*
-		 * The current function is erlang:process_info/2,
-		 * which is not the answer that the application want.
-		 * We will use the function pointed into by rp->cp
-		 * instead.
-		 */
+	res = current_function(BIF_P, rp, &hp, 0);
+	break;
 
-		rp->current = current;
-	    }
+    case am_current_location:
+	res = current_function(BIF_P, rp, &hp, 1);
+	break;
 
-	    hp = HAlloc(BIF_P, 3+4);
-	    res = TUPLE3(hp, rp->current[0],
-			 rp->current[1], make_small(rp->current[2]));
-	    hp += 4;
-	}
+    case am_current_stacktrace:
+	res = current_stacktrace(BIF_P, rp, &hp);
 	break;
 
     case am_initial_call:
@@ -1608,6 +1596,113 @@ process_info_aux(Process *BIF_P,
 }
 #undef MI_INC
 
+static Eterm
+current_function(Process* BIF_P, Process* rp, Eterm** hpp, int full_info)
+{
+    Eterm* hp;
+    Eterm res;
+    FunctionInfo fi;
+
+    if (rp->current == NULL) {
+	erts_lookup_function_info(&fi, rp->i, full_info);
+	rp->current = fi.current;
+    } else if (full_info) {
+	erts_lookup_function_info(&fi, rp->i, full_info);
+	if (fi.current == NULL) {
+	    /* Use the current function without location info */
+	    erts_set_current_function(&fi, rp->current);
+	}
+    }
+
+    if (BIF_P->id == rp->id) {
+	FunctionInfo fi2;
+
+	/*
+	 * The current function is erlang:process_info/{1,2},
+	 * which is not the answer that the application want.
+	 * We will use the function pointed into by rp->cp
+	 * instead if it can be looked up.
+	 */
+	erts_lookup_function_info(&fi2, rp->cp, full_info);
+	if (fi2.current) {
+	    fi = fi2;
+	    rp->current = fi2.current;
+	}
+    }
+
+    /*
+     * Return the result.
+     */
+    if (rp->current == NULL) {
+	hp = HAlloc(BIF_P, 3);
+	res = am_undefined;
+    } else if (full_info) {
+	hp = HAlloc(BIF_P, 3+fi.needed);
+	hp = erts_build_mfa_item(&fi, hp, am_true, &res);
+    } else {
+	hp = HAlloc(BIF_P, 3+4);
+	res = TUPLE3(hp, rp->current[0],
+		     rp->current[1], make_small(rp->current[2]));
+	hp += 4;
+    }
+    *hpp = hp;
+    return res;
+}
+
+static Eterm
+current_stacktrace(Process* p, Process* rp, Eterm** hpp)
+{
+    Uint sz;
+    struct StackTrace* s;
+    int depth;
+    FunctionInfo* stk;
+    FunctionInfo* stkp;
+    Uint heap_size;
+    int i;
+    Eterm* hp = *hpp;
+    Eterm mfa;
+    Eterm res = NIL;
+
+    depth = 8;
+    sz = offsetof(struct StackTrace, trace) + sizeof(BeamInstr *)*depth;
+    s = (struct StackTrace *) erts_alloc(ERTS_ALC_T_TMP, sz);
+    s->depth = 0;
+    if (rp->i) {
+	s->trace[s->depth++] = rp->i;
+	depth--;
+    }
+    if (depth > 0 && rp->cp != 0) {
+	s->trace[s->depth++] = rp->cp - 1;
+	depth--;
+    }
+    erts_save_stacktrace(rp, s, depth);
+
+    depth = s->depth;
+    stk = stkp = (FunctionInfo *) erts_alloc(ERTS_ALC_T_TMP,
+					     depth*sizeof(FunctionInfo));
+    heap_size = 3;
+    for (i = 0; i < depth; i++) {
+	erts_lookup_function_info(stkp, s->trace[i], 1);
+	if (stkp->current) {
+	    heap_size += stkp->needed + 2;
+	    stkp++;
+	}
+    }
+
+    hp = HAlloc(p, heap_size);
+    while (stkp > stk) {
+	stkp--;
+	hp = erts_build_mfa_item(stkp, hp, am_true, &mfa);
+	res = CONS(hp, mfa, res);
+	hp += 2;
+    }
+
+    erts_free(ERTS_ALC_T_TMP, stk);
+    erts_free(ERTS_ALC_T_TMP, s);
+    *hpp = hp;
+    return res;
+}
+
 #if defined(VALGRIND)
 static int check_if_xml(void)
 {
diff --git a/erts/emulator/test/process_SUITE.erl b/erts/emulator/test/process_SUITE.erl
index 5641489f5c..fdc55a4cc5 100644
--- a/erts/emulator/test/process_SUITE.erl
+++ b/erts/emulator/test/process_SUITE.erl
@@ -35,7 +35,7 @@
 	 self_exit/1, normal_suicide_exit/1, abnormal_suicide_exit/1,
 	 t_exit_2_catch/1, trap_exit_badarg/1, trap_exit_badarg_in_bif/1,
 	 exit_and_timeout/1, exit_twice/1,
-	 t_process_info/1, process_info_other_msg/1,
+	 t_process_info/1, process_info_other/1, process_info_other_msg/1,
 	 process_info_other_dist_msg/1,
 	 process_info_2_list/1, process_info_lock_reschedule/1,
 	 process_info_lock_reschedule2/1,
@@ -64,7 +64,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}].
 all() -> 
     [spawn_with_binaries, t_exit_1, {group, t_exit_2},
      trap_exit_badarg, trap_exit_badarg_in_bif,
-     t_process_info, process_info_other_msg,
+     t_process_info, process_info_other, process_info_other_msg,
      process_info_other_dist_msg, process_info_2_list,
      process_info_lock_reschedule,
      process_info_lock_reschedule2,
@@ -412,7 +412,7 @@ etwice_high(Low) ->
     exit(Low, first),
     exit(Low, second).
 
-%% Tests the process_info/1 BIF.
+%% Tests the process_info/2 BIF.
 t_process_info(Config) when is_list(Config) ->
     ?line [] = process_info(self(), registered_name),
     ?line register(my_name, self()),
@@ -420,13 +420,100 @@ t_process_info(Config) when is_list(Config) ->
     ?line {status, running} = process_info(self(), status),
     ?line {min_heap_size, 233} = process_info(self(), min_heap_size),
     ?line {min_bin_vheap_size, 46368} = process_info(self(), min_bin_vheap_size),
-    ?line {current_function, {?MODULE, t_process_info, 1}} =
+    ?line {current_function,{?MODULE,t_process_info,1}} =
 	process_info(self(), current_function),
+    ?line {current_function,{?MODULE,t_process_info,1}} =
+	apply(erlang, process_info, [self(),current_function]),
+
+    %% current_location and current_stacktrace
+    {Line1,Res1} = {?LINE,process_info(self(), current_location)},
+    verify_loc(Line1, Res1),
+    {Line2,Res2} = {?LINE,apply(erlang, process_info,
+				[self(),current_location])},
+    verify_loc(Line2, Res2),
+    pi_stacktrace([{?MODULE,t_process_info,1,?LINE}]),
+
     ?line Gleader = group_leader(),
     ?line {group_leader, Gleader} = process_info(self(), group_leader),
     ?line {'EXIT',{badarg,_Info}} = (catch process_info('not_a_pid')),
     ok.
 
+pi_stacktrace(Expected0) ->
+    {Line,Res} = {?LINE,erlang:process_info(self(), current_stacktrace)},
+    {current_stacktrace,Stack} = Res,
+    Expected = [{?MODULE,pi_stacktrace,1,Line}|Expected0],
+    pi_stacktrace_1(Stack, Expected).
+
+pi_stacktrace_1([{M,F,A,Loc}|Stk], [{M,F,A,Line}|Exp]) ->
+    case Loc of
+	[] ->
+	    %% No location info for some reason (+L, native code).
+	    io:format("Missing location information for ~w:~w/~w",
+		      [M,F,A]),
+	    ok;
+	[_|_] ->
+	    Line = proplists:get_value(line, Loc),
+	    File = proplists:get_value(file, Loc),
+	    File = ?MODULE_STRING ++ ".erl"
+    end,
+    pi_stacktrace_1(Stk, Exp);
+pi_stacktrace_1([_|_], []) -> ok.
+
+verify_loc(Line, {current_location,{?MODULE,t_process_info=F,1=A,Loc}}) ->
+    case Loc of
+	[] ->
+	    %% No location info for some reason (+L, native code).
+	    io:format("Missing location information for ~w:~w/~w",
+		      [?MODULE,F,A]),
+	    ok;
+	[_|_] ->
+	    Line = proplists:get_value(line, Loc),
+	    File = proplists:get_value(file, Loc),
+	    File = ?MODULE_STRING ++ ".erl"
+    end.
+
+process_info_other(Config) when is_list(Config) ->
+    Self = self(),
+    Pid = spawn_link(fun() -> process_info_looper(Self) end),
+    receive after 1 -> ok end,
+    pio_current_location(10000, Pid, 0, 0),
+    pio_current_stacktrace().
+
+pio_current_location(0, _, Pi, Looper) ->
+    io:format("~w call(s) to erlang:process_info/2", [Pi]),
+    io:format("~w call(s) to ~w:process_info_looper/1", [Looper,?MODULE]);
+pio_current_location(N, Pid, Pi, Looper) ->
+    erlang:yield(),
+    {current_location,Where} = process_info(Pid, current_location),
+    case Where of
+	{erlang,process_info,2,[]} ->
+	    pio_current_location(N-1, Pid, Pi+1, Looper);
+	{?MODULE,process_info_looper,1,Loc} when is_list(Loc) ->
+	    pio_current_location(N-1, Pid, Pi, Looper+1)
+    end.
+
+pio_current_stacktrace() ->
+    L = [begin
+	     {current_stacktrace,Stk} = process_info(P, current_stacktrace),
+	     {P,Stk}
+	 end || P <- processes()],
+    [erlang:garbage_collect(P) || {P,_} <- L],
+    erlang:garbage_collect(),
+    [verify_stacktrace(Stk) || {_,Stk} <- L],
+    ok.
+
+verify_stacktrace([{M,F,A,Loc}|T])
+  when is_atom(M),
+       is_atom(F),
+       is_integer(A),
+       is_list(Loc) ->
+    verify_stacktrace(T);
+verify_stacktrace([]) -> ok.
+
+process_info_looper(Parent) ->
+    process_info(Parent, current_location),
+    process_info_looper(Parent).
+
 %% Tests the process_info/1 BIF on another process with messages.
 process_info_other_msg(Config) when is_list(Config) ->
     Self = self(),