diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/ListMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/ListMR.java
index dea32fa8a3f9a1743c163456551db2ac378afd36..597b0fb89a05d4e8a8c5b713b0653bb31ea38b1a 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/ListMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/ListMR.java
@@ -43,20 +43,19 @@ import com.oracle.truffle.r.nodes.access.vector.ExtractVectorNode;
import com.oracle.truffle.r.nodes.access.vector.ReplaceVectorNode;
import com.oracle.truffle.r.nodes.attributes.SpecialAttributesFunctions.GetNamesAttributeNode;
import com.oracle.truffle.r.nodes.control.RLengthNode;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RDataFactory;
import com.oracle.truffle.r.runtime.data.RExpression;
import com.oracle.truffle.r.runtime.data.RFunction;
import com.oracle.truffle.r.runtime.data.RList;
import com.oracle.truffle.r.runtime.data.RLogical;
import com.oracle.truffle.r.runtime.data.RMissing;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.data.RPairList;
import com.oracle.truffle.r.runtime.data.RStringVector;
import com.oracle.truffle.r.runtime.interop.Foreign2R;
import com.oracle.truffle.r.runtime.interop.Foreign2RNodeGen;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
public class ListMR {
@@ -118,14 +117,21 @@ public class ListMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
@@ -209,14 +215,21 @@ public class ListMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(@SuppressWarnings("unused") Object receiver) {
+ return this;
}
}
@@ -294,14 +307,21 @@ public class ListMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RAbstractVectorAccessFactory.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RAbstractVectorAccessFactory.java
index 861b612fd87b813b7b9b1fef96bf9a9820aac3ab..01cd9584402d7bf649595a03ae2bbf787ebbddfa 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RAbstractVectorAccessFactory.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RAbstractVectorAccessFactory.java
@@ -53,8 +53,8 @@ import com.oracle.truffle.r.nodes.access.vector.ReplaceVectorNode;
import com.oracle.truffle.r.nodes.access.vector.ReplaceVectorNodeGen;
import com.oracle.truffle.r.nodes.control.RLengthNode;
import com.oracle.truffle.r.runtime.RRuntime;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RLogical;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.data.RRaw;
import com.oracle.truffle.r.runtime.data.RScalar;
import com.oracle.truffle.r.runtime.data.RString;
@@ -66,7 +66,6 @@ import com.oracle.truffle.r.runtime.interop.Foreign2R;
import com.oracle.truffle.r.runtime.interop.Foreign2RNodeGen;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
import com.oracle.truffle.r.runtime.nodes.RSyntaxNode;
abstract class InteropRootNode extends RootNode {
@@ -440,7 +439,17 @@ public final class RAbstractVectorAccessFactory implements StandardFactory {
return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
@Override
public Object execute(VirtualFrame frame) {
- return false;
+ return true;
+ }
+ });
+ }
+
+ @Override
+ public CallTarget accessAsPointer() {
+ return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
+ @Override
+ public Object execute(VirtualFrame frame) {
+ return NativeDataAccess.asPointer(ForeignAccess.getReceiver(frame));
}
});
}
@@ -451,7 +460,7 @@ public final class RAbstractVectorAccessFactory implements StandardFactory {
@Override
public Object execute(VirtualFrame frame) {
RAbstractVector arg = (RAbstractVector) ForeignAccess.getReceiver(frame);
- return new RObjectNativeWrapper((RObject) arg);
+ return arg;
}
});
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RArgsValuesAndNamesMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RArgsValuesAndNamesMR.java
index 52b9d2636698d879c7f605c9f2c7f098bd073ea9..f9c65193529f6b9c9212a6c26c872935fde9bf4d 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RArgsValuesAndNamesMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RArgsValuesAndNamesMR.java
@@ -36,13 +36,12 @@ import com.oracle.truffle.api.profiles.ConditionProfile;
import com.oracle.truffle.r.engine.interop.RArgsValuesAndNamesMRFactory.RArgsValuesAndNamesKeyInfoImplNodeGen;
import com.oracle.truffle.r.engine.interop.RArgsValuesAndNamesMRFactory.RArgsValuesAndNamesReadImplNodeGen;
import com.oracle.truffle.r.runtime.ArgumentsSignature;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RArgsValuesAndNames;
import com.oracle.truffle.r.runtime.data.RDataFactory;
import com.oracle.truffle.r.runtime.data.RFunction;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RArgsValuesAndNames.class)
public class RArgsValuesAndNamesMR {
@@ -94,14 +93,21 @@ public class RArgsValuesAndNamesMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RConnectionMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RConnectionMR.java
index d2706ca4b87634fb7da3ee5b954f411c857b3639..f80d4cfe788c91c117dfce6a483732a3d20dc6ce 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RConnectionMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RConnectionMR.java
@@ -28,8 +28,7 @@ import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.r.runtime.conn.RConnection;
-import com.oracle.truffle.r.runtime.data.RObject;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
@MessageResolution(receiverType = RConnection.class)
public class RConnectionMR {
@@ -44,14 +43,21 @@ public class RConnectionMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REmptyMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REmptyMR.java
index 710401c2f7fbfc6345f23845e2ff55c2699a295d..75e9a09dc121915abda1ceae29a1444386683b15 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REmptyMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REmptyMR.java
@@ -27,9 +27,8 @@ import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.REmpty;
-import com.oracle.truffle.r.runtime.data.RObject;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = REmpty.class)
public class REmptyMR {
@@ -44,14 +43,21 @@ public class REmptyMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REnvironmentMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REnvironmentMR.java
index 6edfbf12fd5bd6e529f21fe0515fcedf80fe1dc5..709988c5c6a8cfd1b9b4b5de5112e7a6b5f7cc68 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REnvironmentMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/REnvironmentMR.java
@@ -46,14 +46,13 @@ import com.oracle.truffle.r.nodes.access.vector.ElementAccessMode;
import com.oracle.truffle.r.nodes.access.vector.ExtractVectorNode;
import com.oracle.truffle.r.nodes.access.vector.ReplaceVectorNode;
import com.oracle.truffle.r.nodes.builtin.base.Rm;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RFunction;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.env.REnvironment;
import com.oracle.truffle.r.runtime.interop.Foreign2R;
import com.oracle.truffle.r.runtime.interop.Foreign2RNodeGen;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = REnvironment.class)
public class REnvironmentMR {
@@ -105,14 +104,21 @@ public class REnvironmentMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RExternalPtrMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RExternalPtrMR.java
index 52168a3592858a9ff80a0f0db711603370710f89..19932c04b7d5cc362cfb89c9f2288673cbe955c2 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RExternalPtrMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RExternalPtrMR.java
@@ -27,9 +27,8 @@ import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RExternalPtr;
-import com.oracle.truffle.r.runtime.data.RObject;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RExternalPtr.class)
public class RExternalPtrMR {
@@ -44,14 +43,21 @@ public class RExternalPtrMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RFunctionMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RFunctionMR.java
index 3b10c608697912f67cf224090f6b7c855b9f76cf..c654f1584368d62baf17870f8a64d11f6432db08 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RFunctionMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RFunctionMR.java
@@ -22,9 +22,6 @@
*/
package com.oracle.truffle.r.engine.interop;
-import com.oracle.truffle.api.frame.FrameDescriptor;
-import com.oracle.truffle.api.frame.FrameSlot;
-import com.oracle.truffle.api.frame.FrameSlotKind;
import com.oracle.truffle.api.frame.MaterializedFrame;
import com.oracle.truffle.api.interop.CanResolve;
import com.oracle.truffle.api.interop.MessageResolution;
@@ -34,16 +31,13 @@ import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.r.nodes.function.call.RExplicitCallNode;
import com.oracle.truffle.r.runtime.ArgumentsSignature;
import com.oracle.truffle.r.runtime.context.RContext;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RArgsValuesAndNames;
import com.oracle.truffle.r.runtime.data.RFunction;
-import com.oracle.truffle.r.runtime.data.RObject;
-import com.oracle.truffle.r.runtime.env.frame.FrameSlotChangeMonitor;
-import com.oracle.truffle.r.runtime.env.frame.RFrameSlot;
import com.oracle.truffle.r.runtime.interop.Foreign2R;
import com.oracle.truffle.r.runtime.interop.Foreign2RNodeGen;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RFunction.class)
public class RFunctionMR {
@@ -83,14 +77,21 @@ public class RFunctionMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RMissingMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RMissingMR.java
index 26e2e9199ac65030c363d741e566e49b2e43db68..ac39305be2414ab8c013c245d30905b43820ae9f 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RMissingMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RMissingMR.java
@@ -27,8 +27,8 @@ import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RMissing;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RMissing.class)
public class RMissingMR {
@@ -43,14 +43,21 @@ public class RMissingMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RMissing receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RNullMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RNullMR.java
index 4c7eb21434b73362e0b05dec8b3e6abca1c8f002..f58095f11119bc164fe6a811ce80b5dd704d9285 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RNullMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RNullMR.java
@@ -28,9 +28,9 @@ import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.r.runtime.context.RContext;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RNull;
import com.oracle.truffle.r.runtime.interop.RNullMRContextState;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RNull.class)
public class RNullMR {
@@ -49,17 +49,24 @@ public class RNullMR {
}
}
- @Resolve(message = "TO_NATIVE")
- public abstract static class RNullToNativeNode extends Node {
- protected Object access(RNull receiver) {
- return new RObjectNativeWrapper(receiver);
- }
- }
-
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
+ }
+ }
+
+ @Resolve(message = "TO_NATIVE")
+ public abstract static class ToNativeNode extends Node {
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RPromiseMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RPromiseMR.java
index adbad54d33b67d089e2c580be7af6b1b5ebb19ee..af76bba4e6beb50a5841d528dcdbaa268ae24eb9 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RPromiseMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RPromiseMR.java
@@ -38,11 +38,10 @@ import com.oracle.truffle.r.engine.interop.RPromiseMRFactory.RPromiseReadImplNod
import com.oracle.truffle.r.engine.interop.RPromiseMRFactory.RPromiseWriteImplNodeGen;
import com.oracle.truffle.r.nodes.function.PromiseHelperNode;
import com.oracle.truffle.r.runtime.RRuntime;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RDataFactory;
import com.oracle.truffle.r.runtime.data.RNull;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.data.RPromise;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RPromise.class)
public class RPromiseMR {
@@ -90,14 +89,21 @@ public class RPromiseMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RS4ObjectMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RS4ObjectMR.java
index 61c3cc7e0ade17bfdfa2d2177a2df3f4b6cce75e..3b9f6cdd3949a799984ba88a28ee7415c14c031e 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RS4ObjectMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RS4ObjectMR.java
@@ -42,18 +42,17 @@ import com.oracle.truffle.r.engine.interop.RS4ObjectMRFactory.RS4ObjectWriteImpl
import com.oracle.truffle.r.nodes.attributes.ArrayAttributeNode;
import com.oracle.truffle.r.nodes.attributes.GetAttributeNode;
import com.oracle.truffle.r.nodes.attributes.SetAttributeNode;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RAttributesLayout.RAttribute;
import com.oracle.truffle.r.runtime.data.RDataFactory;
import com.oracle.truffle.r.runtime.data.RFunction;
import com.oracle.truffle.r.runtime.data.RNull;
-import com.oracle.truffle.r.runtime.data.RObject;
import com.oracle.truffle.r.runtime.data.RS4Object;
import com.oracle.truffle.r.runtime.data.model.RAbstractStringVector;
import com.oracle.truffle.r.runtime.interop.Foreign2R;
import com.oracle.truffle.r.runtime.interop.Foreign2RNodeGen;
import com.oracle.truffle.r.runtime.interop.R2Foreign;
import com.oracle.truffle.r.runtime.interop.R2ForeignNodeGen;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RS4Object.class)
public class RS4ObjectMR {
@@ -106,14 +105,21 @@ public class RS4ObjectMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RSymbolMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RSymbolMR.java
index 3b142b2b7ce51a43b9c1680e7819534cccbc5c92..43802f19e2e7976fba39813564a7f0ffa19ffc43 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RSymbolMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RSymbolMR.java
@@ -27,9 +27,8 @@ import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
-import com.oracle.truffle.r.runtime.data.RObject;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RSymbol;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RSymbol.class)
public class RSymbolMR {
@@ -44,14 +43,21 @@ public class RSymbolMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RUnboundValueMR.java b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RUnboundValueMR.java
index a1f00d9e841c456cb23aa396247531105f14d3c6..e0cd1d649b96f966cf554b1ff952722e884bb689 100644
--- a/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RUnboundValueMR.java
+++ b/com.oracle.truffle.r.engine/src/com/oracle/truffle/r/engine/interop/RUnboundValueMR.java
@@ -27,8 +27,8 @@ import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.data.RUnboundValue;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = RUnboundValue.class)
public class RUnboundValueMR {
@@ -43,14 +43,21 @@ public class RUnboundValueMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RUnboundValue receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/interop/DLLInfoMR.java b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/interop/DLLInfoMR.java
index 3b3a2c2a6c5e9b6081e162aa4d7e5b05c5f65c19..317dc023e4c7263b3fba7f3fb41449a3cf4d3701 100644
--- a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/interop/DLLInfoMR.java
+++ b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/interop/DLLInfoMR.java
@@ -28,10 +28,10 @@ import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.r.runtime.data.CharSXPWrapper;
+import com.oracle.truffle.r.runtime.data.NativeDataAccess;
import com.oracle.truffle.r.runtime.ffi.DLL;
-import com.oracle.truffle.r.runtime.ffi.VectorRFFIWrapper;
import com.oracle.truffle.r.runtime.ffi.DLL.DLLInfo;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
+import com.oracle.truffle.r.runtime.ffi.VectorRFFIWrapper;
@MessageResolution(receiverType = DLL.DLLInfo.class)
public class DLLInfoMR {
@@ -43,10 +43,24 @@ public class DLLInfoMR {
}
}
- @Resolve(message = "TO_NATIVE")
+ @Resolve(message = "IS_POINTER")
+ public abstract static class IsPointerNode extends Node {
+ protected boolean access(@SuppressWarnings("unused") Object receiver) {
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
public abstract static class AsPointerNode extends Node {
protected Object access(Object receiver) {
- return new RObjectNativeWrapper((DLLInfo) receiver);
+ return NativeDataAccess.asPointer(receiver);
+ }
+ }
+
+ @Resolve(message = "TO_NATIVE")
+ public abstract static class ToNativeNode extends Node {
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Call.java b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Call.java
index 04959b0f5f1f5c55d08296d4684223169407222c..c17fb6761be96c5c7582d143c055340d60ba8e5a 100644
--- a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Call.java
+++ b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Call.java
@@ -63,7 +63,7 @@ final class TruffleLLVM_Call implements CallRFFI {
private final TruffleLLVM_UpCallsRFFIImpl upCallsRFFIImpl = new TruffleLLVM_UpCallsRFFIImpl();
private RContext context;
private boolean initVarsDone;
- private TruffleObject callbacksAddress;
+ private TruffleObject setCallbacksAddress;
private TruffleObject callbacks;
@Override
@@ -95,13 +95,11 @@ final class TruffleLLVM_Call implements CallRFFI {
callbacks = (TruffleObject) context.getEnv().asGuestValue(callbacksArray);
- Node executeNode = Message.createExecute(0).createNode();
- SymbolHandle symbolHandle = new SymbolHandle(context.getEnv().importSymbol("@" + "Rinternals_getCallbacksAddress"));
-
- callbacksAddress = (TruffleObject) ForeignAccess.sendExecute(executeNode, symbolHandle.asTruffleObject());
+ Node setClbkAddrExecuteNode = Message.createExecute(1).createNode();
+ SymbolHandle setClbkAddrSymbolHandle = new SymbolHandle(context.getEnv().importSymbol("@" + "Rinternals_setCallbacksAddress"));
+ setCallbacksAddress = setClbkAddrSymbolHandle.asTruffleObject();
// Initialize the callbacks global variable
- ForeignAccess.sendWrite(Message.WRITE.createNode(), callbacksAddress, 0, context.getEnv().asGuestValue(new TruffleObject[0]));
-
+ ForeignAccess.sendExecute(setClbkAddrExecuteNode, setCallbacksAddress, context.getEnv().asGuestValue(new TruffleObject[0]));
} catch (InteropException ex) {
throw RInternalError.shouldNotReachHere(ex);
}
@@ -219,7 +217,7 @@ final class TruffleLLVM_Call implements CallRFFI {
@Override
public Object dispatch(NativeCallInfo nativeCallInfo, Object[] args) {
TruffleLLVM_Context rffiCtx = TruffleLLVM_Context.getContextState();
- pushCallbacks.execute(rffiCtx.callState.callbacksAddress, rffiCtx.callState.callbacks);
+ pushCallbacks.execute(rffiCtx.callState.setCallbacksAddress, rffiCtx.callState.callbacks);
try {
return InvokeCallNode.super.dispatch(nativeCallInfo, args);
} finally {
@@ -316,11 +314,11 @@ final class TruffleLLVM_Call implements CallRFFI {
public static final class PushCallbacksNode extends Node {
@Child private Node readPreviousCallbacks = Message.READ.createNode();
- @Child private Node setCallbacks = Message.WRITE.createNode();
+ @Child private Node setCallbacksNode = Message.createExecute(1).createNode();
- public void execute(TruffleObject callbacksAddress, TruffleObject callbacks) {
+ public void execute(TruffleObject setCallbacksAddress, TruffleObject callbacks) {
try {
- ForeignAccess.sendWrite(setCallbacks, callbacksAddress, 0, callbacks);
+ ForeignAccess.sendExecute(setCallbacksNode, setCallbacksAddress, callbacks);
} catch (InteropException ex) {
throw RInternalError.shouldNotReachHere(ex);
}
diff --git a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Context.java b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Context.java
index 109ac52c228f9b58b8bf281e0ed7c105bd10c8df..2657178aac9b998e8e7fc9aabbf7843fde58cb09 100644
--- a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Context.java
+++ b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_Context.java
@@ -22,12 +22,16 @@
*/
package com.oracle.truffle.r.ffi.impl.llvm;
+import java.nio.file.FileSystems;
+
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.r.ffi.impl.common.LibPaths;
+import com.oracle.truffle.r.runtime.REnvVars;
import com.oracle.truffle.r.runtime.context.RContext;
import com.oracle.truffle.r.runtime.context.RContext.ContextState;
import com.oracle.truffle.r.runtime.ffi.BaseRFFI;
import com.oracle.truffle.r.runtime.ffi.DLL;
+import com.oracle.truffle.r.runtime.ffi.DLLRFFI;
import com.oracle.truffle.r.runtime.ffi.LapackRFFI;
import com.oracle.truffle.r.runtime.ffi.MiscRFFI;
import com.oracle.truffle.r.runtime.ffi.NativeFunction;
@@ -64,10 +68,16 @@ final class TruffleLLVM_Context extends RFFIContext {
@Override
public ContextState initialize(RContext context) {
+
+ // Load the f2c runtime library
+ String libf2cPath = FileSystems.getDefault().getPath(REnvVars.rHome(), "lib", "libf2c.so").toString();
+ DLLRFFI.DLOpenRootNode.create(context).call(libf2cPath, false, false);
+
if (context.isInitial()) {
String librffiPath = LibPaths.getBuiltinLibPath("R");
DLL.loadLibR(context, librffiPath);
}
+
dllState.initialize(context);
callState.initialize(context);
return this;
diff --git a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_DownCallNodeFactory.java b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_DownCallNodeFactory.java
index 01a04277121b7c6373ee01efa1aaf77774eda6bc..905e78c7c47a1a5b4f0e9c65e473fddd43225983 100644
--- a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_DownCallNodeFactory.java
+++ b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/TruffleLLVM_DownCallNodeFactory.java
@@ -26,10 +26,15 @@ import static com.oracle.truffle.r.runtime.ffi.NativeFunction.anyLibrary;
import java.nio.charset.StandardCharsets;
+import com.oracle.truffle.api.CallTarget;
import com.oracle.truffle.api.CompilerAsserts;
+import com.oracle.truffle.api.Truffle;
import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
+import com.oracle.truffle.api.interop.ForeignAccess;
import com.oracle.truffle.api.interop.TruffleObject;
+import com.oracle.truffle.api.interop.ForeignAccess.StandardFactory;
import com.oracle.truffle.api.nodes.ExplodeLoop;
+import com.oracle.truffle.api.nodes.RootNode;
import com.oracle.truffle.r.runtime.RInternalError;
import com.oracle.truffle.r.runtime.data.RFunction;
import com.oracle.truffle.r.runtime.ffi.DLL;
@@ -55,6 +60,10 @@ final class TruffleLLVM_DownCallNodeFactory extends DownCallNodeFactory {
return new DownCallNode(f) {
@Override
protected TruffleObject getTarget(NativeFunction fn) {
+ if (fn == NativeFunction.initEventLoop) {
+ return new InitEventLoop();
+ }
+
CompilerAsserts.neverPartOfCompilation();
String library = fn.getLibrary();
DLLInfo dllInfo = null;
@@ -107,4 +116,25 @@ final class TruffleLLVM_DownCallNodeFactory extends DownCallNodeFactory {
}
};
}
+
+ private static final class InitEventLoop implements TruffleObject {
+
+ @Override
+ public ForeignAccess getForeignAccess() {
+ return ForeignAccess.create(InitEventLoop.class, new StandardFactory() {
+ @Override
+ public CallTarget accessIsExecutable() {
+ return Truffle.getRuntime().createCallTarget(RootNode.createConstantNode(true));
+ }
+
+ @Override
+ public CallTarget accessExecute(int argumentsLength) {
+ // TODO:
+ // by returning -1 we indicate that the native handlers loop is not available
+ return Truffle.getRuntime().createCallTarget(RootNode.createConstantNode(-1));
+ }
+ });
+ }
+ }
+
}
diff --git a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/upcalls/BytesToNativeCharArrayCallMR.java b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/upcalls/BytesToNativeCharArrayCallMR.java
index 854dd05b5017a67d0af0b9407f9a72a416d1c319..921ccfdc4439d5946fba544b3b320dbd7c9e7f01 100644
--- a/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/upcalls/BytesToNativeCharArrayCallMR.java
+++ b/com.oracle.truffle.r.ffi.impl/src/com/oracle/truffle/r/ffi/impl/llvm/upcalls/BytesToNativeCharArrayCallMR.java
@@ -25,7 +25,6 @@ package com.oracle.truffle.r.ffi.impl.llvm.upcalls;
import com.oracle.truffle.api.interop.MessageResolution;
import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.nodes.Node;
-import com.oracle.truffle.r.runtime.context.RContext;
@MessageResolution(receiverType = BytesToNativeCharArrayCall.class)
public class BytesToNativeCharArrayCallMR {
@@ -33,8 +32,8 @@ public class BytesToNativeCharArrayCallMR {
@Resolve(message = "EXECUTE")
public abstract static class BytesToNativeCharArrayCallExecute extends Node {
protected java.lang.Object access(BytesToNativeCharArrayCall receiver, Object[] arguments) {
- byte[] byteArray = (byte[]) RContext.getInstance().getEnv().asHostObject(arguments[0]);
- return receiver.upCallsImpl.bytesToNativeCharArray(byteArray);
+ String strArg = (String) arguments[0];
+ return receiver.upCallsImpl.bytesToNativeCharArray(strArg.getBytes());
}
}
diff --git a/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/RCmdOptions.java b/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/RCmdOptions.java
index 2ddb715ef2010bc3aa7779c004d5e5b414463d38..236d8bcedcf2447895c612e1c279e67d5dd5dc0c 100644
--- a/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/RCmdOptions.java
+++ b/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/RCmdOptions.java
@@ -364,6 +364,7 @@ public final class RCmdOptions {
// adjust for inserted executable name
return new RCmdOptions(options, args, firstNonOptionArgIndex);
+
}
public String[] getArguments() {
diff --git a/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/REPL.java b/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/REPL.java
index 9be847012a900478db027bcba5734ddfb0eb1d16..e2d65a53f7825e4c8be820fae41acdb5b640ea18 100644
--- a/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/REPL.java
+++ b/com.oracle.truffle.r.launcher/src/com/oracle/truffle/r/launcher/REPL.java
@@ -181,7 +181,9 @@ public class REPL {
if (result.isNull()) {
return; // event loop is not configured to be run
} else if (result.getMember("result").asInt() != 0) {
- System.out.println("WARNING: Native event loop unavailable. Error code: " + result.getMember("result").asInt());
+ // TODO: it breaks pkgtest when parsing output
+ // System.err.println("WARNING: Native event loop unavailable. Error code: " +
+ // result.getMember("result").asInt());
} else {
final String fifoInPath = result.getMember("fifoInPath").asString();
Thread t = new Thread() {
diff --git a/com.oracle.truffle.r.native/Makefile b/com.oracle.truffle.r.native/Makefile
index f8b3c33f01c70af04b9f7c461da439b647f85421..eb29521bbe32332b8329c5f074152b6a3423ac41 100644
--- a/com.oracle.truffle.r.native/Makefile
+++ b/com.oracle.truffle.r.native/Makefile
@@ -31,15 +31,6 @@ export R_VERSION = 3.4.0
export DEFAULT_CRAN_MIRROR = "https://mran.microsoft.com/snapshot/2018-06-20"
export GNUR_HOME = $(TOPDIR)/gnur/patch-build
-ifeq ($(FASTR_RFFI),llvm)
-ifndef FASTR_LLVM_TOOLS
-ifdef FASTR_LLVM_FOR_DRAGONEGG_HOME
-export FASTR_LLVM_TOOLS = $(FASTR_LLVM_FOR_DRAGONEGG_HOME)/bin
-$(info FASTR_LLVM_TOOLS set to $(FASTR_LLVM_TOOLS))
-endif
-endif
-endif
-
$(info R_VERSION: $(R_VERSION))
$(info GNUR_HOME: $(GNUR_HOME))
@@ -56,8 +47,11 @@ endif
# to force a clean build, and elsewhere use sentinels to avoid rebuilding when we can't compute the
# dependencies accurately.
+ifeq ($(FASTR_RFFI),llvm)
all: checkversion
$(MAKE) -C gnur
+ $(MAKE) -C ../f2c/f2c
+ FASTR_RFFI=llvm-only $(MAKE) -C ../f2c/libf2c
$(MAKE) -C include
$(MAKE) -C fficall
$(MAKE) -C $(GNUR_HOME)/src/library
@@ -68,7 +62,24 @@ clean:
$(MAKE) -C include clean
$(MAKE) -C fficall clean
$(MAKE) -C run clean
+ $(MAKE) -C ../f2c/libf2c clean
+ $(MAKE) -C ../f2c/f2c clean
$(MAKE) -C gnur clean
+else
+all: checkversion
+ $(MAKE) -C gnur
+ $(MAKE) -C include
+ $(MAKE) -C fficall
+ $(MAKE) -C $(GNUR_HOME)/src/library
+ $(MAKE) -C run
+ cp version.source version.built
+
+clean:
+ $(MAKE) -C include clean
+ $(MAKE) -C fficall clean
+ $(MAKE) -C run clean
+ $(MAKE) -C gnur clean
+endif
version.source := $(shell cat version.source)
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Makefile b/com.oracle.truffle.r.native/fficall/src/common/Makefile
index f24705c1cf4cc1d19ae954a97102ed8c6392863b..ba07abcf7e62dd3cb1f5ad9ad183e14736e7a7a2 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/Makefile
+++ b/com.oracle.truffle.r.native/fficall/src/common/Makefile
@@ -33,9 +33,9 @@ endif
# location of compiled code (.o files)
OBJ = ../../lib
-GNUR_APPL_C_FILES = pretty.c interv.c
GNUR_APPL_SRC = $(GNUR_HOME)/src/appl
GNUR_APPL_F_FILES := $(notdir $(wildcard $(GNUR_APPL_SRC)/d*.f))
+GNUR_APPL_C_FILES := $(notdir $(wildcard $(GNUR_APPL_SRC)/*.c))
GNUR_MAIN_C_FILES = errors.c colors.c devices.c engine.c format.c graphics.c plot.c plot3d.c plotmath.c rlocale.c sort.c
GNUR_MAIN_SRC = $(GNUR_HOME)/src/main
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_common/Connections.c b/com.oracle.truffle.r.native/fficall/src/truffle_common/Connections.c
index ae95ff2256c46d5c7eaf4c730866e51d4668e62c..1ad7ff5fe874fb3440d7a109b3fda0c82394c79b 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_common/Connections.c
+++ b/com.oracle.truffle.r.native/fficall/src/truffle_common/Connections.c
@@ -126,8 +126,8 @@ SEXP R_new_custom_connection(const char *description, const char *mode, const ch
error(_("allocation of %s connection failed"), class_name);
SEXP addrObj = R_MakeExternalPtr(new, R_NilValue, R_NilValue);
- SEXP fastRConn = ((call_R_new_custom_connection) callbacks[R_new_custom_connection_x])(description, mode,
- class_name, addrObj);
+ SEXP fastRConn = ((call_R_new_custom_connection) callbacks[R_new_custom_connection_x])(ensure_truffle_chararray(description), ensure_truffle_chararray(mode),
+ ensure_truffle_chararray(class_name), addrObj);
// printf("DEBUG: R_new_custom_connection address %p SEXP value %p\n", ptr, addrObj);
if (fastRConn) {
new->class = (char *) malloc(strlen(class_name) + 1);
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h b/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h
index 3ffb4ee65280e0cad210e9ba1026d56cd7db208f..97547fc7fcbf2540a5a62bc5f607dfbd0efefe08 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h
+++ b/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h
@@ -25,7 +25,7 @@
truffle_nfi and truffle_llvm directories.
The implementation must define the following functions:
- char *ensure_truffle_chararray_n(const char *x, int n)
+ char *ensure_truffle_chararray_n(const char *x, long n)
Ensures that the sequence of 'n' bytes starting at 'x' is in the
appropriate representation for the implementation.
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Makefile b/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Makefile
index c7198f3b6563e1afeb22723b198825f4c71b7ac0..1634115df4433de19729f77f1cdf3ac5d100c04e 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Makefile
+++ b/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Makefile
@@ -46,13 +46,10 @@ LOCAL_C_OBJECTS := $(addprefix $(OBJ)/, $(LOCAL_C_SOURCES:.c=.bc))
TRUFFLE_COMMON_C_OBJECTS := $(addprefix $(OBJ)/, $(notdir $(TRUFFLE_COMMON_C_SOURCES:.c=.bc)))
C_OBJECTS := $(LOCAL_C_OBJECTS) $(TRUFFLE_COMMON_C_OBJECTS)
-SULONG_DIR = $(abspath $(FASTR_R_HOME)/../sulong)
-
-SULONG_INCLUDES = -I$(SULONG_DIR)/include
FFI_INCLUDES = -I$(TOPDIR)/include -I$(TOPDIR)/include/R_ext
LOCAL_INCLUDES = -I . -I $(abspath ../include) -I $(abspath ../common)
-INCLUDES := $(LOCAL_INCLUDES) $(FFI_INCLUDES) $(SULONG_INCLUDES) $(NFI_INCLUDES)
+INCLUDES := $(LOCAL_INCLUDES) $(FFI_INCLUDES) $(NFI_INCLUDES)
FFLAGS :=
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Rinternals.c b/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Rinternals.c
index 64a0579f57490e0a5cf4f8cf98e281c590965a2f..1164822d56210ef186301c53feeb3dfff8dd57a4 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Rinternals.c
+++ b/com.oracle.truffle.r.native/fficall/src/truffle_llvm/Rinternals.c
@@ -26,6 +26,7 @@
#include <rffiutils.h>
#include <Rinternals_common.h>
#include <truffle.h>
+#include <polyglot.h>
#include "../common/rffi_upcalls.h"
// Most everything in RInternals.h
@@ -48,8 +49,8 @@ void Rinternals_addCallback(void** theCallbacks, int index, void *callback) {
callbacks[index] = callback;
}
-void*** Rinternals_getCallbacksAddress() {
- return &callbacks;
+void Rinternals_setCallbacksAddress(void** theCallbacks) {
+ callbacks = theCallbacks;
}
typedef SEXP (*call_Test)(const char *name);
@@ -59,11 +60,11 @@ SEXP Rinternals_invoke(int index) {
return ((call_Test) callback)("aaa");
}
-static char *ensure_truffle_chararray_n(const char *x, int n) {
+static char *ensure_truffle_chararray_n(const char *x, long n) {
if (truffle_is_truffle_object(x)) {
return x;
} else {
- return ((call_bytesToNativeCharArray) callbacks[bytesToNativeCharArray_x])(truffle_read_n_bytes(x, n));
+ return ((call_bytesToNativeCharArray) callbacks[bytesToNativeCharArray_x])(polyglot_from_string_n(x, n, "ascii"));
}
}
@@ -71,7 +72,7 @@ char *ensure_truffle_chararray(const char *x) {
if (truffle_is_truffle_object(x)) {
return (char *)x;
} else {
- return ((call_bytesToNativeCharArray) callbacks[bytesToNativeCharArray_x])(truffle_read_n_bytes(x, strlen(x)));
+ return ((call_bytesToNativeCharArray) callbacks[bytesToNativeCharArray_x])(polyglot_from_string_n(x, strlen(x), "ascii"));
}
}
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_nfi/Rinternals.c b/com.oracle.truffle.r.native/fficall/src/truffle_nfi/Rinternals.c
index b9854d3e91c9967e0354a561d1f64c03835698e7..be96adc02d0218c5a56c2e76e94b32b574348ff8 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_nfi/Rinternals.c
+++ b/com.oracle.truffle.r.native/fficall/src/truffle_nfi/Rinternals.c
@@ -41,6 +41,10 @@ char *ensure_truffle_chararray_n(const char *x, int n) {
return (char *) x;
}
+char *ensure_truffle_chararray(const char *x) {
+ return (char *) x;
+}
+
void *ensure_string(const char * x) {
return (void *) x;
}
diff --git a/com.oracle.truffle.r.native/gnur/edLLVM b/com.oracle.truffle.r.native/gnur/edLLVM
index 4cefc6d92562aeb914d69b7c2aff95ad6800a5a6..e2594c42254ceff6a160b2a0da719198af893d8e 100644
--- a/com.oracle.truffle.r.native/gnur/edLLVM
+++ b/com.oracle.truffle.r.native/gnur/edLLVM
@@ -1,12 +1,4 @@
-/^CC =/
-d
-i
-CC = $(FASTR_NATIVE_DIR)/llvm_tools/llvm-cc
-.
-/^F77 =/
-d
-i
-F77 = $(FASTR_NATIVE_DIR)/llvm_tools/llvm-fc
-.
+,s/CC[[:space:]]=\(.*\)/CC = $(FASTR_NATIVE_DIR)\/llvm_tools\/llvm-cc\1/g
+,s/F77[[:space:]]=\(.*\)/F77 = $(FASTR_NATIVE_DIR)\/llvm_tools\/llvm-fc\1/g
w
-q
+q
\ No newline at end of file
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ppr.f_c b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ppr.f_c
new file mode 100644
index 0000000000000000000000000000000000000000..1af2b553b0ff99ff2835f22f0badae75aca58299
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/stats/src/ppr.f_c
@@ -0,0 +1,2463 @@
+/* /home/ubuntu/work/tests/fastr/com.oracle.truffle.r.native/gnur/patch-build/src/library/stats/src/ppr.f -- translated by f2c (version 20100827).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include <stdlib.h>
+#include "f2c.h"
+
+/* Common Block Declarations */
+
+struct pprpar_1_ {
+ integer ifl, lf;
+ doublereal span, alpha, big;
+};
+
+#define pprpar_1 (*(struct pprpar_1_ *) &pprpar_)
+
+struct pprz01_1_ {
+ doublereal conv;
+ integer maxit, mitone;
+ doublereal cutmin, fdel, cjeps;
+ integer mitcj;
+};
+
+#define pprz01_1 (*(struct pprz01_1_ *) &pprz01_)
+
+struct spsmooth_1_ {
+ doublereal df, gcvpen;
+ integer ismethod;
+ logical trace;
+};
+
+#define spsmooth_1 (*(struct spsmooth_1_ *) &spsmooth_)
+
+struct spans_1_ {
+ doublereal spans[3];
+};
+
+#define spans_1 (*(struct spans_1_ *) &spans_)
+
+struct consts_1_ {
+ doublereal big, sml, eps;
+};
+
+#define consts_1 (*(struct consts_1_ *) &consts_)
+
+/* Initialized data */
+
+struct {
+ doublereal e_1[2];
+ integer e_2;
+ logical e_3;
+ } spsmooth_ = { 4., 1., 0, FALSE_ };
+
+struct {
+ integer e_1[2];
+ doublereal e_2[3];
+ } pprpar_ = { 6, 2, 0., 0., 1e20 };
+
+struct {
+ doublereal e_1[3];
+ } spans_ = { .05, .2, .5 };
+
+struct {
+ doublereal e_1[3];
+ } consts_ = { 1e20, 1e-7, .001 };
+
+struct {
+ doublereal e_1;
+ integer e_2[2];
+ doublereal e_3[3];
+ integer e_4;
+ } pprz01_ = { .005, 20, 20, .1, .02, .001, 1 };
+
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c__0 = 0;
+static doublereal c_b183 = 0.;
+static integer c__4 = 4;
+static integer c__18 = 18;
+
+
+/* Modified from the SMART package by J.H. Friedman, 10/10/84 */
+/* Main change is to add spline smoothing modified from BRUTO, */
+/* calling code written for smooth.spline in S. */
+
+/* B.D. Ripley (ripley@stats.ox.ac.uk) 1994-7. */
+
+
+/* Subroutine */ int smart_(integer *m, integer *mu, integer *p, integer *q,
+ integer *n, doublereal *w, doublereal *x, doublereal *y, doublereal *
+ ww, doublereal *smod, integer *nsmod, doublereal *sp, integer *nsp,
+ doublereal *dp, integer *ndp, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, y_dim1, y_offset;
+
+ /* Local variables */
+ extern /* Subroutine */ int smart1_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *);
+
+ /* Parameter adjustments */
+ --edf;
+ --ww;
+ y_dim1 = *q;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --w;
+ --smod;
+ --sp;
+ --dp;
+
+ /* Function Body */
+ smod[1] = (doublereal) (*m);
+ smod[2] = (doublereal) (*p);
+ smod[3] = (doublereal) (*q);
+ smod[4] = (doublereal) (*n);
+ smart1_(m, mu, p, q, n, &w[1], &x[x_offset], &y[y_offset], &ww[1], &smod[
+ 6], &smod[*q + 6], &smod[*q + 7], &smod[*q + 7 + *p * *m], &smod[*
+ q + 7 + *m * (*p + *q)], &smod[*q + 7 + *m * (*p + *q + *n)], &
+ smod[*q + 7 + *m * (*p + *q + (*n << 1))], &sp[1], &sp[*q * *n +
+ 1], &sp[*n * (*q + 15) + 1], &sp[*n * (*q + 15) + *q + 1], &dp[1],
+ &smod[5], &edf[1]);
+ return 0;
+} /* smart_ */
+
+/* Subroutine */ int smart1_(integer *m, integer *mu, integer *p, integer *q,
+ integer *n, doublereal *w, doublereal *x, doublereal *y, doublereal *
+ ww, doublereal *yb, doublereal *ys, doublereal *a, doublereal *b,
+ doublereal *f, doublereal *t, doublereal *asr, doublereal *r__,
+ doublereal *sc, doublereal *bt, doublereal *g, doublereal *dp,
+ doublereal *flm, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, a_dim1, a_offset, b_dim1, b_offset, f_dim1,
+ f_offset, t_dim1, t_offset, r_dim1, r_offset, sc_dim1, sc_offset,
+ g_dim1, g_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ static integer i__, j, l;
+ static doublereal s;
+ static integer lm;
+ static doublereal sw, asr1;
+ extern /* Subroutine */ int sort_(doublereal *, doublereal *, integer *,
+ integer *), fulfit_(integer *, integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *), subfit_(integer *,
+ integer *, integer *, integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+
+/* ^^^ really (ndb) of smart(.) */
+/* Common Vars */
+ /* Parameter adjustments */
+ --edf;
+ g_dim1 = *p;
+ g_offset = 1 + g_dim1;
+ g -= g_offset;
+ a_dim1 = *p;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bt;
+ b_dim1 = *q;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --yb;
+ --ww;
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ r_dim1 = *q;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ t_dim1 = *n;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ f_dim1 = *n;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --w;
+ --y;
+ --asr;
+ --dp;
+
+ /* Function Body */
+ sw = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sw += w[j];
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__[i__ + j * r_dim1] = y[*q * (j - 1) + i__];
+ }
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ s += w[j] * r__[i__ + j * r_dim1];
+ }
+ yb[i__] = s / sw;
+ }
+/* yb is vector of means */
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__[i__ + j * r_dim1] -= yb[i__];
+ }
+ }
+ *ys = 0.;
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing 2nd power */
+ d__1 = r__[i__ + j * r_dim1];
+ s += w[j] * (d__1 * d__1);
+ }
+ *ys += ww[i__] * s / sw;
+ }
+ if (*ys > 0.) {
+ goto L311;
+ }
+/* ys is the overall standard deviation -- quit if zero */
+ return 0;
+L311:
+ *ys = sqrt(*ys);
+ s = 1. / *ys;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__[i__ + j * r_dim1] *= s;
+ }
+ }
+/* r is now standardized residuals */
+/* subfit adds up to m terms one at time; lm is the number fitted. */
+ subfit_(m, p, q, n, &w[1], &sw, &x[x_offset], &r__[r_offset], &ww[1], &lm,
+ &a[a_offset], &b[b_offset], &f[f_offset], &t[t_offset], &asr[1],
+ &sc[sc_offset], &bt[1], &g[g_offset], &dp[1], &edf[1]);
+ if (pprpar_1.lf <= 0) {
+ goto L9999;
+ }
+ fulfit_(&lm, &pprpar_1.lf, p, q, n, &w[1], &sw, &x[x_offset], &r__[
+ r_offset], &ww[1], &a[a_offset], &b[b_offset], &f[f_offset], &t[
+ t_offset], &asr[1], &sc[sc_offset], &bt[1], &g[g_offset], &dp[1],
+ &edf[1]);
+/* REPEAT */
+L371:
+ i__1 = lm;
+ for (l = 1; l <= i__1; ++l) {
+ sc[l + sc_dim1] = l + .1;
+ s = 0.;
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s += ww[i__] * (d__1 = b[i__ + l * b_dim1], abs(d__1));
+ }
+ sc[l + (sc_dim1 << 1)] = -s;
+ }
+ sort_(&sc[(sc_dim1 << 1) + 1], &sc[sc_offset], &c__1, &lm);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__[i__ + j * r_dim1] = y[*q * (j - 1) + i__];
+ }
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ r__[i__ + j * r_dim1] -= yb[i__];
+ s = 0.;
+ i__3 = lm;
+ for (l = 1; l <= i__3; ++l) {
+ s += b[i__ + l * b_dim1] * f[j + l * f_dim1];
+ }
+ r__[i__ + j * r_dim1] = r__[i__ + j * r_dim1] / *ys - s;
+ }
+ }
+ if (lm <= *mu) {
+ goto L9999;
+ }
+/* back to integer: */
+ l = (integer) sc[lm + sc_dim1];
+ asr1 = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ r__[i__ + j * r_dim1] += b[i__ + l * b_dim1] * f[j + l * f_dim1];
+/* Computing 2nd power */
+ d__1 = r__[i__ + j * r_dim1];
+ asr1 += w[j] * ww[i__] * (d__1 * d__1);
+ }
+ }
+ asr1 /= sw;
+ asr[1] = asr1;
+ if (l >= lm) {
+ goto L591;
+ }
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__ + l * a_dim1] = a[i__ + lm * a_dim1];
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + l * b_dim1] = b[i__ + lm * b_dim1];
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ f[j + l * f_dim1] = f[j + lm * f_dim1];
+ t[j + l * t_dim1] = t[j + lm * t_dim1];
+ }
+L591:
+ --lm;
+ fulfit_(&lm, &pprpar_1.lf, p, q, n, &w[1], &sw, &x[x_offset], &r__[
+ r_offset], &ww[1], &a[a_offset], &b[b_offset], &f[f_offset], &t[
+ t_offset], &asr[1], &sc[sc_offset], &bt[1], &g[g_offset], &dp[1],
+ &edf[1]);
+ goto L371;
+/* END REPEAT */
+L9999:
+ *flm = (doublereal) lm;
+ return 0;
+} /* smart1_ */
+
+/* Subroutine */ int subfit_(integer *m, integer *p, integer *q, integer *n,
+ doublereal *w, doublereal *sw, doublereal *x, doublereal *r__,
+ doublereal *ww, integer *lm, doublereal *a, doublereal *b, doublereal
+ *f, doublereal *t, doublereal *asr, doublereal *sc, doublereal *bt,
+ doublereal *g, doublereal *dp, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, r_dim1, r_offset, a_dim1, a_offset, b_dim1,
+ b_offset, f_dim1, f_offset, t_dim1, t_offset, sc_dim1, sc_offset,
+ g_dim1, g_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ static integer i__, j, l;
+ extern /* Subroutine */ int newb_(integer *, integer *, doublereal *,
+ doublereal *);
+ static integer iflsv;
+ static doublereal asrold;
+ extern /* Subroutine */ int fulfit_(integer *, integer *, integer *,
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), onetrm_(
+ integer *, integer *, integer *, integer *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *), rchkusr_(void);
+
+/* Args */
+/* Var */
+/* Common Vars */
+ /* Parameter adjustments */
+ --edf;
+ g_dim1 = *p;
+ g_offset = 1 + g_dim1;
+ g -= g_offset;
+ a_dim1 = *p;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bt;
+ b_dim1 = *q;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --ww;
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ t_dim1 = *n;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ f_dim1 = *n;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *q;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --w;
+ --asr;
+ --dp;
+
+ /* Function Body */
+ asr[1] = pprpar_1.big;
+ *lm = 0;
+ i__1 = *m;
+ for (l = 1; l <= i__1; ++l) {
+ rchkusr_();
+ ++(*lm);
+ asrold = asr[1];
+ newb_(lm, q, &ww[1], &b[b_offset]);
+/* does 'edf' mean 'edf(1)' or 'edf(l)'? */
+ onetrm_(&c__0, p, q, n, &w[1], sw, &x[x_offset], &r__[r_offset], &ww[
+ 1], &a[*lm * a_dim1 + 1], &b[*lm * b_dim1 + 1], &f[*lm *
+ f_dim1 + 1], &t[*lm * t_dim1 + 1], &asr[1], &sc[sc_offset], &
+ g[g_offset], &dp[1], &edf[1]);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *q;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r__[i__ + j * r_dim1] -= b[i__ + *lm * b_dim1] * f[j + *lm *
+ f_dim1];
+/* L10: */
+ }
+/* L20: */
+ }
+ if (*lm == 1) {
+ goto L100;
+ }
+ if (pprpar_1.lf > 0) {
+ if (*lm == *m) {
+ return 0;
+ }
+ iflsv = pprpar_1.ifl;
+ pprpar_1.ifl = 0;
+ fulfit_(lm, &c__1, p, q, n, &w[1], sw, &x[x_offset], &r__[
+ r_offset], &ww[1], &a[a_offset], &b[b_offset], &f[
+ f_offset], &t[t_offset], &asr[1], &sc[sc_offset], &bt[1],
+ &g[g_offset], &dp[1], &edf[1]);
+ pprpar_1.ifl = iflsv;
+ }
+ if (asr[1] <= 0. || (asrold - asr[1]) / asrold < pprz01_1.conv) {
+ return 0;
+ }
+L100:
+ ;
+ }
+ return 0;
+} /* subfit_ */
+
+/* Subroutine */ int fulfit_(integer *lm, integer *lbf, integer *p, integer *
+ q, integer *n, doublereal *w, doublereal *sw, doublereal *x,
+ doublereal *r__, doublereal *ww, doublereal *a, doublereal *b,
+ doublereal *f, doublereal *t, doublereal *asr, doublereal *sc,
+ doublereal *bt, doublereal *g, doublereal *dp, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, r_dim1, r_offset, a_dim1, a_offset, b_dim1,
+ b_offset, f_dim1, f_offset, t_dim1, t_offset, sc_dim1, sc_offset,
+ g_dim1, g_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ static integer i__, j, lp;
+ static doublereal fsv;
+ static integer isv;
+ static doublereal asri;
+ static integer iter;
+ static doublereal asrold;
+ extern /* Subroutine */ int onetrm_(integer *, integer *, integer *,
+ integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+
+/* Args */
+/* Var */
+/* Common Vars */
+ /* Parameter adjustments */
+ --edf;
+ --asr;
+ g_dim1 = *p;
+ g_offset = 1 + g_dim1;
+ g -= g_offset;
+ a_dim1 = *p;
+ a_offset = 1 + a_dim1;
+ a -= a_offset;
+ --bt;
+ b_dim1 = *q;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --ww;
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ t_dim1 = *n;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ f_dim1 = *n;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+ r_dim1 = *q;
+ r_offset = 1 + r_dim1;
+ r__ -= r_offset;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --w;
+ --dp;
+
+ /* Function Body */
+ if (*lbf <= 0) {
+ return 0;
+ }
+ asri = asr[1];
+ fsv = pprz01_1.cutmin;
+ isv = pprz01_1.mitone;
+ if (*lbf < 3) {
+ pprz01_1.cutmin = 1.;
+ pprz01_1.mitone = *lbf - 1;
+ }
+ iter = 0;
+/* Outer loop: */
+L1000:
+ asrold = asri;
+ ++iter;
+ i__1 = *lm;
+ for (lp = 1; lp <= i__1; ++lp) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ bt[i__] = b[i__ + lp * b_dim1];
+/* L10: */
+ }
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ g[i__ + g_dim1 * 3] = a[i__ + lp * a_dim1];
+/* L20: */
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *q;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r__[i__ + j * r_dim1] += bt[i__] * f[j + lp * f_dim1];
+/* L30: */
+ }
+/* L35: */
+ }
+ onetrm_(&c__1, p, q, n, &w[1], sw, &x[x_offset], &r__[r_offset], &ww[
+ 1], &g[g_dim1 * 3 + 1], &bt[1], &sc[sc_dim1 * 14 + 1], &sc[
+ sc_dim1 * 15 + 1], &asri, &sc[sc_offset], &g[g_offset], &dp[1]
+ , &edf[lp]);
+ if (asri < asrold) {
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + lp * b_dim1] = bt[i__];
+/* L40: */
+ }
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ a[i__ + lp * a_dim1] = g[i__ + g_dim1 * 3];
+/* L50: */
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ f[j + lp * f_dim1] = sc[j + sc_dim1 * 14];
+ t[j + lp * t_dim1] = sc[j + sc_dim1 * 15];
+/* L60: */
+ }
+ } else {
+ asri = asrold;
+ }
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ i__3 = *q;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ r__[i__ + j * r_dim1] -= b[i__ + lp * b_dim1] * f[j + lp *
+ f_dim1];
+/* L80: */
+ }
+/* L85: */
+ }
+/* L100: */
+ }
+ if (iter <= pprz01_1.maxit && (asri > 0. && (asrold - asri) / asrold >=
+ pprz01_1.conv)) {
+ goto L1000;
+ }
+ pprz01_1.cutmin = fsv;
+ pprz01_1.mitone = isv;
+ if (pprpar_1.ifl > 0) {
+ asr[*lm + 1] = asri;
+ asr[1] = asri;
+ }
+ return 0;
+} /* fulfit_ */
+
+/* Subroutine */ int onetrm_(integer *jfl, integer *p, integer *q, integer *n,
+ doublereal *w, doublereal *sw, doublereal *x, doublereal *y,
+ doublereal *ww, doublereal *a, doublereal *b, doublereal *f,
+ doublereal *t, doublereal *asr, doublereal *sc, doublereal *g,
+ doublereal *dp, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, y_dim1, y_offset, sc_dim1, sc_offset, g_dim1,
+ g_offset, i__1, i__2, i__3;
+ doublereal d__1;
+
+ /* Local variables */
+ static integer i__, j;
+ static doublereal s;
+ static integer iter;
+ extern /* Subroutine */ int oneone_(integer *, integer *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ static doublereal asrold;
+
+/* Args */
+/* Var */
+/* Common Vars */
+ /* Parameter adjustments */
+ g_dim1 = *p;
+ g_offset = 1 + g_dim1;
+ g -= g_offset;
+ --a;
+ --b;
+ --ww;
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --t;
+ --f;
+ y_dim1 = *q;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --w;
+ --dp;
+
+ /* Function Body */
+ iter = 0;
+ *asr = pprpar_1.big;
+/* REPEAT */
+L1000:
+ ++iter;
+ asrold = *asr;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s += ww[i__] * b[i__] * y[i__ + j * y_dim1];
+/* L21: */
+ }
+ sc[j + sc_dim1 * 13] = s;
+/* L11: */
+ }
+/* Computing MAX */
+ i__2 = *jfl, i__3 = iter - 1;
+ i__1 = max(i__2,i__3);
+ oneone_(&i__1, p, n, &w[1], sw, &sc[sc_dim1 * 13 + 1], &x[x_offset], &a[1]
+ , &f[1], &t[1], asr, &sc[sc_offset], &g[g_offset], &dp[1], edf);
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ s += w[j] * y[i__ + j * y_dim1] * f[j];
+/* L41: */
+ }
+ b[i__] = s / *sw;
+/* L31: */
+ }
+ *asr = 0.;
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+/* Computing 2nd power */
+ d__1 = y[i__ + j * y_dim1] - b[i__] * f[j];
+ s += w[j] * (d__1 * d__1);
+/* L61: */
+ }
+ *asr += ww[i__] * s / *sw;
+/* L51: */
+ }
+ if (*q != 1 && iter <= pprz01_1.maxit && *asr > 0. && (asrold - *asr) /
+ asrold >= pprz01_1.conv) {
+ goto L1000;
+ }
+ return 0;
+} /* onetrm_ */
+
+/* Subroutine */ int oneone_(integer *ist, integer *p, integer *n, doublereal
+ *w, doublereal *sw, doublereal *y, doublereal *x, doublereal *a,
+ doublereal *f, doublereal *t, doublereal *asr, doublereal *sc,
+ doublereal *g, doublereal *dp, doublereal *edf)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, sc_dim1, sc_offset, g_dim1, g_offset, i__1,
+ i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ static integer i__, j, k;
+ static doublereal s, v, sml, cut;
+ static integer iter;
+ extern /* Subroutine */ int sort_(doublereal *, doublereal *, integer *,
+ integer *);
+ static doublereal asrold;
+ extern /* Subroutine */ int pprder_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), pprdir_(
+ integer *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *), supsmu_(
+ integer *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *);
+
+/* Args */
+/* Var */
+/* Common Vars */
+ /* Parameter adjustments */
+ g_dim1 = *p;
+ g_offset = 1 + g_dim1;
+ g -= g_offset;
+ --a;
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --t;
+ --f;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --y;
+ --w;
+ --dp;
+
+ /* Function Body */
+ sml = 1. / pprpar_1.big;
+ if (*ist <= 0) {
+ if (*p <= 1) {
+ a[1] = 1.;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sc[j + (sc_dim1 << 1)] = 1.;
+/* L10: */
+ }
+ pprdir_(p, n, &w[1], sw, &y[1], &x[x_offset], &sc[(sc_dim1 << 1) + 1],
+ &a[1], &dp[1]);
+ }
+ s = 0.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ g[i__ + g_dim1] = 0.;
+/* Computing 2nd power */
+ d__1 = a[i__];
+ s += d__1 * d__1;
+/* L20: */
+ }
+ s = 1. / sqrt(s);
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__] *= s;
+/* L30: */
+ }
+ iter = 0;
+ *asr = pprpar_1.big;
+ cut = 1.;
+/* REPEAT ----------------------------- */
+L100:
+ ++iter;
+ asrold = *asr;
+/* REPEAT [inner loop] ----- */
+L60:
+ s = 0.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ g[i__ + (g_dim1 << 1)] = a[i__] + g[i__ + g_dim1];
+/* Computing 2nd power */
+ d__1 = g[i__ + (g_dim1 << 1)];
+ s += d__1 * d__1;
+/* L70: */
+ }
+ s = 1. / sqrt(s);
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ g[i__ + (g_dim1 << 1)] *= s;
+/* L80: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sc[j + sc_dim1] = j + .1;
+ s = 0.;
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s += g[i__ + (g_dim1 << 1)] * x[i__ + j * x_dim1];
+/* L91: */
+ }
+ sc[j + sc_dim1 * 11] = s;
+/* L90: */
+ }
+ sort_(&sc[sc_dim1 * 11 + 1], &sc[sc_offset], &c__1, n);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = (integer) sc[j + sc_dim1];
+ sc[j + (sc_dim1 << 1)] = y[k];
+/* Computing MAX */
+ d__1 = w[k];
+ sc[j + sc_dim1 * 3] = max(d__1,sml);
+/* L110: */
+ }
+ supsmu_(n, &sc[sc_dim1 * 11 + 1], &sc[(sc_dim1 << 1) + 1], &sc[sc_dim1 *
+ 3 + 1], &c__1, &pprpar_1.span, &pprpar_1.alpha, &sc[sc_dim1 * 12
+ + 1], &sc[(sc_dim1 << 2) + 1], edf);
+ s = 0.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+/* Computing 2nd power */
+ d__1 = sc[j + (sc_dim1 << 1)] - sc[j + sc_dim1 * 12];
+ s += sc[j + sc_dim1 * 3] * (d__1 * d__1);
+/* L120: */
+ }
+ s /= *sw;
+ if (s < *asr) {
+ goto L140;
+ }
+ cut *= .5;
+ if (cut < pprz01_1.cutmin) {
+ goto L199;
+ }
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ g[i__ + g_dim1] *= cut;
+/* L150: */
+ }
+ goto L60;
+/* -------- */
+L140:
+ *asr = s;
+ cut = 1.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ a[i__] = g[i__ + (g_dim1 << 1)];
+/* L160: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = (integer) sc[j + sc_dim1];
+ t[k] = sc[j + sc_dim1 * 11];
+ f[k] = sc[j + sc_dim1 * 12];
+/* L170: */
+ }
+ if (*asr <= 0. || (asrold - *asr) / asrold < pprz01_1.conv) {
+ goto L199;
+ }
+ if (iter > pprz01_1.mitone || *p <= 1) {
+ goto L199;
+ }
+ pprder_(n, &sc[sc_dim1 * 11 + 1], &sc[sc_dim1 * 12 + 1], &sc[sc_dim1 * 3
+ + 1], &pprz01_1.fdel, &sc[(sc_dim1 << 2) + 1], &sc[sc_dim1 * 5 +
+ 1]);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ k = (integer) sc[j + sc_dim1];
+ sc[j + sc_dim1 * 5] = y[j] - f[j];
+ sc[k + sc_dim1 * 6] = sc[j + (sc_dim1 << 2)];
+/* L180: */
+ }
+ pprdir_(p, n, &w[1], sw, &sc[sc_dim1 * 5 + 1], &x[x_offset], &sc[sc_dim1 *
+ 6 + 1], &g[g_offset], &dp[1]);
+ goto L100;
+/* -------------- */
+L199:
+/* -------------- */
+ s = 0.;
+ v = s;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ s += w[j] * f[j];
+/* L210: */
+ }
+ s /= *sw;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ f[j] -= s;
+/* Computing 2nd power */
+ d__1 = f[j];
+ v += w[j] * (d__1 * d__1);
+/* L220: */
+ }
+ if (v > 0.) {
+ v = 1. / sqrt(v / *sw);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ f[j] *= v;
+/* L230: */
+ }
+ }
+ return 0;
+} /* oneone_ */
+
+/* Subroutine */ int pprdir_(integer *p, integer *n, doublereal *w,
+ doublereal *sw, doublereal *r__, doublereal *x, doublereal *d__,
+ doublereal *e, doublereal *g)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ static integer i__, j, k, l;
+ static doublereal s;
+ static integer m1, m2;
+ extern /* Subroutine */ int ppconj_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *);
+
+ /* Parameter adjustments */
+ --e;
+ --d__;
+ x_dim1 = *p;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --r__;
+ --w;
+ --g;
+
+ /* Function Body */
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ s += w[j] * d__[j] * x[i__ + j * x_dim1];
+/* L15: */
+ }
+ e[i__] = s / *sw;
+/* L10: */
+ }
+ k = 0;
+ m1 = *p * (*p + 1) / 2;
+ m2 = m1 + *p;
+ i__1 = *p;
+ for (j = 1; j <= i__1; ++j) {
+ s = 0.;
+ i__2 = *n;
+ for (l = 1; l <= i__2; ++l) {
+ s += w[l] * r__[l] * (d__[l] * x[j + l * x_dim1] - e[j]);
+/* L22: */
+ }
+ g[m1 + j] = s / *sw;
+ i__2 = j;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s = 0.;
+ i__3 = *n;
+ for (l = 1; l <= i__3; ++l) {
+ s += w[l] * (d__[l] * x[i__ + l * x_dim1] - e[i__]) * (d__[l]
+ * x[j + l * x_dim1] - e[j]);
+/* L27: */
+ }
+ ++k;
+ g[k] = s / *sw;
+/* L25: */
+ }
+/* L20: */
+ }
+ ppconj_(p, &g[1], &g[m1 + 1], &g[m2 + 1], &pprz01_1.cjeps, &
+ pprz01_1.mitcj, &g[m2 + *p + 1]);
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ e[i__] = g[m2 + i__];
+/* L30: */
+ }
+ return 0;
+} /* pprdir_ */
+
+/* Subroutine */ int ppconj_(integer *p, doublereal *g, doublereal *c__,
+ doublereal *x, doublereal *eps, integer *maxit, doublereal *sc)
+{
+ /* System generated locals */
+ integer sc_dim1, sc_offset, i__1, i__2;
+ doublereal d__1, d__2, d__3;
+
+ /* Local variables */
+ static doublereal h__;
+ static integer i__, j;
+ static doublereal s, t;
+ static integer im1, nit;
+ static doublereal beta;
+ static integer iter;
+ static doublereal alpha;
+
+ /* Parameter adjustments */
+ sc_dim1 = *p;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --x;
+ --c__;
+ --g;
+
+ /* Function Body */
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ x[i__] = 0.;
+ sc[i__ + (sc_dim1 << 1)] = 0.;
+/* L1: */
+ }
+ nit = 0;
+/* REPEAT */
+L11321:
+ ++nit;
+ h__ = 0.;
+ beta = 0.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ sc[i__ + (sc_dim1 << 2)] = x[i__];
+ s = g[i__ * (i__ - 1) / 2 + i__] * x[i__];
+ im1 = i__ - 1;
+ j = 1;
+ goto L11343;
+L11341:
+ ++j;
+L11343:
+ if (j > im1) {
+ goto L11342;
+ }
+ s += g[i__ * (i__ - 1) / 2 + j] * x[j];
+ goto L11341;
+L11342:
+ j = i__ + 1;
+ goto L11353;
+L11351:
+ ++j;
+L11353:
+ if (j > *p) {
+ goto L11352;
+ }
+ s += g[j * (j - 1) / 2 + i__] * x[j];
+ goto L11351;
+L11352:
+ sc[i__ + sc_dim1] = s - c__[i__];
+/* Computing 2nd power */
+ d__1 = sc[i__ + sc_dim1];
+ h__ += d__1 * d__1;
+/* L11331: */
+ }
+ if (h__ <= 0.) {
+ goto L11322;
+ }
+ i__1 = *p;
+ for (iter = 1; iter <= i__1; ++iter) {
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ sc[i__ + (sc_dim1 << 1)] = beta * sc[i__ + (sc_dim1 << 1)] - sc[
+ i__ + sc_dim1];
+/* L11371: */
+ }
+ t = 0.;
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s = g[i__ * (i__ - 1) / 2 + i__] * sc[i__ + (sc_dim1 << 1)];
+ im1 = i__ - 1;
+ j = 1;
+ goto L11393;
+L11391:
+ ++j;
+L11393:
+ if (j > im1) {
+ goto L11392;
+ }
+ s += g[i__ * (i__ - 1) / 2 + j] * sc[j + (sc_dim1 << 1)];
+ goto L11391;
+L11392:
+ j = i__ + 1;
+ goto L11403;
+L11401:
+ ++j;
+L11403:
+ if (j > *p) {
+ goto L11402;
+ }
+ s += g[j * (j - 1) / 2 + i__] * sc[j + (sc_dim1 << 1)];
+ goto L11401;
+L11402:
+ sc[i__ + sc_dim1 * 3] = s;
+ t += s * sc[i__ + (sc_dim1 << 1)];
+/* L11381: */
+ }
+ alpha = h__ / t;
+ s = 0.;
+ i__2 = *p;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ x[i__] += alpha * sc[i__ + (sc_dim1 << 1)];
+ sc[i__ + sc_dim1] += alpha * sc[i__ + sc_dim1 * 3];
+/* Computing 2nd power */
+ d__1 = sc[i__ + sc_dim1];
+ s += d__1 * d__1;
+/* L11411: */
+ }
+ if (s <= 0.) {
+ goto L11362;
+ }
+ beta = s / h__;
+ h__ = s;
+/* L11361: */
+ }
+L11362:
+ s = 0.;
+ i__1 = *p;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+ d__2 = s, d__3 = (d__1 = x[i__] - sc[i__ + (sc_dim1 << 2)], abs(d__1))
+ ;
+ s = max(d__2,d__3);
+/* L11421: */
+ }
+ if (s >= *eps && nit < *maxit) {
+ goto L11321;
+ }
+L11322:
+ return 0;
+} /* ppconj_ */
+
+/* Subroutine */ int pprder_(integer *n, doublereal *x, doublereal *s,
+ doublereal *w, doublereal *fdel, doublereal *d__, doublereal *sc)
+{
+ /* System generated locals */
+ integer sc_dim1, sc_offset, i__1;
+
+ /* Local variables */
+ static integer i__, j, bc, ec, bl, el, br, er;
+ static doublereal del;
+ extern /* Subroutine */ int pool_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *);
+ static doublereal scale;
+ extern /* Subroutine */ int rexit_(char *, ftnlen);
+
+
+/* unnecessary initialization of bl el ec to keep g77 -Wall happy */
+
+ /* Parameter adjustments */
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --d__;
+ --w;
+ --s;
+ --x;
+
+ /* Function Body */
+ bl = 0;
+ el = 0;
+ ec = 0;
+
+ if (x[*n] > x[1]) {
+ goto L11441;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ d__[j] = 0.;
+/* L11451: */
+ }
+ return 0;
+L11441:
+ i__ = *n / 4;
+ j = i__ * 3;
+ scale = x[j] - x[i__];
+L11461:
+ if (scale > 0.) {
+ goto L11462;
+ }
+ if (j < *n) {
+ ++j;
+ }
+ if (i__ > 1) {
+ --i__;
+ }
+ scale = x[j] - x[i__];
+ goto L11461;
+L11462:
+ del = *fdel * scale * 2.;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sc[j + sc_dim1] = x[j];
+ sc[j + (sc_dim1 << 1)] = s[j];
+ sc[j + sc_dim1 * 3] = w[j];
+/* L11471: */
+ }
+ pool_(n, &sc[sc_offset], &sc[(sc_dim1 << 1) + 1], &sc[sc_dim1 * 3 + 1], &
+ del);
+ bc = 0;
+ br = bc;
+ er = br;
+L11481:
+ br = er + 1;
+ er = br;
+L11491:
+ if (er >= *n) {
+ goto L11492;
+ }
+ if (sc[br + sc_dim1] != sc[er + 1 + sc_dim1]) {
+ goto L11511;
+ }
+ ++er;
+ goto L11521;
+L11511:
+ goto L11492;
+L11521:
+ goto L11491;
+L11492:
+ if (br != 1) {
+ goto L11541;
+ }
+ bl = br;
+ el = er;
+ goto L11481;
+L11541:
+ if (bc != 0) {
+ goto L11561;
+ }
+ bc = br;
+ ec = er;
+ i__1 = el;
+ for (j = bl; j <= i__1; ++j) {
+ d__[j] = (sc[bc + (sc_dim1 << 1)] - sc[bl + (sc_dim1 << 1)]) / (sc[bc
+ + sc_dim1] - sc[bl + sc_dim1]);
+/* L11571: */
+ }
+ goto L11481;
+L11561:
+/* sanity check needed for PR#13517 */
+ if (br > *n) {
+ rexit_("br is too large", (ftnlen)15);
+ }
+ i__1 = ec;
+ for (j = bc; j <= i__1; ++j) {
+ d__[j] = (sc[br + (sc_dim1 << 1)] - sc[bl + (sc_dim1 << 1)]) / (sc[br
+ + sc_dim1] - sc[bl + sc_dim1]);
+/* L11581: */
+ }
+ if (er != *n) {
+ goto L11601;
+ }
+ i__1 = er;
+ for (j = br; j <= i__1; ++j) {
+ d__[j] = (sc[br + (sc_dim1 << 1)] - sc[bc + (sc_dim1 << 1)]) / (sc[br
+ + sc_dim1] - sc[bc + sc_dim1]);
+/* L11611: */
+ }
+ goto L11482;
+L11601:
+ bl = bc;
+ el = ec;
+ bc = br;
+ ec = er;
+ goto L11481;
+L11482:
+ return 0;
+} /* pprder_ */
+
+/* Subroutine */ int pool_(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, doublereal *del)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ static integer i__, bb, eb, bl, el, br, er;
+ static doublereal pw, px, py;
+
+ /* Parameter adjustments */
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ bb = 0;
+ eb = bb;
+L11621:
+ if (eb >= *n) {
+ goto L11622;
+ }
+ bb = eb + 1;
+ eb = bb;
+L11631:
+ if (eb >= *n) {
+ goto L11632;
+ }
+ if (x[bb] != x[eb + 1]) {
+ goto L11651;
+ }
+ ++eb;
+ goto L11661;
+L11651:
+ goto L11632;
+L11661:
+ goto L11631;
+L11632:
+ if (eb >= *n) {
+ goto L11681;
+ }
+ if (x[eb + 1] - x[eb] >= *del) {
+ goto L11701;
+ }
+ br = eb + 1;
+ er = br;
+L11711:
+ if (er >= *n) {
+ goto L11712;
+ }
+ if (x[er + 1] != x[br]) {
+ goto L11731;
+ }
+ ++er;
+ goto L11741;
+L11731:
+ goto L11712;
+L11741:
+ goto L11711;
+L11712:
+/* avoid bounds error: this was .and. but order is not guaranteed */
+ if (er < *n) {
+ if (x[er + 1] - x[er] < x[eb + 1] - x[eb]) {
+ goto L11621;
+ }
+ }
+ eb = er;
+ pw = w[bb] + w[eb];
+ px = (x[bb] * w[bb] + x[eb] * w[eb]) / pw;
+ py = (y[bb] * w[bb] + y[eb] * w[eb]) / pw;
+ i__1 = eb;
+ for (i__ = bb; i__ <= i__1; ++i__) {
+ x[i__] = px;
+ y[i__] = py;
+ w[i__] = pw;
+/* L11751: */
+ }
+L11701:
+L11681:
+L11761:
+ if (bb <= 1) {
+ goto L11762;
+ }
+ if (x[bb] - x[bb - 1] >= *del) {
+ goto L11762;
+ }
+ bl = bb - 1;
+ el = bl;
+L11771:
+ if (bl <= 1) {
+ goto L11772;
+ }
+ if (x[bl - 1] != x[el]) {
+ goto L11791;
+ }
+ --bl;
+ goto L11801;
+L11791:
+ goto L11772;
+L11801:
+ goto L11771;
+L11772:
+ bb = bl;
+ pw = w[bb] + w[eb];
+ px = (x[bb] * w[bb] + x[eb] * w[eb]) / pw;
+ py = (y[bb] * w[bb] + y[eb] * w[eb]) / pw;
+ i__1 = eb;
+ for (i__ = bb; i__ <= i__1; ++i__) {
+ x[i__] = px;
+ y[i__] = py;
+ w[i__] = pw;
+/* L11811: */
+ }
+ goto L11761;
+L11762:
+ goto L11621;
+L11622:
+ return 0;
+} /* pool_ */
+
+/* Subroutine */ int newb_(integer *lm, integer *q, doublereal *ww,
+ doublereal *b)
+{
+ /* System generated locals */
+ integer b_dim1, b_offset, i__1, i__2;
+ doublereal d__1;
+
+ /* Builtin functions */
+ double sqrt(doublereal);
+
+ /* Local variables */
+ static integer i__, l;
+ static doublereal s, t;
+ static integer l1, lm1;
+ static doublereal sml;
+
+/* Common */
+ /* Parameter adjustments */
+ b_dim1 = *q;
+ b_offset = 1 + b_dim1;
+ b -= b_offset;
+ --ww;
+
+ /* Function Body */
+ sml = 1. / pprpar_1.big;
+ if (*q != 1) {
+ goto L11831;
+ }
+ b[*lm * b_dim1 + 1] = 1.;
+ return 0;
+L11831:
+ if (*lm != 1) {
+ goto L11851;
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + *lm * b_dim1] = (doublereal) i__;
+/* L11861: */
+ }
+ return 0;
+L11851:
+ lm1 = *lm - 1;
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + *lm * b_dim1] = 0.;
+/* L11871: */
+ }
+ t = 0.;
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s = 0.;
+ i__2 = lm1;
+ for (l = 1; l <= i__2; ++l) {
+ s += (d__1 = b[i__ + l * b_dim1], abs(d__1));
+/* L11891: */
+ }
+ b[i__ + *lm * b_dim1] = s;
+ t += s;
+/* L11881: */
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + *lm * b_dim1] = ww[i__] * (t - b[i__ + *lm * b_dim1]);
+/* L11901: */
+ }
+ l1 = 1;
+ if (*lm > *q) {
+ l1 = *lm - *q + 1;
+ }
+ i__1 = lm1;
+ for (l = l1; l <= i__1; ++l) {
+ s = 0.;
+ t = s;
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ s += ww[i__] * b[i__ + *lm * b_dim1] * b[i__ + l * b_dim1];
+/* Computing 2nd power */
+ d__1 = b[i__ + l * b_dim1];
+ t += ww[i__] * (d__1 * d__1);
+/* L11921: */
+ }
+ s /= sqrt(t);
+ i__2 = *q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ b[i__ + *lm * b_dim1] -= s * b[i__ + l * b_dim1];
+/* L11931: */
+ }
+/* L11911: */
+ }
+ i__1 = *q;
+ for (i__ = 2; i__ <= i__1; ++i__) {
+ if ((d__1 = b[i__ - 1 + *lm * b_dim1] - b[i__ + *lm * b_dim1], abs(
+ d__1)) > sml) {
+ return 0;
+ }
+/* L11941: */
+ }
+ i__1 = *q;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ b[i__ + *lm * b_dim1] = (doublereal) i__;
+/* L11951: */
+ }
+ return 0;
+} /* newb_ */
+
+/* Subroutine */ int bkppr_(void)
+{
+ return 0;
+} /* bkppr_ */
+
+/* Common Vars */
+
+/* Subroutine */ int setppr_(doublereal *span1, doublereal *alpha1, integer *
+ optlevel, integer *ism, doublereal *df1, doublereal *gcvpen1)
+{
+/* Put 'parameters' into Common blocks */
+ pprpar_1.span = *span1;
+ pprpar_1.lf = *optlevel;
+ pprpar_1.alpha = *alpha1;
+ if (*ism >= 0) {
+ spsmooth_1.ismethod = *ism;
+ spsmooth_1.trace = FALSE_;
+ } else {
+ spsmooth_1.ismethod = -(*ism + 1);
+ spsmooth_1.trace = TRUE_;
+ }
+ spsmooth_1.df = *df1;
+ spsmooth_1.gcvpen = *gcvpen1;
+ return 0;
+} /* setppr_ */
+
+/* Subroutine */ int fsort_(integer *mu, integer *n, doublereal *f,
+ doublereal *t, doublereal *sp)
+{
+ /* System generated locals */
+ integer f_dim1, f_offset, t_dim1, t_offset, sp_dim1, sp_offset, i__1,
+ i__2;
+
+ /* Local variables */
+ static integer j, k, l;
+ extern /* Subroutine */ int sort_(doublereal *, doublereal *, integer *,
+ integer *);
+
+
+
+ /* Parameter adjustments */
+ sp_dim1 = *n;
+ sp_offset = 1 + sp_dim1;
+ sp -= sp_offset;
+ t_dim1 = *n;
+ t_offset = 1 + t_dim1;
+ t -= t_offset;
+ f_dim1 = *n;
+ f_offset = 1 + f_dim1;
+ f -= f_offset;
+
+ /* Function Body */
+ i__1 = *mu;
+ for (l = 1; l <= i__1; ++l) {
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ sp[j + sp_dim1] = j + .1;
+ sp[j + (sp_dim1 << 1)] = f[j + l * f_dim1];
+/* L10: */
+ }
+ sort_(&t[l * t_dim1 + 1], &sp[sp_offset], &c__1, n);
+ i__2 = *n;
+ for (j = 1; j <= i__2; ++j) {
+ k = (integer) sp[j + sp_dim1];
+ f[j + l * f_dim1] = sp[k + (sp_dim1 << 1)];
+/* L20: */
+ }
+/* L100: */
+ }
+ return 0;
+} /* fsort_ */
+
+/* Subroutine */ int pppred_(integer *np, doublereal *x, doublereal *smod,
+ doublereal *y, doublereal *sc)
+{
+ /* System generated locals */
+ integer x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, i__3;
+
+ /* Local variables */
+ static integer i__, j, l, m, n, p, q;
+ static doublereal s, t;
+ static integer ja, jb, jf, jt, mu;
+ static doublereal ys;
+ static integer jfh, jfl, jth, inp, jtl, low, high, place;
+ extern /* Subroutine */ int fsort_(integer *, integer *, doublereal *,
+ doublereal *, doublereal *);
+
+ /* Parameter adjustments */
+ y_dim1 = *np;
+ y_offset = 1 + y_dim1;
+ y -= y_offset;
+ x_dim1 = *np;
+ x_offset = 1 + x_dim1;
+ x -= x_offset;
+ --smod;
+ --sc;
+
+ /* Function Body */
+ m = (integer) (smod[1] + .1);
+ p = (integer) (smod[2] + .1);
+ q = (integer) (smod[3] + .1);
+ n = (integer) (smod[4] + .1);
+ mu = (integer) (smod[5] + .1);
+ ys = smod[q + 6];
+ ja = q + 6;
+ jb = ja + p * m;
+ jf = jb + m * q;
+ jt = jf + n * m;
+ fsort_(&mu, &n, &smod[jf + 1], &smod[jt + 1], &sc[1]);
+ i__1 = *np;
+ for (inp = 1; inp <= i__1; ++inp) {
+ ja = q + 6;
+ jb = ja + p * m;
+ jf = jb + m * q;
+ jt = jf + n * m;
+ i__2 = q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[inp + i__ * y_dim1] = 0.;
+/* L81: */
+ }
+ i__2 = mu;
+ for (l = 1; l <= i__2; ++l) {
+ s = 0.;
+ i__3 = p;
+ for (j = 1; j <= i__3; ++j) {
+ s += smod[ja + j] * x[inp + j * x_dim1];
+/* L12201: */
+ }
+ if (s > smod[jt + 1]) {
+ goto L12221;
+ }
+ place = 1;
+ goto L12230;
+L12221:
+ if (s < smod[jt + n]) {
+ goto L12251;
+ }
+ place = n;
+ goto L12230;
+L12251:
+ low = 0;
+ high = n + 1;
+/* WHILE */
+L12261:
+ if (low + 1 >= high) {
+ goto L12262;
+ }
+ place = (low + high) / 2;
+ t = smod[jt + place];
+ if (s == t) {
+ goto L12230;
+ }
+ if (s < t) {
+ high = place;
+ } else {
+ low = place;
+ }
+ goto L12261;
+/* END */
+L12262:
+ jfl = jf + low;
+ jfh = jf + high;
+ jtl = jt + low;
+ jth = jt + high;
+ t = smod[jfl] + (smod[jfh] - smod[jfl]) * (s - smod[jtl]) / (smod[
+ jth] - smod[jtl]);
+ goto L12300;
+L12230:
+ t = smod[jf + place];
+L12300:
+ i__3 = q;
+ for (i__ = 1; i__ <= i__3; ++i__) {
+ y[inp + i__ * y_dim1] += smod[jb + i__] * t;
+/* L12311: */
+ }
+ ja += p;
+ jb += q;
+ jf += n;
+ jt += n;
+/* L91: */
+ }
+ i__2 = q;
+ for (i__ = 1; i__ <= i__2; ++i__) {
+ y[inp + i__ * y_dim1] = ys * y[inp + i__ * y_dim1] + smod[i__ + 5]
+ ;
+/* L12321: */
+ }
+/* L100: */
+ }
+ return 0;
+} /* pppred_ */
+
+/* Called from R's supsmu() */
+/* Subroutine */ int setsmu_(integer *tr)
+{
+ spsmooth_1.ismethod = 0;
+ spsmooth_1.trace = *tr != 0;
+ return 0;
+} /* setsmu_ */
+
+/* Subroutine */ int supsmu_internal(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, integer *iper, doublereal *span, doublereal *alpha,
+ doublereal *smo, doublereal *sc, doublereal *edf, doublereal *h__)
+{
+ /* System generated locals */
+ integer sc_dim1, sc_offset, i__1;
+ doublereal d__1, d__2, d__3, d__4;
+
+ /* Builtin functions */
+ double pow_dd(doublereal *, doublereal *);
+
+ /* Local variables */
+ static doublereal a, f;
+ static integer i__, j;
+ static doublereal sw, sy;
+ static integer jper;
+ static doublereal scale;
+ extern /* Subroutine */ int spline_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+ static doublereal resmin;
+ extern /* Subroutine */ int smooth_(integer *, doublereal *, doublereal *,
+ doublereal *, doublereal *, integer *, doublereal *, doublereal *
+ , doublereal *);
+ static doublereal vsmlsq;
+
+
+/* ------------------------------------------------------------------ */
+
+/* super smoother (Friedman, 1984). */
+
+/* version 10/10/84 */
+
+/* coded and copywrite (c) 1984 by: */
+
+/* Jerome H. Friedman */
+/* department of statistics */
+/* and */
+/* stanford linear accelerator center */
+/* stanford university */
+
+/* all rights reserved. */
+
+
+/* input: */
+/* n : number of observations (x,y - pairs). */
+/* x(n) : ordered abscissa values. */
+/* y(n) : corresponding ordinate (response) values. */
+/* w(n) : weight for each (x,y) observation. */
+/* iper : periodic variable flag. */
+/* iper=1 => x is ordered interval variable. */
+/* iper=2 => x is a periodic variable with values */
+/* in the range (0.0,1.0) and period 1.0. */
+/* span : smoother span (fraction of observations in window). */
+/* span=0.0 <=> "cv" : automatic (variable) span selection. */
+/* alpha : controls high frequency (small span) penality */
+/* used with automatic span selection (bass tone control). */
+/* (alpha.le.0.0 or alpha.gt.10.0 => no effect.) */
+/* output: */
+/* smo(n) : smoothed ordinate (response) values. */
+/* scratch: */
+/* sc(n,7) : internal working storage. */
+
+/* note: */
+/* for small samples (n < 40) or if there are substantial serial */
+/* correlations between observations close in x - value, then */
+/* a prespecified fixed span smoother (span > 0) should be */
+/* used. reasonable span values are 0.2 to 0.4. */
+
+/* ------------------------------------------------------------------ */
+/* Args */
+/* Var */
+/* Called from R's supsmu(), ismethod = 0, always (but not when called from ppr) */
+ /* Parameter adjustments */
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --smo;
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ if (x[*n] > x[1]) {
+ goto L30;
+ }
+/* x(n) <= x(1) : boundary case: smo[.] := weighted mean( y ) */
+ sy = 0.;
+ sw = sy;
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ sy += w[j] * y[j];
+ sw += w[j];
+/* L10: */
+ }
+ a = 0.;
+ if (sw > 0.) {
+ a = sy / sw;
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ smo[j] = a;
+/* L20: */
+ }
+ return 0;
+/* Normal Case */
+L30:
+ if (spsmooth_1.ismethod != 0) {
+/* possible only when called from ppr() */
+ spline_(n, &x[1], &y[1], &w[1], &smo[1], edf, &sc[sc_offset]);
+ } else {
+ i__ = *n / 4;
+ j = i__ * 3;
+ scale = x[j] - x[i__];
+/* = IQR(x) */
+L40:
+ if (scale > 0.) {
+ goto L50;
+ }
+ if (j < *n) {
+ ++j;
+ }
+ if (i__ > 1) {
+ --i__;
+ }
+ scale = x[j] - x[i__];
+ goto L40;
+L50:
+/* Computing 2nd power */
+ d__1 = consts_1.eps * scale;
+ vsmlsq = d__1 * d__1;
+ jper = *iper;
+ if (*iper == 2 && (x[1] < 0. || x[*n] > 1.)) {
+ jper = 1;
+ }
+ if (jper < 1 || jper > 2) {
+ jper = 1;
+ }
+ if (*span > 0.) {
+ smooth_(n, &x[1], &y[1], &w[1], span, &jper, &vsmlsq, &smo[1], &
+ sc[sc_offset]);
+ return 0;
+ }
+/* else "cv" (crossvalidation) from three spans[] */
+ for (i__ = 1; i__ <= 3; ++i__) {
+ smooth_(n, &x[1], &y[1], &w[1], &spans_1.spans[i__ - 1], &jper, &
+ vsmlsq, &sc[((i__ << 1) - 1) * sc_dim1 + 1], &sc[sc_dim1 *
+ 7 + 1]);
+ i__1 = -jper;
+ smooth_(n, &x[1], &sc[sc_dim1 * 7 + 1], &w[1], &spans_1.spans[1],
+ &i__1, &vsmlsq, &sc[(i__ << 1) * sc_dim1 + 1], h__);
+/* L70: */
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ resmin = consts_1.big;
+ for (i__ = 1; i__ <= 3; ++i__) {
+ if (sc[j + (i__ << 1) * sc_dim1] >= resmin) {
+ goto L80;
+ }
+ resmin = sc[j + (i__ << 1) * sc_dim1];
+ sc[j + sc_dim1 * 7] = spans_1.spans[i__ - 1];
+L80:
+ ;
+ }
+ if (*alpha > 0. && *alpha <= 10. && resmin < sc[j + sc_dim1 * 6]
+ && resmin > 0.) {
+/* Computing MAX */
+ d__2 = consts_1.sml, d__3 = resmin / sc[j + sc_dim1 * 6];
+ d__1 = max(d__2,d__3);
+ d__4 = 10. - *alpha;
+ sc[j + sc_dim1 * 7] += (spans_1.spans[2] - sc[j + sc_dim1 * 7]
+ ) * pow_dd(&d__1, &d__4);
+ }
+/* L90: */
+ }
+ i__1 = -jper;
+ smooth_(n, &x[1], &sc[sc_dim1 * 7 + 1], &w[1], &spans_1.spans[1], &
+ i__1, &vsmlsq, &sc[(sc_dim1 << 1) + 1], h__);
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ if (sc[j + (sc_dim1 << 1)] <= spans_1.spans[0]) {
+ sc[j + (sc_dim1 << 1)] = spans_1.spans[0];
+ }
+ if (sc[j + (sc_dim1 << 1)] >= spans_1.spans[2]) {
+ sc[j + (sc_dim1 << 1)] = spans_1.spans[2];
+ }
+ f = sc[j + (sc_dim1 << 1)] - spans_1.spans[1];
+ if (f >= 0.) {
+ goto L100;
+ }
+ f = -f / (spans_1.spans[1] - spans_1.spans[0]);
+ sc[j + (sc_dim1 << 2)] = (1. - f) * sc[j + sc_dim1 * 3] + f * sc[
+ j + sc_dim1];
+ goto L110;
+L100:
+ f /= spans_1.spans[2] - spans_1.spans[1];
+ sc[j + (sc_dim1 << 2)] = (1. - f) * sc[j + sc_dim1 * 3] + f * sc[
+ j + sc_dim1 * 5];
+L110:
+ ;
+ }
+ i__1 = -jper;
+ smooth_(n, &x[1], &sc[(sc_dim1 << 2) + 1], &w[1], spans_1.spans, &
+ i__1, &vsmlsq, &smo[1], h__);
+ *edf = 0.;
+ }
+ return 0;
+} /* supsmu_ */
+
+/* Subroutine */ int supsmu_(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, integer *iper, doublereal *span, doublereal *alpha,
+ doublereal *smo, doublereal *sc, doublereal *edf)
+{
+ doublereal *h__;
+ h__ = malloc((*n)*sizeof(doublereal*));
+ int res = supsmu_internal(n, x, y, w, iper, span, alpha, smo, sc, edf, h__);
+ free(h__);
+ return res;
+}
+
+/* Subroutine */ int smooth_(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, doublereal *span, integer *iper, doublereal *vsmlsq,
+ doublereal *smo, doublereal *acvr)
+{
+ /* System generated locals */
+ integer i__1;
+ doublereal d__1;
+
+ /* Local variables */
+ static doublereal a, h__;
+ static integer i__, j, j0;
+ extern /* Subroutine */ int smoothprt_(doublereal *, integer *,
+ doublereal *, doublereal *);
+ static integer in, it;
+ static doublereal xm, ym, wt, sy, fbo, fbw;
+ static integer ibw;
+ static doublereal var, tmp, xti;
+ static integer out;
+ static doublereal xto, cvar;
+ static integer jper;
+
+/* Args */
+/* Var */
+/* will use 'trace': */
+ /* Parameter adjustments */
+ --acvr;
+ --smo;
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ xm = 0.;
+ ym = xm;
+ var = ym;
+ cvar = var;
+ fbw = cvar;
+ jper = abs(*iper);
+ ibw = (integer) (*span * .5 * *n + .5);
+ if (ibw < 2) {
+ ibw = 2;
+ }
+ it = (ibw << 1) + 1;
+ if (it > *n) {
+ it = *n;
+ }
+ i__1 = it;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ j = i__;
+ if (jper == 2) {
+ j = i__ - ibw - 1;
+ }
+ if (j >= 1) {
+ xti = x[j];
+ } else {
+/* if (j.lt.1) then */
+ j = *n + j;
+ xti = x[j] - 1.;
+ }
+ wt = w[j];
+ fbo = fbw;
+ fbw += wt;
+ if (fbw > 0.) {
+ xm = (fbo * xm + wt * xti) / fbw;
+ }
+ if (fbw > 0.) {
+ ym = (fbo * ym + wt * y[j]) / fbw;
+ }
+ tmp = 0.;
+ if (fbo > 0.) {
+ tmp = fbw * wt * (xti - xm) / fbo;
+ }
+ var += tmp * (xti - xm);
+ cvar += tmp * (y[j] - ym);
+ }
+ i__1 = *n;
+ for (j = 1; j <= i__1; ++j) {
+ out = j - ibw - 1;
+ in = j + ibw;
+ if (jper != 2 && (out < 1 || in > *n)) {
+ goto L60;
+ }
+ if (out < 1) {
+ out = *n + out;
+ xto = x[out] - 1.;
+ xti = x[in];
+ } else if (in > *n) {
+ in -= *n;
+ xti = x[in] + 1.;
+ xto = x[out];
+ } else {
+ xto = x[out];
+ xti = x[in];
+ }
+ wt = w[out];
+ fbo = fbw;
+ fbw -= wt;
+ tmp = 0.;
+ if (fbw > 0.) {
+ tmp = fbo * wt * (xto - xm) / fbw;
+ }
+ var -= tmp * (xto - xm);
+ cvar -= tmp * (y[out] - ym);
+ if (fbw > 0.) {
+ xm = (fbo * xm - wt * xto) / fbw;
+ }
+ if (fbw > 0.) {
+ ym = (fbo * ym - wt * y[out]) / fbw;
+ }
+ wt = w[in];
+ fbo = fbw;
+ fbw += wt;
+ if (fbw > 0.) {
+ xm = (fbo * xm + wt * xti) / fbw;
+ }
+ if (fbw > 0.) {
+ ym = (fbo * ym + wt * y[in]) / fbw;
+ }
+ tmp = 0.;
+ if (fbo > 0.) {
+ tmp = fbw * wt * (xti - xm) / fbo;
+ }
+ var += tmp * (xti - xm);
+ cvar += tmp * (y[in] - ym);
+L60:
+ a = 0.;
+ if (var > *vsmlsq) {
+ a = cvar / var;
+ }
+ smo[j] = a * (x[j] - xm) + ym;
+ if (*iper > 0) {
+ h__ = 0.;
+ if (fbw > 0.) {
+ h__ = 1. / fbw;
+ }
+ if (var > *vsmlsq) {
+/* Computing 2nd power */
+ d__1 = x[j] - xm;
+ h__ += d__1 * d__1 / var;
+ }
+ acvr[j] = 0.;
+ a = 1. - w[j] * h__;
+ if (a > 0.) {
+ acvr[j] = (d__1 = y[j] - smo[j], abs(d__1)) / a;
+ } else if (j > 1) {
+ acvr[j] = acvr[j - 1];
+ }
+ }
+/* L80: */
+ }
+ if (spsmooth_1.trace) {
+ smoothprt_(span, iper, &var, &cvar);
+ }
+/* -- Recompute fitted values smo(j) as weighted mean for non-unique x(.) values: */
+/* -> ./ksmooth.c */
+ j = 1;
+L90:
+ j0 = j;
+ sy = smo[j] * w[j];
+ fbw = w[j];
+ if (j >= *n) {
+ goto L110;
+ }
+L100:
+ if (x[j + 1] <= x[j]) {
+ ++j;
+ sy += w[j] * smo[j];
+ fbw += w[j];
+ if (j < *n) {
+ goto L100;
+ }
+ }
+L110:
+ if (j > j0) {
+ a = 0.;
+ if (fbw > 0.) {
+ a = sy / fbw;
+ }
+ i__1 = j;
+ for (i__ = j0; i__ <= i__1; ++i__) {
+ smo[i__] = a;
+ }
+ }
+ ++j;
+ if (j <= *n) {
+ goto L90;
+ }
+ return 0;
+} /* smooth_ */
+
+/* Subroutine */ int bksupsmu_(void)
+{
+ return 0;
+} /* bksupsmu_ */
+
+
+/* --------------------------------------------------------------- */
+
+/* this sets the compile time (default) values for various */
+/* internal parameters : */
+
+/* spans : span values for the three running linear smoothers. */
+/* spans(1) : tweeter span. */
+/* spans(2) : midrange span. */
+/* spans(3) : woofer span. */
+/* (these span values should be changed only with care.) */
+/* big : a large representable floating point number. */
+/* sml : a small number. should be set so that (sml)**(10.0) does */
+/* not cause floating point underflow. */
+/* eps : used to numerically stabilize slope calculations for */
+/* running linear fits. */
+
+/* these parameter values can be changed by declaring the */
+/* relevant labeled common in the main program and resetting */
+/* them with executable statements. */
+
+/* Only for ppr(*, ismethod != 0): Compute "smoothing" spline */
+/* (rather, a penalized regression spline with at most 15 (inner) knots): */
+/* ----------------------------------------------------------------- */
+
+/* Subroutine */ int spline_(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, doublereal *smo, doublereal *edf, doublereal *sc)
+{
+ /* System generated locals */
+ integer sc_dim1, sc_offset;
+
+ /* Local variables */
+ extern /* Subroutine */ int splineaa_(integer *, doublereal *, doublereal
+ *, doublereal *, doublereal *, doublereal *, doublereal *,
+ doublereal *, doublereal *, doublereal *, doublereal *);
+
+
+/* ------------------------------------------------------------------ */
+
+/* input: */
+/* n : number of observations. */
+/* x(n) : ordered abscissa values. */
+/* y(n) : corresponding ordinate (response) values. */
+/* w(n) : weight for each (x,y) observation. */
+/* work space: */
+/* sc(n,7) : used for dx(n), dy(n), dw(n), dsmo(n), lev(n) */
+/* output: */
+/* smo(n) : smoothed ordinate (response) values. */
+/* edf : equivalent degrees of freedom */
+
+/* ------------------------------------------------------------------ */
+/* Args */
+ /* Parameter adjustments */
+ sc_dim1 = *n;
+ sc_offset = 1 + sc_dim1;
+ sc -= sc_offset;
+ --smo;
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ splineaa_(n, &x[1], &y[1], &w[1], &smo[1], edf, &sc[*n + sc_dim1], &sc[*n
+ + (sc_dim1 << 1)], &sc[*n + sc_dim1 * 3], &sc[*n + (sc_dim1 << 2)]
+ , &sc[*n + sc_dim1 * 5]);
+/* dx */
+/* dy */
+/* dw */
+/* dsmo */
+/* lev */
+ return 0;
+} /* spline_ */
+
+/* Subroutine */ int splineaa_(integer *n, doublereal *x, doublereal *y,
+ doublereal *w, doublereal *smo, doublereal *edf, doublereal *dx,
+ doublereal *dy, doublereal *dw, doublereal *dsmo, doublereal *lev)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ static integer i__;
+ static doublereal p, s;
+ extern /* Subroutine */ int splineprt_(doublereal *, doublereal *,
+ integer *, doublereal *, doublereal *);
+ static integer nk, ip;
+ static doublereal df1;
+ static integer ier;
+ static doublereal coef[25], crit, knot[29], work[1050], param[5];
+ extern /* Subroutine */ int rbart_(doublereal *, doublereal *, doublereal
+ *, doublereal *, doublereal *, doublereal *, integer *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *,
+ doublereal *, integer *, doublereal *, doublereal *, doublereal *
+ , integer *, integer *, integer *), intpr_(char *, integer *,
+ integer *, integer *, ftnlen);
+ static doublereal lambda;
+ static integer iparms[4];
+
+
+/* Workhorse of spline() above */
+/* ------------------------------------------------------------------ */
+
+/* Additional input variables (no extra output, work): */
+/* dx : */
+/* dy : */
+/* dw : */
+/* dsmo: */
+/* lev : "leverages", i.e., diagonal entries S_{i,i} of the smoother matrix */
+
+/* ------------------------------------------------------------------ */
+/* Args */
+/* Var */
+/* __no-more__ if (n .gt. 2500) call bdrsplerr() */
+ /* Parameter adjustments */
+ --lev;
+ --dsmo;
+ --dw;
+ --dy;
+ --dx;
+ --smo;
+ --w;
+ --y;
+ --x;
+
+ /* Function Body */
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ dx[i__] = (x[i__] - x[1]) / (x[*n] - x[1]);
+ dy[i__] = y[i__];
+ dw[i__] = w[i__];
+ }
+ nk = min(*n,15);
+ knot[0] = dx[1];
+ knot[1] = dx[1];
+ knot[2] = dx[1];
+ knot[3] = dx[1];
+ knot[nk] = dx[*n];
+ knot[nk + 1] = dx[*n];
+ knot[nk + 2] = dx[*n];
+ knot[nk + 3] = dx[*n];
+ i__1 = nk;
+ for (i__ = 5; i__ <= i__1; ++i__) {
+ p = (*n - 1) * (real) (i__ - 4) / (real) (nk - 3);
+ ip = (integer) p;
+ p -= ip;
+ knot[i__ - 1] = (1 - p) * dx[ip + 1] + p * dx[ip + 2];
+ }
+/* call dblepr('knots', 5, knot, nk+4) */
+/* iparms(1:2) := (icrit, ispar) for ./sbart.c */
+ if (spsmooth_1.ismethod == 1) {
+ iparms[0] = 3;
+ df1 = spsmooth_1.df;
+ } else {
+ iparms[0] = 1;
+ df1 = 0.;
+ }
+
+ iparms[1] = 0;
+/* ispar := 0 <==> estimate `spar' */
+ iparms[2] = 500;
+/* maxit = 500 */
+ iparms[3] = 0;
+
+/* spar (!= lambda) */
+ param[0] = 0.;
+/* = lspar : min{spar} */
+ param[1] = 1.5;
+/* tol for 'spar' estimation: */
+/* = uspar : max{spar} */
+ param[2] = .01;
+/* 'eps' (~= 2^-12 = sqrt(2^-24) ?= sqrt(machine eps)) in ./sbart.c : */
+ param[3] = 2.44e-4f;
+ ier = 1;
+ rbart_(&spsmooth_1.gcvpen, &df1, &dx[1], &dy[1], &dw[1], &c_b183, n, knot,
+ &nk, coef, &dsmo[1], &lev[1], &crit, iparms, &lambda, param,
+ work, &c__4, &c__1, &ier);
+ if (ier > 0) {
+ intpr_("spline(.) TROUBLE:", &c__18, &ier, &c__1, (ftnlen)18);
+ }
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ smo[i__] = dsmo[i__];
+ }
+/* call dblepr('smoothed',8, dsmo, n) */
+ s = 0.;
+ i__1 = *n;
+ for (i__ = 1; i__ <= i__1; ++i__) {
+ s += lev[i__];
+ }
+ *edf = s;
+ if (spsmooth_1.trace) {
+ splineprt_(&spsmooth_1.df, &spsmooth_1.gcvpen, &spsmooth_1.ismethod, &
+ lambda, edf);
+ }
+ return 0;
+} /* splineaa_ */
+
+/* ********************************************************************** */
+/* === This was 'sort()' in gamfit's mysort.f [or sortdi() in sortdi.f ] : */
+
+/* === FIXME: Translate to C and add to ../../../main/sort.c <<<<< */
+
+/* a[] is double precision because the caller reuses a double (sometimes v[] itself!) */
+/* Subroutine */ int sort_(doublereal *v, doublereal *a, integer *ii, integer
+ *jj)
+{
+ static integer i__, j, k, l, m, t, ij, il[20], iu[20], tt;
+ static doublereal vt, vtt;
+
+
+/* Puts into a the permutation vector which sorts v into */
+/* increasing order. Only elements from ii to jj are considered. */
+/* Arrays iu(k) and il(k) permit sorting up to 2**(k+1)-1 elements */
+
+/* This is a modification of CACM algorithm #347 by R. C. Singleton, */
+/* which is a modified Hoare quicksort. */
+
+
+ /* Parameter adjustments */
+ --v;
+ --a;
+
+ /* Function Body */
+ m = 1;
+ i__ = *ii;
+ j = *jj;
+L10:
+ if (i__ >= j) {
+ goto L80;
+ }
+L20:
+ k = i__;
+ ij = (j + i__) / 2;
+ t = (integer) a[ij];
+ vt = v[ij];
+ if (v[i__] <= vt) {
+ goto L30;
+ }
+ a[ij] = a[i__];
+ a[i__] = (doublereal) t;
+ t = (integer) a[ij];
+ v[ij] = v[i__];
+ v[i__] = vt;
+ vt = v[ij];
+L30:
+ l = j;
+ if (v[j] >= vt) {
+ goto L50;
+ }
+ a[ij] = a[j];
+ a[j] = (doublereal) t;
+ t = (integer) a[ij];
+ v[ij] = v[j];
+ v[j] = vt;
+ vt = v[ij];
+ if (v[i__] <= vt) {
+ goto L50;
+ }
+ a[ij] = a[i__];
+ a[i__] = (doublereal) t;
+ t = (integer) a[ij];
+ v[ij] = v[i__];
+ v[i__] = vt;
+ vt = v[ij];
+ goto L50;
+L40:
+ a[l] = a[k];
+ a[k] = (doublereal) tt;
+ v[l] = v[k];
+ v[k] = vtt;
+L50:
+ --l;
+ if (v[l] > vt) {
+ goto L50;
+ }
+ tt = (integer) a[l];
+ vtt = v[l];
+L60:
+ ++k;
+ if (v[k] < vt) {
+ goto L60;
+ }
+ if (k <= l) {
+ goto L40;
+ }
+ if (l - i__ <= j - k) {
+ goto L70;
+ }
+ il[m - 1] = i__;
+ iu[m - 1] = l;
+ i__ = k;
+ ++m;
+ goto L90;
+L70:
+ il[m - 1] = k;
+ iu[m - 1] = j;
+ j = l;
+ ++m;
+ goto L90;
+L80:
+ --m;
+ if (m == 0) {
+ return 0;
+ }
+ i__ = il[m - 1];
+ j = iu[m - 1];
+L90:
+ if (j - i__ > 10) {
+ goto L20;
+ }
+ if (i__ == *ii) {
+ goto L10;
+ }
+ --i__;
+L100:
+ ++i__;
+ if (i__ == j) {
+ goto L80;
+ }
+ t = (integer) a[i__ + 1];
+ vt = v[i__ + 1];
+ if (v[i__] <= vt) {
+ goto L100;
+ }
+ k = i__;
+L110:
+ a[k + 1] = a[k];
+ v[k + 1] = v[k];
+ --k;
+ if (vt < v[k]) {
+ goto L110;
+ }
+ a[k + 1] = (doublereal) t;
+ v[k + 1] = vt;
+ goto L100;
+} /* sort_ */
+
diff --git a/com.oracle.truffle.r.native/gnur/patch/src/library/tools/Makefile b/com.oracle.truffle.r.native/gnur/patch/src/library/tools/Makefile
index 9eeb1067bafe809108e1b2e0a931d0ec2ee145d3..e6df455de53f2c71c21d29c947a156910659d2b7 100644
--- a/com.oracle.truffle.r.native/gnur/patch/src/library/tools/Makefile
+++ b/com.oracle.truffle.r.native/gnur/patch/src/library/tools/Makefile
@@ -31,9 +31,6 @@ else
ifeq ($(FASTR_RFFI),llvm)
XTRA_C_SOURCES += $(SRC)/truffle_llvm/gramRd_llvm.c
XTRA_C_OBJECTS += $(OBJ)/gramRd_llvm.o
-SULONG_DIR = $(abspath $(FASTR_R_HOME)/../sulong)
-
-SULONG_INCLUDES = -I$(SULONG_DIR)/include
endif
endif
@@ -45,4 +42,4 @@ $(OBJ)/gramRd_nfi.o: $(SRC)/truffle_nfi/gramRd_nfi.c
$(CC) $(CFLAGS) $(FFI_INCLUDES) $(NFI_INCLUDES) -c $< -o $@
$(OBJ)/gramRd_llvm.o: $(SRC)/truffle_llvm/gramRd_llvm.c
- $(CC) $(CFLAGS) $(FFI_INCLUDES) $(SULONG_INCLUDES) -c $< -o $@
+ $(CC) $(CFLAGS) $(FFI_INCLUDES) -c $< -o $@
diff --git a/com.oracle.truffle.r.native/llvm_tools/llvm-ar b/com.oracle.truffle.r.native/llvm_tools/llvm-ar
index 390cfe4331ac54b05867a50e1b6c09986e6fdd9c..c17cdaf354cd1d7d5a9ef758e15751ef37994883 100755
--- a/com.oracle.truffle.r.native/llvm_tools/llvm-ar
+++ b/com.oracle.truffle.r.native/llvm_tools/llvm-ar
@@ -22,8 +22,11 @@
# questions.
#
+ORIG_CMD=$1
+shift
+
if [[ "$FASTR_RFFI" != 'llvm-only' ]]; then
- ar "$@"
+ ${ORIG_CMD} "$@"
fi
if [[ "$FASTR_RFFI" == 'nfi-only' ]]; then
exit 0
diff --git a/com.oracle.truffle.r.native/llvm_tools/llvm-c++ b/com.oracle.truffle.r.native/llvm_tools/llvm-c++
index a6cd013f896c514a70b4a2138ab77fff7ddf0719..3ddba626e1a9c1ebfdda8c334a0a8e2a0939b486 100755
--- a/com.oracle.truffle.r.native/llvm_tools/llvm-c++
+++ b/com.oracle.truffle.r.native/llvm_tools/llvm-c++
@@ -21,9 +21,11 @@
# or visit www.oracle.com if you need additional information or have any
# questions.
#
+ORIG_CMD=$1
+shift
if [[ "$FASTR_RFFI" != 'llvm-only' ]]; then
- g++ "$@"
+ ${ORIG_CMD} "$@"
fi
if [[ "$FASTR_RFFI" == 'nfi-only' ]]; then
exit 0
@@ -32,6 +34,16 @@ fi
SOURCE="$0"
DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
+SULONG_DIR=""
+if [ -f "${DIR}/../../sulong" ]
+then
+ # For a package build
+ SULONG_DIR="${DIR}/../../sulong"
+else
+ # For the FastR build
+ SULONG_DIR="${DIR}/../../../sulong"
+fi
+
. $DIR/llvm-helper
errorOccurred || {
@@ -55,7 +67,7 @@ else
if [[ "$unamestr" == 'Linux' ]]; then
llvm_args="-stdlib=libc++ -I/usr/include/libcxxabi ${llvm_args[@]}"
fi
- runit $llvm_tool_bin "${llvm_args[@]}"
+ runit $llvm_tool_bin -DSULONG "-I${SULONG_DIR}/include" "-I${SULONG_DIR}/mxbuild/sulong-libs" "-I${SULONG_DIR}/projects/com.oracle.truffle.llvm.libraries.bitcode/include" "${llvm_args[@]}"
ecode=$?
if [[ $ecode -ne 0 ]]; then
exit $ecode
diff --git a/com.oracle.truffle.r.native/llvm_tools/llvm-cc b/com.oracle.truffle.r.native/llvm_tools/llvm-cc
index 8b83f95858b8f5c9fc5723aab602983755376fb0..d6f87796d8fbd25e5f076e677401b6d87aa59dad 100755
--- a/com.oracle.truffle.r.native/llvm_tools/llvm-cc
+++ b/com.oracle.truffle.r.native/llvm_tools/llvm-cc
@@ -22,8 +22,11 @@
# questions.
#
+ORIG_CMD=$1
+shift
+
if [[ "$FASTR_RFFI" != 'llvm-only' ]]; then
- gcc "$@"
+ ${ORIG_CMD} "$@"
fi
if [[ "$FASTR_RFFI" == 'nfi-only' ]]; then
exit 0
@@ -32,6 +35,16 @@ fi
SOURCE="$0"
DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
+SULONG_DIR=""
+if [ -f "${DIR}/../../sulong" ]
+then
+ # For a package build
+ SULONG_DIR="${DIR}/../../sulong"
+else
+ # For the FastR build
+ SULONG_DIR="${DIR}/../../../sulong"
+fi
+
. $DIR/llvm-helper
errorOccurred || {
@@ -51,7 +64,7 @@ then
else
llvm_tool=clang
get_llvm_tool
- runit $llvm_tool_bin "${llvm_args[@]}"
+ runit $llvm_tool_bin -DSULONG "-I${SULONG_DIR}/include" "-I${SULONG_DIR}/mxbuild/sulong-libs" "-I${SULONG_DIR}/projects/com.oracle.truffle.llvm.libraries.bitcode/include" "${llvm_args[@]}"
ecode=$?
if [[ $ecode -ne 0 ]]; then
exit $ecode
diff --git a/com.oracle.truffle.r.native/llvm_tools/llvm-fc b/com.oracle.truffle.r.native/llvm_tools/llvm-fc
index 7a6bfea588bf29ad8206ff9b34922307c553853a..02273ac6a69a0b85f317abc7edd38927a3925d35 100755
--- a/com.oracle.truffle.r.native/llvm_tools/llvm-fc
+++ b/com.oracle.truffle.r.native/llvm_tools/llvm-fc
@@ -22,12 +22,11 @@
# questions.
#
-echo "ARGS: $@"
-
-echo "llvm-fc FASTR_RFFI $FASTR_RFFI"
+ORIG_CMD=$1
+shift
if [[ "$FASTR_RFFI" != 'llvm-only' ]]; then
- gfortran "$@"
+ ${ORIG_CMD} "$@"
fi
if [[ "$FASTR_RFFI" == 'nfi-only' ]]; then
exit 0
@@ -36,49 +35,63 @@ fi
SOURCE="$0"
DIR="$( cd -P "$( dirname "$SOURCE" )" && pwd )"
+F2C=""
+F2C_H_INCLUDE="${DIR}/../include/"
+if [ -f "${DIR}/f2c" ]
+then
+ # For a package build
+ F2C="${DIR}/../f2c/f2c/f2c"
+else
+ # For the FastR build
+ F2C="${DIR}/../../bin/f2c"
+fi
+
. $DIR/llvm-helper
errorOccurred || {
try
(
-fortran=1
-analyze_args "$@"
+ find_source_and_target "$@"
-if [ -z "$FASTR_LLVM_GFORTRAN" ]
-then
- echo FASTR_LLVM_GFORTRAN must be set
- exit 1
-fi
+ target_file=`basename ${source_file}`
+ target_file=${target_file%%.*}
+ target_file="${target_dir}/${target_file}.c"
-if [ -z "$FASTR_LLVM_GFORTRAN_LLVM_AS" ]
-then
- echo FASTR_LLVM_GFORTRAN_LLVM_AS must be set
- exit 1
-fi
-
-if [ -z "$FASTR_LLVM_DRAGONEGG" ]
-then
- echo FASTR_DRAGONEGG must be set
- exit 1
-fi
+ if [ -f "${source_file}_c" ]
+ then
+ # Just copy the patched pre-transformed C source to the target dir,
+ # simulating so the f2c transformation
+ cp "${source_file}_c" "${target_file}"
+ else
+ $F2C "${source_file}" "-d${target_dir}"
+ ecode=$?
+ if [[ $ecode -ne 0 ]]; then
+ exit $ecode
+ fi
+ fi
+
+ replace_arg_from="${source_file}"
+ replace_arg_to="${target_file}"
+ fortran=1
+ analyze_args "$@"
-function ll_to_bc() {
- f=`basename $llvm_ir_file`
- d=`dirname $llvm_ir_file`
- llvm_ir_bc_file=${d}/${f%%.*}.bc
-}
+ llvm_tool=clang
+ get_llvm_tool
+ runit $llvm_tool_bin -I${F2C_H_INCLUDE} "${llvm_args[@]}"
+ ecode=$?
+ if [[ $ecode -ne 0 ]]; then
+ exit $ecode
+ fi
-runit $FASTR_LLVM_GFORTRAN -fplugin=$FASTR_LLVM_DRAGONEGG -fplugin-arg-dragonegg-emit-ir "${llvm_args[@]}"
-ll_to_bc
-runit $FASTR_LLVM_GFORTRAN_LLVM_AS $llvm_ir_file -o $llvm_ir_bc_file
-runit rm $llvm_ir_file
-llvm_ir_file=$llvm_ir_bc_file
-# the llvm_ir_file is empty if the result is sent to stdout
-if [ -n "$llvm_ir_file" ]; then
- mem2reg_opt
- #fake_obj
-fi
+ # the llvm_ir_file is empty if the result is sent to stdout
+ if [ -n "$llvm_ir_file" ]; then
+ mem2reg_opt
+ ecode=$?
+ if [[ $ecode -ne 0 ]]; then
+ exit $ecode
+ fi
+ fi
) || catch || {
recordError
diff --git a/com.oracle.truffle.r.native/llvm_tools/llvm-helper b/com.oracle.truffle.r.native/llvm_tools/llvm-helper
index 7164390ac123dcffe911b2375db8493824d828e1..a7ce6b137890d83c68df9c3d9d7d49269eb82b84 100644
--- a/com.oracle.truffle.r.native/llvm_tools/llvm-helper
+++ b/com.oracle.truffle.r.native/llvm_tools/llvm-helper
@@ -48,17 +48,14 @@ function runit() {
# llvm_ir_file: name of file containing LLVM IR, e.g. foo.bc
# llvm_file_ext: extension of above, e.g. .bc
# llvm_args: processed arguments to pass to llvm tool, e.g. clang
+# replace_arg_from: the argument to be replaced by replace_arg_to
+# replace_arg_to: the replacement of the argument specified in replace_arg_from
function analyze_args() {
llvm_args_tmp=()
llvm_args_tmp+=("-g")
- if [ $fortran -eq 1 ]
- then
- llvm_file_ext='.ll'
- else
- llvm_file_ext='.bc'
- fi
-
+ llvm_file_ext='.bc'
+
is_link=0
out_file_opt=()
llvm_ir_file=""
@@ -68,6 +65,9 @@ function analyze_args() {
while [[ $# -gt 0 ]]
do
case $1 in
+ -fpic)
+ shift
+ ;;
-c)
c_opt_found=1
llvm_args_tmp+=("$1")
@@ -91,36 +91,55 @@ function analyze_args() {
fi
;;
*)
- llvm_args_tmp+=("$1")
+ if [ ! -z "$replace_arg_from" -a "$1" == "$replace_arg_from" ]
+ then
+ llvm_args_tmp+=("$replace_arg_to")
+ else
+ llvm_args_tmp+=("$1")
+ fi
;;
esac
shift
done
llvm_args=()
- if [ $fortran -eq 1 ]
+
+ if [ $c_opt_found -eq 1 ]
then
- if [ $c_opt_found -eq 1 ]
- then
- llvm_args+=("-S")
- llvm_args+=("${llvm_ir_file_opt[@]}")
- llvm_args+=("${llvm_args_tmp[@]}")
- else
- llvm_args+=("${out_file_opt[@]}")
- llvm_args+=("${llvm_args_tmp[@]}")
- fi
+ llvm_args+=("-emit-llvm")
+ llvm_args+=("${llvm_ir_file_opt[@]}")
+ llvm_args+=("${llvm_args_tmp[@]}")
else
- if [ $c_opt_found -eq 1 ]
- then
- llvm_args+=("-emit-llvm")
- llvm_args+=("${llvm_ir_file_opt[@]}")
- llvm_args+=("${llvm_args_tmp[@]}")
- else
- llvm_args+=("${out_file_opt[@]}")
- llvm_args+=("${llvm_args_tmp[@]}")
- fi
+ llvm_args+=("${out_file_opt[@]}")
+ llvm_args+=("${llvm_args_tmp[@]}")
fi
+ echo "Effective args: ${llvm_args[@]}"
+}
+
+function find_source_and_target() {
+ source_file=""
+ while [[ $# -gt 0 ]]
+ do
+ case $1 in
+ -o)
+ shift
+ d=`dirname $1`
+ target_dir=${d}
+ ;;
+ -I)
+ shift
+ ;;
+ -I*)
+ ;;
+ -*)
+ ;;
+ *)
+ source_file=$1
+ ;;
+ esac
+ shift
+ done
}
# Input arguments:
diff --git a/com.oracle.truffle.r.native/run/Makefile b/com.oracle.truffle.r.native/run/Makefile
index 5ee2435d2478265e312c3c2ff61985036fa8fffc..ce1a09a1aee8cbf13e3710c9d863052c1221152b 100644
--- a/com.oracle.truffle.r.native/run/Makefile
+++ b/com.oracle.truffle.r.native/run/Makefile
@@ -53,7 +53,7 @@ ETC_FILES := $(addprefix $(GNUR_HOME_BINARY)/etc/,javaconf ldpaths Renviron repo
SHARE_FILES := $(addprefix $(GNUR_HOME_BINARY)/share/,R Rd make java encodings)
-LLVM_TOOLS := $(wildcard $(FASTR_NATIVE_DIR)/llvm_tools/*)
+LLVM_TOOLS := $(wildcard $(FASTR_NATIVE_DIR)/llvm_tools/llvm-*)
all: rundirs rcmds includedir
diff --git a/com.oracle.truffle.r.native/run/edMakeconf.etc.llvm b/com.oracle.truffle.r.native/run/edMakeconf.etc.llvm
index c4972785f1b97ace17efcf41e7d9d36f203e2910..ede3effa4b2c5f178675f55480515d229f5274d8 100644
--- a/com.oracle.truffle.r.native/run/edMakeconf.etc.llvm
+++ b/com.oracle.truffle.r.native/run/edMakeconf.etc.llvm
@@ -1,37 +1,9 @@
-/^CC =/
-d
-i
-CC = $(R_HOME)/bin/llvm-cc
-.
-/^CXX =/
-d
-i
-CXX = $(R_HOME)/bin/llvm-c++
-.
-/^CXX11 =/
-d
-i
-CXX11 = $(R_HOME)/bin/llvm-c++
-.
-/^FC =/
-d
-i
-FC = $(R_HOME)/bin/llvm-fc
-.
-/^F77 =/
-d
-i
-F77 = $(R_HOME)/bin/llvm-fc
-.
-/^OBJC =/
-d
-i
-OBJC = $(R_HOME)/bin/llvm-cc
-.
-/^AR =/
-d
-i
-AR = $(R_HOME)/bin/llvm-ar
-.
+,s/CC[[:space:]]=\(.*\)/CC = $(R_HOME)\/bin\/llvm-cc\1/g
+,s/CXX[[:space:]]=\(.*\)/CXX = $(R_HOME)\/bin\/llvm-c++\1/g
+,s/CXX11[[:space:]]=\(.*\)/CXX11 = $(R_HOME)\/bin\/llvm-c++\1/g
+,s/FC[[:space:]]=\(.*\)/FC = $(R_HOME)\/bin\/llvm-fc\1/g
+,s/F77[[:space:]]=\(.*\)/F77 = $(R_HOME)\/bin\/llvm-fc\1/g
+,s/OBJC[[:space:]]=\(.*\)/OBJC = $(R_HOME)\/bin\/llvm-cc\1/g
+,s/AR[[:space:]]=\(.*\)/AR = $(R_HOME)\/bin\/llvm-ar\1/g
w
q
diff --git a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/access/BaseWriteVariableNode.java b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/access/BaseWriteVariableNode.java
index 8518b6e062a9206390c0855239fe7d66bb4c47f9..e5835846c04a8c71c9cd8171d0b8ce52ca4ccf13 100644
--- a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/access/BaseWriteVariableNode.java
+++ b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/access/BaseWriteVariableNode.java
@@ -26,6 +26,7 @@ import com.oracle.truffle.api.CompilerAsserts;
import com.oracle.truffle.api.CompilerDirectives;
import com.oracle.truffle.api.dsl.NodeChild;
import com.oracle.truffle.api.frame.Frame;
+import com.oracle.truffle.api.frame.FrameDescriptor;
import com.oracle.truffle.api.frame.FrameSlot;
import com.oracle.truffle.api.frame.FrameSlotKind;
import com.oracle.truffle.api.frame.FrameSlotTypeException;
@@ -134,30 +135,30 @@ abstract class BaseWriteVariableNode extends WriteVariableNode {
* The frame parameters are needed to keep the guards from being considered static.
*/
- protected boolean isLogicalKind(@SuppressWarnings("unused") Frame frame, FrameSlot frameSlot) {
- return isKind(frameSlot, FrameSlotKind.Boolean);
+ protected boolean isLogicalKind(Frame frame, FrameSlot frameSlot) {
+ return isKind(frame.getFrameDescriptor(), frameSlot, FrameSlotKind.Boolean);
}
- protected boolean isIntegerKind(@SuppressWarnings("unused") Frame frame, FrameSlot frameSlot) {
- return isKind(frameSlot, FrameSlotKind.Int);
+ protected boolean isIntegerKind(Frame frame, FrameSlot frameSlot) {
+ return isKind(frame.getFrameDescriptor(), frameSlot, FrameSlotKind.Int);
}
- protected boolean isDoubleKind(@SuppressWarnings("unused") Frame frame, FrameSlot frameSlot) {
- return isKind(frameSlot, FrameSlotKind.Double);
+ protected boolean isDoubleKind(Frame frame, FrameSlot frameSlot) {
+ return isKind(frame.getFrameDescriptor(), frameSlot, FrameSlotKind.Double);
}
- protected boolean isKind(FrameSlot frameSlot, FrameSlotKind kind) {
- if (frameSlot.getKind() == kind) {
+ protected boolean isKind(FrameDescriptor fd, FrameSlot frameSlot, FrameSlotKind kind) {
+ if (fd.getFrameSlotKind(frameSlot) == kind) {
return true;
} else {
initialSetKindProfile.enter();
- return initialSetKind(frameSlot, kind);
+ return initialSetKind(fd, frameSlot, kind);
}
}
- private static boolean initialSetKind(FrameSlot frameSlot, FrameSlotKind kind) {
- if (frameSlot.getKind() == FrameSlotKind.Illegal) {
- frameSlot.setKind(kind);
+ private static boolean initialSetKind(FrameDescriptor fd, FrameSlot frameSlot, FrameSlotKind kind) {
+ if (fd.getFrameSlotKind(frameSlot) == FrameSlotKind.Illegal) {
+ fd.setFrameSlotKind(frameSlot, kind);
return true;
}
return false;
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/CharSXPWrapperMR.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/CharSXPWrapperMR.java
index 28c15c1ead42b1802d1c6912e5bf20bfabde6cdf..c59e88a01b1315cfa7aeb5b5be823e6777e33951 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/CharSXPWrapperMR.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/CharSXPWrapperMR.java
@@ -29,7 +29,6 @@ import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.api.profiles.ConditionProfile;
import com.oracle.truffle.r.runtime.RInternalError;
-import com.oracle.truffle.r.runtime.interop.RObjectNativeWrapper;
@MessageResolution(receiverType = CharSXPWrapper.class)
public class CharSXPWrapperMR {
@@ -37,14 +36,21 @@ public class CharSXPWrapperMR {
@Resolve(message = "IS_POINTER")
public abstract static class IsPointerNode extends Node {
protected boolean access(@SuppressWarnings("unused") Object receiver) {
- return false;
+ return true;
+ }
+ }
+
+ @Resolve(message = "AS_POINTER")
+ public abstract static class AsPointerNode extends Node {
+ protected Object access(Object receiver) {
+ return NativeDataAccess.asPointer(receiver);
}
}
@Resolve(message = "TO_NATIVE")
public abstract static class ToNativeNode extends Node {
- protected Object access(RObject receiver) {
- return new RObjectNativeWrapper(receiver);
+ protected Object access(Object receiver) {
+ return receiver;
}
}
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/StringArrayWrapper.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/StringArrayWrapper.java
index fca1d3650f25fe213725bf585df0ffb14fd6c042..bb14a47772de0d9940c63127df0d0350038fdc60 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/StringArrayWrapper.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/StringArrayWrapper.java
@@ -29,10 +29,36 @@ import com.oracle.truffle.api.interop.Resolve;
import com.oracle.truffle.api.interop.TruffleObject;
import com.oracle.truffle.api.nodes.Node;
import com.oracle.truffle.api.profiles.ConditionProfile;
+import com.oracle.truffle.r.runtime.ffi.interop.NativeCharArray;
@MessageResolution(receiverType = StringArrayWrapper.class)
final class StringArrayWrapperMR {
+ @Resolve(message = "READ")
+ public abstract static class StringArrayWrapperReadNode extends Node {
+ protected Object access(StringArrayWrapper receiver, int index) {
+ return receiver.getNativeCharArray(index);
+ }
+
+ protected Object access(StringArrayWrapper receiver, long index) {
+ return receiver.getNativeCharArray((int) index);
+ }
+ }
+
+ @Resolve(message = "HAS_SIZE")
+ public abstract static class StringArrayWrapperHasSizeNode extends Node {
+ protected boolean access(@SuppressWarnings("unused") StringArrayWrapper receiver) {
+ return true;
+ }
+ }
+
+ @Resolve(message = "GET_SIZE")
+ public abstract static class StringArrayWrapperGetSizeNode extends Node {
+ protected int access(StringArrayWrapper receiver) {
+ return receiver.getLength();
+ }
+ }
+
@Resolve(message = "IS_POINTER")
public abstract static class StringArrayWrapperIsPointerNode extends Node {
protected Object access(@SuppressWarnings("unused") StringArrayWrapper receiver) {
@@ -65,6 +91,7 @@ public final class StringArrayWrapper implements TruffleObject {
long address;
private final RStringVector vector;
+ private NativeCharArray[] nativeCharArrays = null;
public StringArrayWrapper(RStringVector vector) {
this.vector = vector;
@@ -82,7 +109,23 @@ public final class StringArrayWrapper implements TruffleObject {
public RStringVector copyBackFromNative() {
if (address == 0) {
- return vector;
+ if (nativeCharArrays != null) {
+ String[] contents = new String[vector.getLength()];
+ for (int i = 0; i < contents.length; i++) {
+ NativeCharArray nativeCharArray = nativeCharArrays[i];
+ if (nativeCharArray == null) {
+ contents[i] = vector.getDataAt(i);
+ } else {
+ contents[i] = nativeCharArray.getString();
+ }
+ }
+ address = 0;
+ RStringVector copy = new RStringVector(contents, false);
+ copy.copyAttributesFrom(vector);
+ return copy;
+ } else {
+ return vector;
+ }
} else {
String[] contents = NativeDataAccess.releaseNativeStringArray(address, vector.getLength());
address = 0;
@@ -92,4 +135,20 @@ public final class StringArrayWrapper implements TruffleObject {
}
}
+ public int getLength() {
+ return vector.getLength();
+ }
+
+ public NativeCharArray getNativeCharArray(int index) {
+ if (nativeCharArrays == null) {
+ nativeCharArrays = new NativeCharArray[vector.getLength()];
+ }
+ NativeCharArray nativeCharArray = nativeCharArrays[index];
+ if (nativeCharArray == null) {
+ nativeCharArray = new NativeCharArray(vector.getDataAt(index));
+ nativeCharArrays[index] = nativeCharArray;
+ }
+ return nativeCharArray;
+ }
+
}
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/frame/REnvTruffleFrameAccess.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/frame/REnvTruffleFrameAccess.java
index 8e568a9e9c2779276e3c536c2b722a8275613a68..c3d96411060610f8672ebec0f485fb0b4efc1752 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/frame/REnvTruffleFrameAccess.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/frame/REnvTruffleFrameAccess.java
@@ -102,11 +102,10 @@ public final class REnvTruffleFrameAccess extends REnvFrameAccess {
FrameSlotKind valueSlotKind = RRuntime.getSlotKind(value);
FrameDescriptor fd = frame.getFrameDescriptor();
FrameSlot slot = FrameSlotChangeMonitor.findOrAddFrameSlot(fd, key, valueSlotKind);
-
- if (valueSlotKind != slot.getKind()) {
+ if (valueSlotKind != fd.getFrameSlotKind(slot)) {
// we must not toggle between slot kinds, so go to Object
valueSlotKind = FrameSlotKind.Object;
- slot.setKind(valueSlotKind);
+ fd.setFrameSlotKind(slot, valueSlotKind);
}
switch (valueSlotKind) {
@@ -155,8 +154,8 @@ public final class REnvTruffleFrameAccess extends REnvFrameAccess {
// TODO: also throw this error when slot contains "null" value
throw new PutException(RError.Message.UNKNOWN_OBJECT, key);
} else {
- if (slot.getKind() != FrameSlotKind.Object) {
- slot.setKind(FrameSlotKind.Object);
+ if (fd.getFrameSlotKind(slot) != FrameSlotKind.Object) {
+ fd.setFrameSlotKind(slot, FrameSlotKind.Object);
}
Assumption containsNoActiveBindingAssumption = FrameSlotChangeMonitor.getContainsNoActiveBindingAssumption(fd);
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeDoubleArrayMR.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeDoubleArrayMR.java
index 032680dccf679e46eca01d420fb9dc05df945974..b5092dea9c559ceebcf9e71a95cd6a449c0e84d9 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeDoubleArrayMR.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeDoubleArrayMR.java
@@ -36,6 +36,10 @@ public class NativeDoubleArrayMR {
protected double access(NativeDoubleArray receiver, int index) {
return receiver.read(index);
}
+
+ protected double access(NativeDoubleArray receiver, long index) {
+ return receiver.read((int) index);
+ }
}
@Resolve(message = "WRITE")
@@ -44,6 +48,11 @@ public class NativeDoubleArrayMR {
receiver.write(index, value);
return value;
}
+
+ protected double access(NativeDoubleArray receiver, long index, double value) {
+ receiver.write((int) index, value);
+ return value;
+ }
}
@Resolve(message = "TO_NATIVE")
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeIntegerArrayMR.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeIntegerArrayMR.java
index 3b65e82d6d4b2dc97ee6509bcb8adf7cc9f79d36..9014c4fd0213f9006e2fe8ef61af45a03c2e35e1 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeIntegerArrayMR.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/ffi/interop/NativeIntegerArrayMR.java
@@ -36,6 +36,10 @@ public class NativeIntegerArrayMR {
protected int access(NativeIntegerArray receiver, int index) {
return receiver.read(index);
}
+
+ protected int access(NativeIntegerArray receiver, long index) {
+ return receiver.read((int) index);
+ }
}
@Resolve(message = "WRITE")
@@ -44,6 +48,11 @@ public class NativeIntegerArrayMR {
receiver.write(index, value);
return value;
}
+
+ protected int access(NativeIntegerArray receiver, long index, int value) {
+ receiver.write((int) index, value);
+ return value;
+ }
}
@Resolve(message = "TO_NATIVE")
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/interop/RObjectNativeWrapper.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/interop/RObjectNativeWrapper.java
deleted file mode 100644
index bb4a001ae7e5b16587e58f159cc232a97794bf3a..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/interop/RObjectNativeWrapper.java
+++ /dev/null
@@ -1,100 +0,0 @@
-/*
- * Copyright (c) 2018, 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
- * under the terms of the GNU General Public License version 3 only, as
- * published by the Free Software Foundation.
- *
- * This code 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
- * version 3 for more details (a copy is included in the LICENSE file that
- * accompanied this code).
- *
- * You should have received a copy of the GNU General Public License version
- * 3 along with this work; if not, write to the Free Software Foundation,
- * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
- *
- * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
- * or visit www.oracle.com if you need additional information or have any
- * questions.
- */
-package com.oracle.truffle.r.runtime.interop;
-
-import com.oracle.truffle.api.CallTarget;
-import com.oracle.truffle.api.Truffle;
-import com.oracle.truffle.api.frame.VirtualFrame;
-import com.oracle.truffle.api.interop.ForeignAccess;
-import com.oracle.truffle.api.interop.ForeignAccess.StandardFactory;
-import com.oracle.truffle.api.interop.TruffleObject;
-import com.oracle.truffle.api.nodes.RootNode;
-import com.oracle.truffle.api.source.SourceSection;
-import com.oracle.truffle.r.runtime.data.NativeDataAccess;
-import com.oracle.truffle.r.runtime.data.RObject;
-import com.oracle.truffle.r.runtime.nodes.RSyntaxNode;
-
-public class RObjectNativeWrapper implements TruffleObject {
- private final RObject obj;
-
- public RObjectNativeWrapper(RObject obj) {
- this.obj = obj;
- }
-
- @Override
- public ForeignAccess getForeignAccess() {
- return ForeignAccess.create(RObjectNativeWrapper.class, new StandardFactory() {
- @Override
- public CallTarget accessIsNull() {
- return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
- @Override
- public Object execute(VirtualFrame frame) {
- return false;
- }
- });
- }
-
- @Override
- public CallTarget accessIsPointer() {
- return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
- @Override
- public Object execute(VirtualFrame frame) {
- return true;
- }
- });
- }
-
- @Override
- public CallTarget accessAsPointer() {
- return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
- @Override
- public Object execute(VirtualFrame frame) {
- RObjectNativeWrapper receiver = (RObjectNativeWrapper) ForeignAccess.getReceiver(frame);
- return NativeDataAccess.asPointer(receiver.obj);
- }
- });
- }
-
- @Override
- public CallTarget accessToNative() {
- return Truffle.getRuntime().createCallTarget(new InteropRootNode() {
- @Override
- public Object execute(VirtualFrame frame) {
- return ForeignAccess.getReceiver(frame);
- }
- });
- }
- });
- }
-}
-
-abstract class InteropRootNode extends RootNode {
- InteropRootNode() {
- super(null);
- }
-
- @Override
- public final SourceSection getSourceSection() {
- return RSyntaxNode.INTERNAL;
- }
-}
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
index 56300d1661d9478e61d436269b7cb571e5e14df9..157304d770868a4f3b261dbf49a09aca68fd6a7a 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
@@ -21,7 +21,10 @@ rffi.isRString("hello")
rffi.isRString(NULL)
rffi.interactive()
x <- 1; rffi.findvar("x", globalenv())
-x <- "12345"; rffi.char_length(x)
+# See issue GR-9928
+if (Sys.info()[['sysname']] != "Darwin") {
+ x <- "12345"; rffi.char_length(x)
+}
rffi.test_duplicate(quote(a[,3])[[3]], 1L) # try duplicating empty symbol
@@ -29,19 +32,25 @@ strVec <- rffi.getStringNA();
stopifnot(anyNA(strVec))
stopifnot(rffi.isNAString(strVec))
rffi.LENGTH(strVec)
-# this will call CHAR(x) on the NA string, which materializes it to native pointer...
-rffi.char_length(strVec)
+# See issue GR-9928
+if (Sys.info()[['sysname']] != "Darwin") {
+ # this will call CHAR(x) on the NA string, which materializes it to native pointer...
+ rffi.char_length(strVec)
+}
strVec <- rffi.setStringElt(c('hello'), as.character(NA))
stopifnot(anyNA(strVec))
stopifnot(rffi.isNAString(as.character(NA)))
-# Encoding tests
-rffi.getBytes('\u1F602\n')
-# ignored: FastR does not support explicit encoding yet
-# latinEncStr <- '\xFD\xDD\xD6\xF0\n'
-# Encoding(latinEncStr) <- "latin1"
-# rffi.getBytes(latinEncStr)
-rffi.getBytes('hello ascii')
+# See issue GR-9928
+if (Sys.info()[['sysname']] != "Darwin") {
+ # Encoding tests
+ rffi.getBytes('\u1F602\n')
+ # ignored: FastR does not support explicit encoding yet
+ # latinEncStr <- '\xFD\xDD\xD6\xF0\n'
+ # Encoding(latinEncStr) <- "latin1"
+ # rffi.getBytes(latinEncStr)
+ rffi.getBytes('hello ascii')
+}
x <- list(1)
attr(x, 'myattr') <- 'hello';
@@ -50,8 +59,11 @@ stopifnot(attrs[[1]] == 'hello')
attr <- rffi.getAttrib(x, 'myattr')
stopifnot(attr == 'hello')
-# loess invokes loess_raw native function passing in string value as argument and that is what we test here.
-loess(dist ~ speed, cars);
+# Enable when GR-9876 is fixed
+if (Sys.getenv("FASTR_RFFI") != "llvm") {
+ # loess invokes loess_raw native function passing in string value as argument and that is what we test here.
+ loess(dist ~ speed, cars);
+}
# code snippet that simulates work with promises ala rlang package
tmp <- c(1,2,4)
@@ -143,39 +155,42 @@ rffi.inlined_length(expr[[1]])
# foo <-function(...) rffi.inlined_length(get('...'))
# foo(a = 1, b = 2, c = 3, d = 42)
-testLength <- function(type) {
- s <- api.Rf_allocVector(type, 1000)
- print(api.LENGTH(s))
- print(api.TRUELENGTH(s))
-
- api.SETLENGTH(s, 10)
- print(api.LENGTH(s))
- print(api.TRUELENGTH(s))
-
- api.SET_TRUELENGTH(s, 1000)
- print(api.LENGTH(s))
- print(api.TRUELENGTH(s))
+# Enable when GR-10914 is fixed
+if (Sys.getenv("FASTR_RFFI") != "llvm") {
+ testLength <- function(type) {
+ s <- api.Rf_allocVector(type, 1000)
+ print(api.LENGTH(s))
+ print(api.TRUELENGTH(s))
+
+ api.SETLENGTH(s, 10)
+ print(api.LENGTH(s))
+ print(api.TRUELENGTH(s))
+
+ api.SET_TRUELENGTH(s, 1000)
+ print(api.LENGTH(s))
+ print(api.TRUELENGTH(s))
+ }
+ testLength(10) # LGLSXP
+ testLength(13) # INTSXP
+ testLength(14) # REALSXP
+ testLength(15) # CPLXSXP
+ testLength(16) # STRSXP
+ testLength(19) # VECSXP
+
+ svec <- c("a")
+ charsxp <- api.STRING_ELT(svec, 0)
+ api.LENGTH(charsxp)
+ # gnur returns different value
+ # api.TRUELENGTH(charsxp)
+ api.SET_TRUELENGTH(charsxp, 1000)
+ api.LENGTH(charsxp)
+ api.TRUELENGTH(charsxp)
+
+ # gnur returns different value
+ # api.LEVELS(charsxp)
+
+ identical(charsxp, api.STRING_ELT(c("a"), 0))
}
-testLength(10) # LGLSXP
-testLength(13) # INTSXP
-testLength(14) # REALSXP
-testLength(15) # CPLXSXP
-testLength(16) # STRSXP
-testLength(19) # VECSXP
-
-svec <- c("a")
-charsxp <- api.STRING_ELT(svec, 0)
-api.LENGTH(charsxp)
-# gnur returns different value
-# api.TRUELENGTH(charsxp)
-api.SET_TRUELENGTH(charsxp, 1000)
-api.LENGTH(charsxp)
-api.TRUELENGTH(charsxp)
-
-# gnur returns different value
-# api.LEVELS(charsxp)
-
-identical(charsxp, api.STRING_ELT(c("a"), 0))
rffi.parseVector('1+2')
rffi.parseVector('.*/-')
@@ -221,7 +236,10 @@ api.ATTRIB(structure(c(1,2,3), myattr3 = 33))
api.ATTRIB(data.frame(1, 2, 3))
invisible(rffi.testDATAPTR('hello', testSingleString = T));
-rffi.testDATAPTR(c('hello', 'world'), testSingleString = F);
+# See issue GR-9928
+if (Sys.info()[['sysname']] != "Darwin") {
+ rffi.testDATAPTR(c('hello', 'world'), testSingleString = F);
+}
# SET_OBJECT
# FastR does not fully support the SET_OBJECT fully,
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/AbstractMRTest.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/AbstractMRTest.java
index fa11caa030caaed845e8421120f77fd96530003f..66d9767189480713409be139da374d9f292008b3 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/AbstractMRTest.java
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/AbstractMRTest.java
@@ -153,7 +153,7 @@ public abstract class AbstractMRTest {
public void testAsNativePointer() throws Exception {
for (TruffleObject obj : createTruffleObjects()) {
try {
- assertNotNull(obj.getClass().getSimpleName(), ForeignAccess.sendToNative(Message.AS_POINTER.createNode(), obj));
+ assertNotNull(obj.getClass().getSimpleName(), ForeignAccess.sendToNative(Message.TO_NATIVE.createNode(), obj));
assertEquals(obj.getClass().getSimpleName() + " " + obj + " IS_POINTER", true, ForeignAccess.sendIsPointer(Message.IS_POINTER.createNode(), obj));
} catch (UnsupportedMessageException e) {
assertEquals(obj.getClass().getSimpleName() + " " + obj + " IS_POINTER", false, ForeignAccess.sendIsPointer(Message.IS_POINTER.createNode(), obj));
@@ -168,7 +168,7 @@ public abstract class AbstractMRTest {
continue;
}
try {
- assertTrue(obj.getClass().getSimpleName(), ForeignAccess.sendToNative(Message.TO_NATIVE.createNode(), obj) != obj);
+ assertTrue(obj.getClass().getSimpleName(), ForeignAccess.sendToNative(Message.TO_NATIVE.createNode(), obj) == obj);
} catch (UnsupportedMessageException e) {
}
}
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/ListMRTest.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/ListMRTest.java
index 24eacfee16e67c537894eccff71f8c4518982fe4..8c90e547c88b8c3ffae5f7929fab306daaabd3b0 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/ListMRTest.java
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/engine/interop/ListMRTest.java
@@ -50,7 +50,7 @@ public class ListMRTest extends AbstractMRTest {
@Test
public void testNativePointer() throws UnsupportedMessageException, UnknownIdentifierException, UnsupportedTypeException {
for (TruffleObject obj : new TruffleObject[]{create("list", testValues), create("pairlist", testValues)}) {
- assertTrue(ForeignAccess.sendToNative(Message.TO_NATIVE.createNode(), obj) != obj);
+ assertTrue(ForeignAccess.sendToNative(Message.TO_NATIVE.createNode(), obj) == obj);
}
}
diff --git a/documentation/dev/build-process.md b/documentation/dev/build-process.md
index c655b98a4178802c2dba1e9333a745000c66866c..96614fb46229788565d4ae4c21639237e9f23c62 100644
--- a/documentation/dev/build-process.md
+++ b/documentation/dev/build-process.md
@@ -84,7 +84,7 @@ then delving into individual scripts that patch and build parts of GNUR. Last se
* `GNUR_CONFIG_FLAGS` constructed and passed over to the configure utility that generates the `Makeconf` file for GNUR
* the output in `$(GNUR_HOME_BINARY)/gnur_configure.log`
* optionally (Linux, SunOS) patches the generated `$(GNUR_HOME_BINARY)/Makeconf` by `$(GNUR_HOME_BINARY)/Makeconf < edMakeconf` (adds `-fPIC` to `CFLAGS` and `FFLAGS`, i.e. enables Position Independent Code)
- * builds GNUR in `libdownloads/R-$(R_VERSION)` using special compiler options
+ * builds GNUR in `libdownloads/R-$(R_VERSION)` using special compiler options. **Note: the output is redirected to `libdownloads/R-3.4.0/gnur_make.log` in order not to pollute the main build output.**
* A special configuration for Solaris:
1. the default `iconv` utility is inadequate and has to be replaced by GNU `iconv`
2. the solaris studio compilers must be used, assumed to be on the `PATH`
diff --git a/mx.fastr/mx_copylib.py b/mx.fastr/mx_copylib.py
index 5144045ba0beb6fef3a7eb69bff9db31778c866a..794ee136b59496e9e4df38ff9e0d7fb38714e5e0 100644
--- a/mx.fastr/mx_copylib.py
+++ b/mx.fastr/mx_copylib.py
@@ -86,6 +86,8 @@ def _copylib(lib, libpath, plain_libpath_base, target):
try:
mx.log('install_name_tool -id @rpath/' + plain_libpath_base + ' ' + plain_libpath_base)
subprocess.check_call(['install_name_tool', '-id', '@rpath/' + plain_libpath_base, plain_libpath_base])
+ mx.log('install_name_tool --add_rpath ' + target + ' ' + plain_libpath_base)
+ subprocess.check_call(['install_name_tool', '-add_rpath', target, plain_libpath_base])
except subprocess.CalledProcessError:
mx.abort('copylib: install_name_tool failed')
diff --git a/mx.fastr/suite.py b/mx.fastr/suite.py
index 5896701801c567d65be50a5652d191aeff455d8f..e09de7993a89b319128e25b0743d71c457ccdc6a 100644
--- a/mx.fastr/suite.py
+++ b/mx.fastr/suite.py
@@ -7,7 +7,7 @@ suite = {
{
"name" : "truffle",
"subdir" : True,
- "version" : "822da2f5e092931e236885be3cc6e9cac35b5c7a",
+ "version" : "337a2747a1d750693853cc7c8f6ec2aaa2afc4ba",
"urls" : [
{"url" : "https://github.com/graalvm/graal", "kind" : "git"},
{"url" : "https://curio.ssw.jku.at/nexus/content/repositories/snapshots", "kind" : "binary"},