diff --git a/com.oracle.truffle.r.pkgs/refcmp/NAMESPACE b/com.oracle.truffle.r.pkgs/refcmp/NAMESPACE index a48008ffacf3c83dd02cbbc40af647daae1213c5..211930545bace09e2c5139710351e1ef30a7c35c 100644 --- a/com.oracle.truffle.r.pkgs/refcmp/NAMESPACE +++ b/com.oracle.truffle.r.pkgs/refcmp/NAMESPACE @@ -4,4 +4,3 @@ export(snapshot) export(snapshot.init) export(snapshot_id) export(snapshot.show) -export(snapshot.named) diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/actParsToList.R b/com.oracle.truffle.r.pkgs/refcmp/R/actParsToList.R deleted file mode 100644 index d08ef9546cd4977facfd38ef4cd1e2a0f5537779..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/actParsToList.R +++ /dev/null @@ -1,15 +0,0 @@ -actParsToList <- -function (pars, env) { - l <- list() - for (i in seq_along(pars)) { - strrep <- as.character(pars[[i]]) - if (is.symbol(pars[[i]])) { - value <- eval(pars[[i]], envir = env) - l[[strrep]] <- value - } - else { - warning(paste0("Skipping '", strrep, "' because only symbols are allowed")) - } - } - l -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/refcmp.R b/com.oracle.truffle.r.pkgs/refcmp/R/refcmp.R new file mode 100644 index 0000000000000000000000000000000000000000..fc88e77f79c11d136ff82f20375a206120ef254d --- /dev/null +++ b/com.oracle.truffle.r.pkgs/refcmp/R/refcmp.R @@ -0,0 +1,119 @@ +## + # Copyright (c) 2017, Oracle and/or its affiliates. All rights reserved. + # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. + # + # This code is free software; you can redistribute it and/or modify it + # under the terms of the GNU General Public License version 2 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 2 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 + # 2 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. +## + +refcmpEnv <- new.env(parent = emptyenv()) +refcmpEnv$snapshot_dir <- 'snapshots' +refcmpEnv$snapshot_id <- 0L + +snapshot.isFastR <- function() { + length(grep('FastR', R.Version()$version.string)) != 0 +} +refcmpEnv$isReferenceRun <- function() !snapshot.isFastR() + +snapshot.init <- function(dir) { + if(!missing(dir)) { + refcmpEnv$snaphost_dir <- dir + } + refcmpEnv$snapshot_id <- 0 +} + +snapshot <- function(...) { + # the actual parameter expessions + actParExprs <- as.list(match.call()[-1]) + valueList <- actParsToList(actParExprs, parent.frame()) + try({ + snapshot_id(refcmpEnv$snapshot_id, valueList) + refcmpEnv$snapshot_id <- refcmpEnv$snapshot_id + 1 + }) +} + +snapshot_id <- function(id, valueList, env = parent.frame()) { + if(refcmpEnv$isReferenceRun()) { + snapshot.record(id, valueList) + } else { + snapshot.check(id, valueList) + } +} + +snapshot.record <- function(id, valueList) { + dumpDir <- file.path(refcmpEnv$snapshot_dir) + if(!dir.exists(dumpDir)) { + dir.create(dumpDir) + } + fcon <- file(file.path(refcmpEnv$snapshot_dir, paste0("snapshot", id, ".obj"))) + saveRDS(valueList, file=fcon) + close(fcon) +} + +snapshot.check <- function(id, valueList) { + fcon <- file(file.path(refcmpEnv$snapshot_dir, paste0("snapshot", id, ".obj"))) + restoredVars <- readRDS(file=fcon) + close(fcon) + + if(length(restoredVars) < length(vars)) { + stop(paste("recorded snapshot has", length(restoredVars), "recorded variables but expected", length(vars))) + } + + var_names <- names(vars) + restored_names <- names(restoredVars) + for(i in seq_along(var_names)) { + if(var_names[[i]] %in% restored_names) { + actualVal <- vars[[var_names[[i]]]] + expectedVal <- restoredVars[[var_names[[i]]]] + if(!identical(expectedVal, actualVal)) { + stop(paste0("Value of variable '", var_names[[i]], "' differs. Expected ", expectedVal, " but was ", actualVal)) + } + } else { + stop(paste0("Missing variable '", var_names[[i]], "' in recorded variables")) + } + } +} + +snapshot.show <- function(id = refcmpEnv$snapshot_id) { + snapshot_filename <- file.path(refcmpEnv$snapshot_dir, paste0("snapshot", id, ".obj")) + if(!file.exists(snapshot_filename)) { + stop(paste0("Snapshot with ID=", id, " does not exist")) + } + fcon <- file(snapshot_filename) + restoredVars <- readRDS(file=fcon) + close(fcon) + + return (restoredVars) +} + +actParsToList <- function(pars, env) { + l <- list() + for(i in seq_along(pars)) { + strrep <- as.character(pars[[i]]) + if (is.symbol(pars[[i]])) { + value <- eval(pars[[i]], envir=env) + # cat(i, ": ", strrep, " = ", value, "\n") + l[[strrep]] <- value + } else { + warning(paste0("Skipping '", strrep, "' because only symbols are allowed")) + } + } + l +} + + diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.R deleted file mode 100644 index 495f770334182ff17ce68f57d31c4cd0815f76d4..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.R +++ /dev/null @@ -1,9 +0,0 @@ -snapshot <- -function (...) { - actParExprs <- as.list(match.call()[-1]) - valueList <- actParsToList(actParExprs, parent.frame()) - try({ - snapshot.id(refcmpEnv$snapshot_id, valueList) - }) - refcmpEnv$snapshot_id <- refcmpEnv$snapshot_id + 1 -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.check.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.check.R deleted file mode 100644 index 493b6089d4f30ff694b8d02d1609940d6a70d6b4..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.check.R +++ /dev/null @@ -1,28 +0,0 @@ -snapshot.check <- -function (id, valueList) { - fcon <- file(file.path(refcmpEnv$snapshot_dir, paste0("snapshot", - id, ".obj"))) - restoredVars <- readRDS(file = fcon) - close(fcon) - if (length(restoredVars) < length(valueList)) { - stop(paste("recorded snapshot has", length(restoredVars), - "recorded variables but expected", length(valueList))) - } - var_names <- names(valueList) - restored_names <- names(restoredVars) - for (i in seq_along(var_names)) { - if (var_names[[i]] %in% restored_names) { - actualVal <- valueList[[var_names[[i]]]] - expectedVal <- restoredVars[[var_names[[i]]]] - if (!refcmpEnv$equals(expectedVal, actualVal)) { - stop(paste0("Value of variable '", var_names[[ - i]], "' differs. Expected ", expectedVal, " but was ", - actualVal)) - } - } - else { - stop(paste0("Missing variable '", var_names[[i]], - "' in recorded variables")) - } - } -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.id.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.id.R deleted file mode 100644 index 02db534a33c71ec1d22367beb96c35b00762d2f8..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.id.R +++ /dev/null @@ -1,9 +0,0 @@ -snapshot.id <- -function (id, valueList, env = parent.frame()) { - if (refcmpEnv$isReferenceRun()) { - snapshot.record(id, valueList) - } - else { - snapshot.check(id, valueList) - } -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.init.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.init.R deleted file mode 100644 index 75ecb489799c598fa067d12fb3688b1abc0c3129..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.init.R +++ /dev/null @@ -1,13 +0,0 @@ -snapshot.init <- -function (dir, referenceRunPredicate, equalityFunction) { - if (!missing(dir)) { - refcmpEnv$snaphost_dir <- dir - } - if (!missing(referenceRunPredicate)) { - refcmpEnv$isReferenceRun <- referenceRunPredicate - } - if (!missing(equalityFunction)) { - refcmpEnv$equals <- equalityFunction - } - refcmpEnv$snapshot_id <- 0 -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.isFastR.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.isFastR.R deleted file mode 100644 index dcdb7eb18a52a236fe0b327ff1cff11fe20eaae9..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.isFastR.R +++ /dev/null @@ -1,4 +0,0 @@ -snapshot.isFastR <- -function () { - length(grep("FastR", R.Version()$version.string)) != 0 -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.named.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.named.R deleted file mode 100644 index 4706fed2b9a6636295d6f99674d5b1217509d1c4..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.named.R +++ /dev/null @@ -1,9 +0,0 @@ -snapshot.named <- -function (...) { - args <- list(...) - valueList <- args[names(args) != ""] - try({ - snapshot.id(refcmpEnv$snapshot_id, valueList) - refcmpEnv$snapshot_id <- refcmpEnv$snapshot_id + 1 - }) -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.record.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.record.R deleted file mode 100644 index c108c9d8270bd7ba0fa656b7352b54eb05cb1420..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.record.R +++ /dev/null @@ -1,11 +0,0 @@ -snapshot.record <- -function (id, valueList) { - dumpDir <- file.path(refcmpEnv$snapshot_dir) - if (!dir.exists(dumpDir)) { - dir.create(dumpDir) - } - fcon <- file(file.path(refcmpEnv$snapshot_dir, paste0("snapshot", - id, ".obj"))) - saveRDS(valueList, file = fcon) - close(fcon) -} diff --git a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.show.R b/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.show.R deleted file mode 100644 index 82805dc2d2de06914f1ffe9daa40354719ce0016..0000000000000000000000000000000000000000 --- a/com.oracle.truffle.r.pkgs/refcmp/R/snapshot.show.R +++ /dev/null @@ -1,12 +0,0 @@ -snapshot.show <- -function (id = refcmpEnv$snapshot_id) { - snapshot_filename <- file.path(refcmpEnv$snapshot_dir, paste0( - "snapshot", id, ".obj")) - if (!file.exists(snapshot_filename)) { - stop(paste0("Snapshot with ID=", id, " does not exist")) - } - fcon <- file(snapshot_filename) - restoredVars <- readRDS(file = fcon) - close(fcon) - return(restoredVars) -}