[GR-2798] Fix: parent.frame(n) with n > 1 after do.call.

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/DoCall.java

@@ -168,7 +168,7 @@ public abstract class DoCall extends RBuiltinNode.Arg4 implements InternalRSynta
                 shareObjectNode.execute(argValues[i]);
             }
             ArgumentsSignature signature = getArgsNames(argsAsList);
-            RCaller caller = RCaller.create(virtualFrame, RCallerHelper.createFromArguments(func, new RArgsValuesAndNames(argValues, signature)));
+            RCaller caller = RCaller.createWithInternalParent(virtualFrame, RCallerHelper.createFromArguments(func, new RArgsValuesAndNames(argValues, signature)));
             try {
                 Object resultValue = RContext.getEngine().evalFunction(func, envFrame, caller, false, signature, argValues);
                 setVisibilityNode.execute(virtualFrame, getVisibility(envFrame));
@@ -246,7 +246,7 @@ public abstract class DoCall extends RBuiltinNode.Arg4 implements InternalRSynta
             }
             RLanguage lang = RDataFactory.createLanguage(RASTUtils.createCall(ConstantNode.create(function), true, argsSignature, argsConstants).asRNode());
             try {
-                Object resultValue = RContext.getEngine().eval(lang, env, call);
+                Object resultValue = RContext.getEngine().eval(lang, env, call.withInternalParent());
                 MaterializedFrame envFrame = env.getFrame();
                 FrameSlot envVisibilitySlot = FrameSlotChangeMonitor.findOrAddFrameSlot(envFrame.getFrameDescriptor(), RFrameSlot.Visibility, FrameSlotKind.Boolean);
                 boolean resultVisibility = false;

com.oracle.truffle.r.nodes.builtin/src/com/oracle/truffle/r/nodes/builtin/base/FrameFunctions.java

@@ -650,6 +650,8 @@ public class FrameFunctions {
         @Specialization(guards = "n == 1")
         protected REnvironment parentFrameDirect(VirtualFrame frame, @SuppressWarnings("unused") int n,
                         @Cached("new()") GetCallerFrameNode getCaller) {
+            // Note: this works even without checking the call#hasInternalParent()
+            // The environment in the arguments array is the right one even after 'do.call'.
             return REnvironment.frameToEnvironment(getCaller.execute(frame));
         }
 
@@ -663,7 +665,8 @@ public class FrameFunctions {
                 promiseProfile.enter();
                 call = call.getParent();
             }
-            for (int i = 0; i < n; i++) {
+            int i = 0;
+            while (i < n) {
                 call = call.getParent();
                 if (call == null) {
                     nullCallerProfile.enter();
@@ -673,6 +676,9 @@ public class FrameFunctions {
                     promiseProfile.enter();
                     call = call.getParent();
                 }
+                if (!call.hasInternalParent()) {
+                    i++;
+                }
             }
             nonNullCallerProfile.enter();
             // if (RArguments.getDispatchArgs(f) != null && RArguments.getDispatchArgs(f) instanceof

com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RCaller.java

 /*
- * Copyright (c) 2014, 2016, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2014, 2017, Oracle and/or its affiliates. All rights reserved.
  * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
  *
  * This code is free software; you can redistribute it and/or modify it
@@ -35,6 +35,13 @@ public final class RCaller {
 
     public static final RCaller topLevel = RCaller.createInvalid(null);
 
+    /**
+     * Determines the actual position of the corresponding frame on the execution call stack. When
+     * one follows the {@link RCaller#parent} chain, then the depth is not always decreasing by only
+     * one, the reason are promises, which may be evaluated somewhere deep down the call stack, but
+     * their parent call frame from R prespective could be much higher up the actual execution call
+     * stack.
+     */
     private final int depth;
     private boolean visibility;
     private final RCaller parent;
@@ -43,11 +50,20 @@ public final class RCaller {
      * promise evaluation frames).
      */
     private final Object payload;
+    /**
+     * Marks those callers whose parent should not be taken into account when iterating R level
+     * frames using e.g. {@code parent.frame()}. This is the case for function invoked through
+     * {@code do.call} -- R pretends that they were called by the caller of {@code do.call} so that
+     * code like {@code eval(formula, parent.frame(2))} gives the same results regardless of whether
+     * the function was invoked directly or through {@code do.call}.
+     */
+    private final boolean parentIsInternal;
 
-    private RCaller(Frame callingFrame, Object nodeOrSupplier) {
+    private RCaller(Frame callingFrame, Object nodeOrSupplier, boolean parentIsInternal) {
         this.depth = depthFromFrame(callingFrame);
         this.parent = parentFromFrame(callingFrame);
         this.payload = nodeOrSupplier;
+        this.parentIsInternal = parentIsInternal;
     }
 
     private static int depthFromFrame(Frame callingFrame) {
@@ -58,10 +74,15 @@ public final class RCaller {
         return callingFrame == null ? null : RArguments.getCall(callingFrame);
     }
 
-    private RCaller(int depth, RCaller parent, Object nodeOrSupplier) {
+    private RCaller(int depth, RCaller parent, Object nodeOrSupplier, boolean parentIsInternal) {
         this.depth = depth;
         this.parent = parent;
         this.payload = nodeOrSupplier;
+        this.parentIsInternal = parentIsInternal;
+    }
+
+    public RCaller withInternalParent() {
+        return new RCaller(depth, parent, payload, true);
     }
 
     public int getDepth() {
@@ -72,6 +93,10 @@ public final class RCaller {
         return parent;
     }
 
+    public boolean hasInternalParent() {
+        return parentIsInternal;
+    }
+
     public RSyntaxElement getSyntaxNode() {
         assert payload != null && !(payload instanceof RCaller) : payload == null ? "null RCaller" : "promise RCaller";
         return payload instanceof RSyntaxElement ? (RSyntaxElement) payload : (RSyntaxElement) ((Supplier<?>) payload).get();
@@ -90,37 +115,42 @@ public final class RCaller {
     }
 
     public static RCaller createInvalid(Frame callingFrame) {
-        return new RCaller(callingFrame, null);
+        return new RCaller(callingFrame, null, false);
     }
 
     public static RCaller createInvalid(Frame callingFrame, RCaller parent) {
-        return new RCaller(depthFromFrame(callingFrame), parent, null);
+        return new RCaller(depthFromFrame(callingFrame), parent, null, false);
     }
 
     public static RCaller create(Frame callingFrame, RSyntaxElement node) {
         assert node != null;
-        return new RCaller(callingFrame, node);
+        return new RCaller(callingFrame, node, false);
     }
 
     public static RCaller create(Frame callingFrame, RCaller parent, RSyntaxElement node) {
         assert node != null;
-        return new RCaller(depthFromFrame(callingFrame), parent, node);
+        return new RCaller(depthFromFrame(callingFrame), parent, node, false);
+    }
+
+    public static RCaller createWithInternalParent(Frame callingFrame, Supplier<RSyntaxElement> supplier) {
+        assert supplier != null;
+        return new RCaller(callingFrame, supplier, true);
     }
 
     public static RCaller create(Frame callingFrame, Supplier<RSyntaxElement> supplier) {
         assert supplier != null;
-        return new RCaller(callingFrame, supplier);
+        return new RCaller(callingFrame, supplier, false);
     }
 
     public static RCaller create(Frame callingFrame, RCaller parent, Supplier<RSyntaxElement> supplier) {
         assert supplier != null;
-        return new RCaller(depthFromFrame(callingFrame), parent, supplier);
+        return new RCaller(depthFromFrame(callingFrame), parent, supplier, false);
     }
 
     public static RCaller createForPromise(RCaller originalCaller, Frame frame) {
         int newDepth = frame == null ? 0 : RArguments.getDepth(frame);
         RCaller originalCall = frame == null ? null : RArguments.getCall(frame);
-        return new RCaller(newDepth, originalCaller, originalCall);
+        return new RCaller(newDepth, originalCaller, originalCall, false);
     }
 
     public boolean getVisibility() {

com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test

@@ -22328,6 +22328,18 @@ Error in (function (x)  : object 'foo' not found
 #v1 <- as.numeric_version('3.0.0'); v2 <- as.numeric_version('3.1.0'); do.call('<', list(v1, v2))
 [1] TRUE
+##com.oracle.truffle.r.test.builtins.TestBuiltin_docall.testDoCall#
+#{ boo <- function(c) ls(parent.frame(2)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(1,2)); bar() }
+[1] "x" "z"
+
+##com.oracle.truffle.r.test.builtins.TestBuiltin_docall.testDoCall#
+#{ boo <- function(c) ls(parent.frame(2)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(parse(text='goo()'),2)); bar() }
+[1] "x" "z"
+
+##com.oracle.truffle.r.test.builtins.TestBuiltin_docall.testDoCall#
+#{ boo <- function(c) ls(parent.frame(3)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(parse(text='goo()'),2)); baz <- function(bazX) bar(bazX,1); baz(); }
+[1] "bazX"
+
 ##com.oracle.truffle.r.test.builtins.TestBuiltin_docall.testDoCall#
 #{ do.call("+", list(quote(1), 2))}
 [1] 3

com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/builtins/TestBuiltin_docall.java

@@ -43,5 +43,9 @@ public class TestBuiltin_docall extends TestBase {
         assertEval("{ e <- new.env(); assign('foo', function() 42, e); foo <- function(x) 1; do.call('foo', list(), envir=e); }");
         assertEval("{ e <- new.env(); assign('foo', 42, e); foo <- function(x) 1; do.call('foo', list(), envir=e); }");
         assertEval("{ do.call('+', list(data.frame(1), data.frame(2)), envir = new.env()); do.call('assign', list('a',2,new.env()), envir = new.env()); }");
+
+        assertEval("{ boo <- function(c) ls(parent.frame(2)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(1,2)); bar() }");
+        assertEval("{ boo <- function(c) ls(parent.frame(2)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(parse(text='goo()'),2)); bar() }");
+        assertEval("{ boo <- function(c) ls(parent.frame(3)); foo <- function(a,b) boo(a); bar <- function(x,z) do.call('foo', list(parse(text='goo()'),2)); baz <- function(bazX) bar(bazX,1); baz(); }");
     }
 }