Logo Search packages:      
Sourcecode: r-base-core-ra version File versions  Download package

jit.c

// jit.c: just-in-time compiler for R
//
// R : A Computer Language for Statistical Data Analysis
// Copyright (C) 1995, 1996    Robert Gentleman and Ross Ihaka
// Copyright (C) 1998--2006    The R Development Core Team.
//
// This program is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with this program; if not, a copy is available at
// http://www.r-project.org/Licenses/

#ifdef HAVE_CONFIG_H
  #include "config.h"
#endif
#include "Defn.h"
#include "Print.h"
#define JIT_INTERNAL 1  // tell jit.h to include JIT tables etc.
#define JIT_NAMES    1  // tell jit.h to include opcodeName
#include "jit.h"
#include "jithash.h"
#include "printsxp.h"

int jitDirective;       // copy of R jit() "jit" parameter
int jitTrace;           // copy of R jit() "trace" parameter

static SEXP compex;     // the expression currently being compiled to genex

static SEXP genex;      // the jit expression currently being generated
                        // allocated as a RAWSXP but used as a JIT_RECORD
static int  ngenex;     // ops in genex from 0 to ngenex-1 are used

int jitUnresolved;      // must be zero for genex to be accepted as valid

static SEXP jitted[MAX_JITS]; // jitted expressions i.e. array of JITSXPs
static int  njitted;          // SEXPs in jitted from 0 to njitted-1 are used

// following two vars used only for messages to the user and debugging
static const char *jitFuncName;             // name of func that called jit(1)
static char terminateCompileMsg[STRLEN+1];  // reason compile was terminated

// we keep jitState for fast tests, but strictly it is redundant
// because jitState == stateStack[iStateStack]

unsigned jitState = JITS_IDLE;  // see defs for JITS_IDLE etc.
static int      iStateStack;    // index into jit state stack
static unsigned stateStack[MAX_NEST];

00057 typedef struct SUBAS_RECORD {
    SEXP     x, index, y;       // args of a subassignment: x[index] = y
    int      depth;             // R_EvalDepth at subassignment expression
} SUBAS_RECORD;

static SUBAS_RECORD subas;      // track subscripted assignment x[i] <- y

//-----------------------------------------------------------------------------
// Forward declarations

static R_INLINE void genjit(JIT_OPCODE opcode, CSEXP operand,
                            FUNC_TYPE func, IFUNC_TYPE ifunc, int n,
                            int type, int result_len, CSEXP resultTemplate,
                            CSEXP sym, CSEXP env);
static R_INLINE void genjit1(const JIT_OPCODE opcode);
static const char *getNameOfFuncThatCalledJit(void);
static void unjit();
static R_INLINE void markAsNotJittable(CSEXP e, const char * const msg);
static void genjitEval(JIT_OPCODE opcode, CSEXP e, CSEXP env);
static R_INLINE void setJitState(unsigned newState, const char msg[]);

//-----------------------------------------------------------------------------
// Printing routines

SEXP getExpBeforeItWasJitted(CSEXP s) // return s->original, needed for deparse
{
    Dassert(TYPEOF(s) == JITSXP);
    Dassert(TYPEOF(CAR(s)) == RAWSXP);
    return ((JIT_RECORD *)RAW(CAR(s)))->original;
}

void printJitOp(const JIT_OP * const op)
{
    CSEXP operand = op->operand;
    CSEXP result = op->result;

    printf("%-16s ", opcodeName(op->opcode));
    if (result != RNIL)
        printf("result  %s length %d ",
               type2char(TYPEOF(result)), LENGTH(result));

    if (operand == RNIL)
        printf("\n");
    else switch (TYPEOF(operand)) {
        case LGLSXP:
        case INTSXP:
        case REALSXP:
        case SYMSXP:
        case LANGSXP:
            printfSxp(operand, "operand");
            break;
        case JITSXP:
            printf("operand JITTED(%s)\n",
                   deparseAsShortString(getExpBeforeItWasJitted(operand)));
            break;
        case LISTSXP:   // operand is a location
            printfSxp(getSymFromLoc(operand), "operand");
            break;
        default:
            printfSxp(operand, "illegal operand");
            break;
    }
}

void printJitHeader(const JIT_RECORD * const prec)
{
    assert(prec);
    if (TYPEOF(prec->ans) == NILSXP)
        printf("type ANY: ");
    else
        printf("%s[%d]: ", type2char(TYPEOF(prec->ans)), LENGTH(prec->ans));

    printf("%s\n", deparseAsShortString(prec->original));
}

static void printJitRecord(const JIT_RECORD * const prec)    // print a JIT_RECORD
{
    const JIT_OP *op = prec->ops;

    printJitHeader(prec);
    do {
        printf("        ");
        printJitOp(op);
    } while ((op++)->opcode != JIT_endop);

    printf("\n");
}

void printJit(CSEXP s)                          // print a JITSXP
{
    assert(TYPEOF(s) == JITSXP);
    assert(TYPEOF(s->u.jitsxp.pjit) == RAWSXP);
    printJitRecord((JIT_RECORD *)RAW(s->u.jitsxp.pjit));
}

void printBinding(CSEXP loc)                    // loc is a binding location
{
    switch (TYPEOF(loc)) {
        case LISTSXP:
            printf("pairlist \"%s\"\n", CHAR(PRINTNAME(TAG(loc))));
            break;
        case SYMSXP:
            printf("symbol \"%s\"\n", CHAR(PRINTNAME(loc)));
            break;
        default:
            UNIMPLEMENTED_TYPE("printBinding", loc);
            break;
   }
}

char *bindingAsString(CSEXP loc)
{
    static char str[STRLEN+1];
    switch (TYPEOF(loc)) {
        case LISTSXP:
            snprintf(str, STRLEN, "%s", CHAR(PRINTNAME(TAG(loc))));
            break;
        case SYMSXP:
            snprintf(str, STRLEN, "%s", CHAR(PRINTNAME(loc)));
            break;
        default:
            UNIMPLEMENTED_TYPE("bindingAsString", loc);
            break;
   }
   return str;
}

// jitError is like error but appends "jitting was enabled in func" msg

static void jitError(const char *format, ...)
{
    #define BUFSIZE 200
    char buf[BUFSIZE+1];
    int nchars;
    va_list(ap);
    assert(BUFSIZE < R_WarnLength);
    va_start(ap, format);
    nchars = vsnprintf(buf, BUFSIZE, format, ap);
    assert(nchars >= 0);
    buf[nchars] = 0;    // guarantee null termination
    va_end(ap);
    // we append a msg if jitting was enabled in a func that called this func
    if (jitFuncName && iStateStack > 0)
        error(_("%s (jitting was enabled in \"%s\")"), buf, jitFuncName);
    else
        error(buf);
}

//-----------------------------------------------------------------------------
// Tracing routines. These are passive i.e. they report
// conditions but don't change them.

static R_INLINE void traceJitProlog(CSEXP e, Rboolean fireup, const char msg[])
{
    if (jitTrace && ((jitTrace >= 3 && fireup) || jitTrace >= 5)) {

        const char *str1, *str2;
        str1 = (fireup? " firing up compiler for": "");

        switch (jitState) {
            case JITS_IN_NESTED_FUNC:
                str2 = " in nested func";
                break;
            case JITS_IN_LOOP:
                 if (e->sxpinfo.gp & CANNOT_JIT_BIT)
                     str2 = " not jittable";
                 else
                     str2 = " possibly jittable";
                break;
            case JITS_COMPILING:
                 if (e->sxpinfo.gp & CANNOT_JIT_BIT)
                     str2 = " subexpression not jittable";
                 else
                     str2 = " subexpression possibly jittable";
                break;
            default:
                str2 = "";
                break;
        }
        printf("#\t\t\t\t%d jitProlog called by %s%s%s %s\n",
               R_EvalDepth, msg, str1, str2, deparseAsShortString(e));
    }
}
static R_INLINE void traceEpilog(const char msg[])
{
    if (jitTrace >= 3) {
        printf("#\t\t\t\t%d jitEpilog called by %s", R_EvalDepth, msg);
        if (jitUnresolved)
                printf(" unresolved=%d", jitUnresolved);
        if (jitCompiling()) {
             if (compex->sxpinfo.gp & CANNOT_JIT_BIT)
                 printf(" not jittable");
             else
                 printf(" done");
        }
        switch (TYPEOF(compex)) {
            case LANGSXP:
                printf(" %s\n", deparseAsShortString(compex));
                break;
            case JITSXP:
                printf(" previously jitted\n");
                break;
            default:
                UNIMPLEMENTED_TYPE("traceEpilog", compex);
                break;
       }
    }
}
static void traceDoJit(int jitArg, int traceArg)
{
    if (jitTrace >= 3 || traceArg >= 3) {
        const char *str = getNameOfFuncThatCalledJit();
        printf("# jit(%d, %d)", jitArg, traceArg);
        if (str)
            printf(" invoked by %s", str);
        printf("\n");
    }
}
static void traceGoodCompile(CSEXP s, JIT_RECORD *prec)
{
    if (jitTrace >= 1) {
        printf(_("%s#   Compiled %s\n"),
               (jitTrace >= 3? "\n": ""),
               deparseAsShortString(prec->original));

        if (jitTrace >= 3) {
            printf("#\tto ");
            printJit(s);
        }
     }
}
static void traceTerminateCompile(const char msg[])
{
    if (jitTrace >= 3) {
        printf("#       Terminated compile\t%d %s, "
               "mark as not compilable %s\n\n",
               R_EvalDepth, msg, deparseAsShortString(compex));
    }
    if (jitTrace >= 2)
        strcpy(terminateCompileMsg, msg);   // for nice error reporting
}
static R_INLINE void traceClearJittedBits(CSEXP loc)
{
    if (jitTrace >= 3) {
        if (loc->sxpinfo.gp & CANNOT_JIT_BIT) {
            printf("#   Clear cannot jit bit ");
            printBinding(loc);
        }
        if (loc->sxpinfo.gp & JITTED_BIT) {
            printf("#   Clear jitted bit ");
            printBinding(loc);
        }
    }
}
static R_INLINE void traceUnjit(void)
{
    if (jitTrace >= 3) {
        if (njitted == 1)
            printf("# Unjit %d expression\n", njitted);
        else
            printf("# Unjit %d expressions\n", njitted);
    }
}
static R_INLINE void tracePushJitState(CSEXP call, unsigned newState)
{
    if (jitTrace && ((jitTrace >= 4 && iStateStack <= 2) || jitTrace >= 5)) {
        printf("#\t\t\t\t%d pushedJitState "
               "iStateStack changed to %d expression %s\n",
               R_EvalDepth, iStateStack,
               (call == RNIL? "none": deparseAsShortString(call)));
    }
}
static R_INLINE void tracePopJitState(CSEXP call, Rboolean atTopLevel)
{
    if (jitTrace) {
        if ((jitTrace >= 4 && iStateStack <= 2) || jitTrace >= 5) {
            printf("#\t\t\t\t%d poppedJitState ", R_EvalDepth);
            if (atTopLevel)
                printf("at top level ");
            else
                printf("iStateStack changed to %d ", iStateStack);
            printf("expression %s\n", deparseAsShortString(call));
        }
        if (jitTrace >= 4 && iStateStack == 0)
            printfSxp(call, "# Return from");
    }
}
static R_INLINE void traceMarkAsNoJittable(CSEXP s, const char msg[])
{
    if (jitTrace >= 2 && !(s->sxpinfo.gp & CANNOT_JIT_BIT)) {
        if (TYPEOF(s) == LANGSXP)
            printf(_("#   Did not compile %s "), deparseAsShortString(s));
        else
            printf(_("#   Mark as not jittable %s "), bindingAsString(s));
        printf("[%s]\n", (msg[0]? msg: "compile terminated early"));
    }
}
static R_INLINE void traceJitEnterLoop(CSEXP s)
{
    if (jitTrace >= 2)
        printf(_("# Begin JIT compilation: %s\n"),
               deparseAsShortString(s));
}
static R_INLINE void traceJitExitLoop(CSEXP s, unsigned prevJitState)
{
    if (jitTrace) {
        if ((jitTrace >= 2 && prevJitState == JITS_AWAITING_LOOP) ||
                jitTrace >= 5) {
            if (prevJitState == JITS_AWAITING_LOOP)
                printf(_("# End JIT compilation: "));
            else
                printf(_("# Exit loop: "));
            switch (TYPEOF(s)) {
                case LANGSXP:
                    printf("%s\n\n", deparseAsShortString(s));
                    break;
                case JITSXP:
                    printf("JITTED(%s)\n\n",
                         deparseAsShortString(getExpBeforeItWasJitted(s)));
                    break;
                default:
                    UNIMPLEMENTED_TYPE("traceJitExitLoop", s);
                    break;
           }
        }
    }
}
static void traceGenjitOp(JIT_OP *op)
{
    if (jitTrace >= 3) {
        printf("#\tGENERATE ");
        printJitOp(op);
    }
}
static R_INLINE void traceNoas(void)
{
    if (jitTrace >= 4)
        printf("#\tskipped generate JIT_as\n");
}
static R_INLINE void traceSkipGen(unsigned opcode)
{
    if (jitTrace >= 3)
        printf("#\t\t\t\t%d Skipped generate %s because "
               "jitState == %s\n",
               R_EvalDepth, opcodeName(opcode), jitStateName(jitState));
}

void printLoopIteration(const char msg[], const SEXP indexVar, int i)
{
    printf("\n#---%s %s iteration [%d]----------\n",
          msg, bindingAsString(indexVar), i+1);
}

//-----------------------------------------------------------------------------
// R jit() function

static SEXP jitReturnVal, jitReturnValNames; // protected by ForwardJitNodes

void initJit(void)                           // called once, at system bootup
{
    // pre-initialize jitReturnVal so do_jit is fast

    jitReturnVal = allocVector(INTSXP, 3);
    jitReturnValNames = allocVector(STRSXP, 3);

    SET_STRING_ELT(jitReturnValNames, 0, mkChar("jit"));
    SET_STRING_ELT(jitReturnValNames, 1, mkChar("trace"));
    SET_STRING_ELT(jitReturnValNames, 2, mkChar("callers.jit"));
    setAttrib(jitReturnVal, R_NamesSymbol, jitReturnValNames);
}

static SEXP getJitReturnVal(void)           // a little helper for do_jit
{
    INTEGER(jitReturnVal)[0] = (iStateStack > 0)? 0: jitDirective;
    INTEGER(jitReturnVal)[1] = (iStateStack > 0)? 0: jitTrace;
    INTEGER(jitReturnVal)[2] = jitDirective;

    return jitReturnVal;
}

// Get the name of R function that called the
// R function "jit" for nice err messages.

static const char *getNameOfFuncThatCalledJit(void)
{
    const char *str = NULL;
    RCNTXT *cptr;
    for (cptr = R_GlobalContext;
         cptr != NULL && cptr->callflag != CTXT_TOPLEVEL;
         cptr = cptr->nextcontext)
        if (cptr->callflag & (CTXT_BROWSER | CTXT_FUNCTION)) {
            SEXP fun = CAR(cptr->call);
            if (TYPEOF(fun) == SYMSXP)
                str = CHAR(PRINTNAME(fun));
            break;
        }
    return str;
}

static void nestedJitWarning(const unsigned jitArg, const unsigned traceArg)
{
    char thisFunc[STRLEN+1], originalFunc[STRLEN+1];

    const char *str = getNameOfFuncThatCalledJit();
    thisFunc[0] = 0;
    if (str)
        snprintf(thisFunc, STRLEN, _("in %s "), str);

    if (jitFuncName)
        snprintf(originalFunc, STRLEN, "%s ", jitFuncName);
    else
        snprintf(originalFunc, STRLEN, _("a calling function "));

    warning(_("ignored jit(%d) %sbecause %sis already jitting"),
            jitArg, thisFunc, originalFunc);
}

static int do_jitAux(SEXP call, int jitArg, int traceArg, int newTrace)
{
    traceDoJit(jitArg, traceArg);
    if (traceArg)
        jitTrace = traceArg;   // set jitTrace now so trace code below

     // Warn if user tried to change jit state in a func called from
     // a jit block.  The "> 0" test is needed because this func itself
     // can be called from a jit block.

    if (jitState == JITS_IN_NESTED_FUNC && iStateStack > 0)
        nestedJitWarning(jitArg, traceArg);
    else {
        if (jitArg && jitArg == jitDirective)
             ;          // already jitting and no changes
        else if (istack)
                error(_("cannot use jit() to change state "
                        "while in a jitted expression"));
        else {
            jitDirective = jitArg;
            if (!jitArg) {
                setJitState(JITS_IDLE, "do_jitAux");
                unjit();
            } else {
                genex = NULL;
                // stash caller's name for nice error reporting
                jitFuncName = getNameOfFuncThatCalledJit();
                iStateStack = 0;
                setJitState(JITS_AWAITING_LOOP, "do_jitAux");
                stateStack[0] = JITS_AWAITING_LOOP;
                jitInitHash();

                // Following hack is needed when jit() is called at the top
                // command level in a "sourced" file
                if (jitFuncName && 0 == strcmp(jitFuncName, "eval.with.vis"))
                    pushJitState(call, JITS_IN_NESTED_FUNC);
             }
        }
        newTrace = jitArg? traceArg: 0;
    }
    return newTrace;
}

// User callable R function: jit(jit=NA, trace=0)
// This changes or reads jitDirective, jitTrace, and other global jit vars.
// For speed, this is a BUILTIN (it was a function in a package but
// that was a LOT slower).
// RA_TODO Add support for named arguments.

SEXP attribute_hidden do_jit(SEXP call, SEXP op, SEXP args, SEXP env)
{
    int jitArg = NA_INTEGER, traceArg = 0, newTrace = jitTrace;
    SEXP names = getAttrib(args, R_NamesSymbol);
    if (names != RNIL)
        error("named arguments to \"jit\" are not supported");

    checkArity(op, args);

    if (CAR(args) != RNIL) {
        jitArg = asInteger(CAR(args));
        if (jitArg != NA_INTEGER && (jitArg < 0 || jitArg > 2))
            error(_("\"jit\" parameter is %d, legal values are NA or 0 to 2"),
                  jitArg);

        if (CADR(args) != RNIL) {
            traceArg = asInteger(CADR(args));
            if (traceArg == NA_INTEGER)
                error(_("\"trace\" parameter is NA, legal values are 0 to 9"));
            else if (traceArg < 0 || traceArg > 9)
                error(_("\"trace\" parameter is %d, legal values are 0 to 9"),
                      traceArg);
        }
    }
    if (jitArg == NA_INTEGER)   // no arguments to jit()?
        R_Visible = TRUE;
    else {
        newTrace = do_jitAux(call, jitArg, traceArg, newTrace);
        R_Visible = FALSE;
    }
    jitTrace = newTrace;

#if 0 // enable garbage collection torture, must also use gc(1) in R source
    extern int torture_flag;
    torture_flag = 1;
#endif
#if 0 // turn on tracing of eval()
    extern int traceEvalFlag;
    traceEvalFlag = 1;
#endif

    return getJitReturnVal();
}

//-----------------------------------------------------------------------------
// R nojit() function

// return a CHARSXP with elements the names of the nojit symbols

static SEXP getNojitReturnVal(void)
{
    SEXP v = RNIL;                          // return value

    if (jitInitHashNext()) {                // true if any entries in hash tab
        // first pass: get number of symbols to return

        SEXP s;
        int n = 0;                          // number of nojit symbols
        while ((s = jitHashNext()))         // "=" is intentional
            if (s->sxpinfo.gp & CANNOT_JIT_BIT)
                n++;

        if (n) {
            // second pass: create a STRSXP and init with the vars

            int i = 0;
            PROTECT(v = allocVector(STRSXP, n));
            jitInitHashNext();

            while ((s = jitHashNext()))     // "=" is intentional
                if (s->sxpinfo.gp & CANNOT_JIT_BIT)
                     SET_STRING_ELT(v, i++, mkChar(bindingAsString(s)));

            UNPROTECT(1);
        }
    }
    return v;
}

// RA_TODO: the warning "ignored nojit because already jitted" is not
// always issued when it should be, see RA_TODO note in test-jit-lib.R

static void do_nojitAux(CSEXP sym, CSEXP env)
{
    // check jitDirective because we want unjit to clear CANNOT_JIT_BIT later

    if (!jitDirective)
        warning("ignored \"nojit\" because not in a JIT block");

    else if (TYPEOF(sym) != SYMSXP)
        error("argument to \"nojit\" must be a variable");

    else {
        CSEXP loc = findVarLoc(sym, ENCLOS(env));
        if (loc == RNIL)
            error(_("no such symbol"));
        else if (loc->sxpinfo.gp & JITTED_BIT)
            warning("ignored nojit(%s) because %s is already jitted",
                    CHAR(PRINTNAME(sym)), CHAR(PRINTNAME(sym)));
        else {
            markAsNotJittable(sym, "user specified nojit");
            jitPutHash(sym);    // for clearJittedBits later
        }
    }
}

// User callable R function: nojit(sym=NULL).
// Set the CANNOT_JIT_BIT for the specified symbol.
// The bit is checked in the genjit functions e.g genjitPushsym.

SEXP attribute_hidden do_nojit(SEXP call, SEXP op, SEXP args, SEXP env)
{
    CSEXP sym = CAR(args);
    if (sym != RNIL)            // no arguments to nojit()?
        do_nojitAux(sym, env);
    return getNojitReturnVal();
}

//-----------------------------------------------------------------------------
// Garbage collection routines

static R_INLINE void forwardJitOp(const JIT_OP *op, SEXP *pForwardedNodes)
{
     // only need to take care of fields not protected by their original owners

     if (op->result != RNIL)
         ForwardNode(op->result, pForwardedNodes);

     if (op->opcode == JIT_arg)
         ForwardNode(op->operand, pForwardedNodes);
}

static R_INLINE void forwardJitRecord(const SEXP pjit, int nops,
                                      SEXP *pForwardedNodes)
{
    int i;
    const JIT_OP *op;
    JIT_RECORD * const prec = (JIT_RECORD *)RAW(pjit);
    Dassert(TYPEOF(pjit) == RAWSXP);
    ForwardNode(pjit, pForwardedNodes);
    if (prec->original != RNIL)
        ForwardNode(prec->original, pForwardedNodes);
     if (prec->ans != RNIL)
         ForwardNode(prec->ans, pForwardedNodes);

    // if nops >= 0 then use it, else look for JIT_endop

    if (nops >= 0)
        for (i = 0; i < nops; i++)
            forwardJitOp(prec->ops + i, pForwardedNodes);
    else
        for (op = prec->ops; op->opcode != JIT_endop; op++)
            forwardJitOp(op, pForwardedNodes);
}

// This is called from the garbage collector.  Tell the garbage collector
// not to collect jit data i.e. to not collect used elements in jitted[]
// or genex[] and preallocated return values for jit().
//
// Elements of jitted[] from 0 to njitted-1 must be protected.
// Elements of genex.ops[] from 0 to ngenex-1 must be protected.
//
// We only need to protect fields that were allocated by the jitter
// because other SEXPs are protected by their original owners.

void ForwardJitNodes(SEXP *pForwardedNodes)
{
    int i;

    ForwardNode(jitReturnVal, pForwardedNodes);
    ForwardNode(jitReturnValNames, pForwardedNodes);

    for (i = 0; i < njitted; i++) {
        SEXP p = jitted[i];
        SEXP pjit = p->u.jitsxp.pjit;
        Dassert(TYPEOF(p) == JITSXP);
        Dassert(TYPEOF(pjit) == RAWSXP);

        // ForwardNode(p, pForwardedNodes); // unneeded
        forwardJitRecord(pjit, -1, pForwardedNodes);
    }
    if (genex)
        forwardJitRecord(genex, ngenex, pForwardedNodes);
}

//-----------------------------------------------------------------------------
// Routines which make sure that the jitted environment is stable.
// These routines work closely with envir.c
//
// The rules are (a) the user cannot change the binding type or length of a
// jitted variable, (b) the user cannot unbind or remove a jitted variable.
// If the user tries to violate these rules we issue an error message.
//
// These rules are needed because
// (a) we store pointers directly to bindings in the "operand" field
//     of jit instructions
// (b) jitted opcodes assume fixed types e.g. add_r1_r1 assumes
//     real scalar operands
// (c) we preallocate fixed length vectors for jit instruction operands.
//
// The rules apply not only to the function with the jit block
// but also to all functions called from the jit block.
//
// We keep track of which bindings are jitted with the gp JITTED_BIT.

void setJittedBit(SEXP loc)
{
    loc->sxpinfo.gp |= JITTED_BIT;
    jitPutHash(loc);                // remember for clearJittedBits later
}

// NOTE: in clearJittedBits, the environment when the jit record was created
// must still be in place because we access binding locations with a pointer

static R_INLINE void clearJittedBits(void)
{
    if (jitInitHashNext()) {                // true if any entries in hash tab
        SEXP loc;
        while ((loc = jitHashNext())) {     // "=" is intentional
            // assert that loc is a binding
            Dassert(TYPEOF(loc) == SYMSXP || TYPEOF(loc) == LISTSXP);
            traceClearJittedBits(loc);
            loc->sxpinfo.gp &= ~(JITTED_BIT|CANNOT_JIT_BIT);
        }
        jitInitHash(); // prevent redundant re-clearing of bits
    }
}

// Return TRUE if the binding "loc" is jitted.
// More accurately: returns TRUE if we tried (successfully or not)
// to jit an expression containing the bound variable, so should
// strictly be named "isPossiblyJitted".
//
// The CANNOT_JIT_BIT takes precedence over the JITTED_BIT
// i.e. if both are set then the sexp is not jitted.
// But for efficiency we don't check that here, the caller must take
// care of it, see e.g. checkJitBinding.

static R_INLINE int isJitted(CSEXP loc)
{
    return loc->sxpinfo.gp & JITTED_BIT;
}

// issue error if type and len of oldval is not the same as val

static R_INLINE void checkTypeAndLen(CSEXP sym, CSEXP oldval, CSEXP val)
{
    Dassert(TYPEOF(sym) == SYMSXP);

    if (TYPEOF(oldval) != TYPEOF(val))
        jitError(_("cannot change the type of a jitted variable\n"
                    "Tried to change \"%s\" from %s to %s"),
                 CHAR(PRINTNAME(sym)),
                 type2char(TYPEOF(oldval)),
                 type2char(TYPEOF(val)));

    if (LENGTH(oldval) != LENGTH(val))
        jitError(_("cannot change the length of a jitted variable\n"
                   "Tried to change \"%s\" from length %d to length %d"),
                 CHAR(PRINTNAME(sym)), LENGTH(oldval), LENGTH(val));
}

// This is called when we are about to change a binding value.  If the
// binding is jitted allow the new binding only if is the same length
// and type as the current binding.
//
// The "val != RNIL" check below is needed because routines like
// do_for() first redefine the loop var with defineVar(sym, RNIL, env)
// and then redefine it again for each iteration with setVar(sym, v, env).
// When the the loop var is jitted, we allow the first call,
// with RNIL, even though it is changing the type of a jitted sym.
// So with this code there is a risk that some R code elsewhere will set a
// jitted var to RNIL and not set it back or set it to another type
// before evalJit() is invoked.  In practice that does not happen.  With
// DEBUG_JIT > 0, the Dasserts in evalJit will catch it if it ever does.
//
// RA_TODO put in an explicit test somewhere to prevent user explicitly
// using "sym <- NULL".  It's safe at the moment because jitUnresolved
// catches it, but expeciit test would be better practice.
//
// The test against CANNOT_JIT_BIT is needed because the CANNOT_JIT_BIT 
// takes precedence over the JITTED_BIT i.e. if both are set then the 
// sexp is not jitted.

void checkJitBinding(CSEXP loc, CSEXP val)
{
    if (isJitted(loc)) {
        SEXP oldval = CAR(loc);
        CSEXP sym = TAG(loc);
        Dassert(TYPEOF(loc) == LISTSXP);

        if (TYPEOF(oldval) == PROMSXP)
            oldval = PRVALUE(oldval);

        if (val != RNIL &&        // see comment in above header
                !(sym->sxpinfo.gp & CANNOT_JIT_BIT) && // see header comment
                oldval != RNIL) { // not initing or set to NULL last time?

            checkTypeAndLen(sym, oldval, val);
        }
    }
}

// Like checkJitBinding above but called when we bind the
// value directly to the symbol rather than through a frame.

void checkJitSymBinding(CSEXP sym, CSEXP val)
{
    if (isJitted(sym) && sym != R_TmpvalSymbol) {
        CSEXP oldval = CDR(sym);   // SYMSXP, so CDR is value field
        Dassert(TYPEOF(oldval) != PROMSXP);
        if (!(sym->sxpinfo.gp & CANNOT_JIT_BIT))
            checkTypeAndLen(sym, oldval, val);
    }
}

// This func is called by defineVar.  It handles the case shown in the
// example R function below.  The essential characteristic of the example
// is that it first uses a non-local variable and then assigns to the
// non-local variable (thereby creating a local copy).
//
//  x <- 1
//  foo <- function()
//  {
//      jit(1, 1)
//      y <- 1
//      for (i in 1:3) {     # need a loop for jitting to take place
//          y <- x           # line 7, after this x is marked as jitted
//          x <- 99          # line 8, this changes x to local scope
//     }
//  }
//
// On the first iter through the loop we use the global x for y <- x (line 7).
// The following assignment to x (line 8) creates a local x. On the next
// iteration through the loop, at line 7 the jitter incorrectly still
// points to the global x instead of the local x.
// To prevent this, the function below disallows the assignment on line 8.
//
// This function slows down assignment to non local vars in jit blocks
// (because we have search beyond the local frame with findVarLoc).
// The slowdown goes away if the assignment is jitted.

void jitPreventLocalRebindingAux(CSEXP sym, CSEXP val, CSEXP env)
{
    CSEXP loc = findVarLoc(sym, env);
    if (jitInHash(loc) && !(loc->sxpinfo.gp & CANNOT_JIT_BIT)) {
        const char *name = CHAR(PRINTNAME(getSymFromLoc(loc)));
        jitError(
            _("Cannot change jitted symbol \"%s\" to local scope\n"
              "Possible remedy: make \"%s\" local by "
              "assigning to it before the jit block"),
            name, name);
    }
}

void checkJitRemove(CSEXP loc)
{
    if (isJitted(loc))
       jitError(_("cannot remove jitted variable \"%s\""),
                CHAR(PRINTNAME(getSymFromLoc(loc))));
}

// This prevents the user doing anything that could affect stability of
// the jitting environment.

void disallowIfJitting(const char str[])
{
    if (jitDirective)
        jitError(_("cannot %s when jitting"), str);
}

// This could be removed, but for now and for paranoia check that
// findVar(e, env) == getSymValFromLoc(findVarLoc(e, env)).

void checkLocationConsistency(SEXP e, SEXP env, SEXP loc, SEXP val)
{
#if DEBUG_JIT_SYM
    SEXP findVarVal = findVar(e, env);
    assert(loc != RNIL);
    if (val != findVarVal) {
        // must print before calling assertFail because error itself
        // can invoke this function via a call to eval()

        REprintf("checkLocationConsistency: "
                 "findVarVal 0x%x != val 0x%x loc 0x%x\n",
                 findVarVal, val, loc);
        REprintf("findVar val: "); printSxp(findVarVal, env, FALSE);
        REprintf("val: "); printSxp(val, env, FALSE);
        REprintf("loc: "); printSxp(loc, env, FALSE);

        assertFail(__FILE__, __LINE__, "see above messages");
    }
#endif
}

static R_INLINE void traceSetJitState(unsigned newState, const char msg[])
{
    if (jitTrace >= 4)
        printf("# %d %s set by %s\n", iStateStack, jitStateName(jitState), msg);
}

#if 0   // used for development
void traceBinding(CSEXP loc, CSEXP val)
{
     if (DEBUG_JIT >= 3 && jitDirective) {
        printfSxp(TAG(loc), "\nSET_BINDING_VALUE");
        printfSxp(CAR(loc), "  current");
        printfSxp(val, "  new    ");
     }
}
#endif

#if 0   // used for development
void traceSymBinding(CSEXP sym, CSEXP val)
{
     if (DEBUG_JIT >= 3 && jitDirective) {
        Dassert(TYPEOF(sym) == SYMSXP);
        printfSxp(sym, "\nSET_SYMBOL_BINDING_VALUE current");
        printfSxp(val, "                         new    ");
    }
}
#endif

//-----------------------------------------------------------------------------
// Routines for pushing and popping jit states.

static void badJitState(const char msg[])
{
    REprintf("Internal error in %s: bad jitState 0x%x %s\n",
             msg, jitState, jitStateName(jitState));

    assertFail(__FILE__, __LINE__, "see above message");
}

static R_INLINE void setJitState(unsigned newState, const char msg[])
{
    stateStack[iStateStack] = newState;
    jitState = newState;
    traceSetJitState(newState, msg);
}

// For now for simplicity we only stack jitState (not genex etc.)
// The disadvantage from the user's perspective is that he or she can't jit a
// function that is called from a jit block --- do_jit() will issue a warning.
// In the long term this limitation should be lifted.

void pushJitState(CSEXP call, unsigned newState)
{
    iStateStack++;
    if (iStateStack >= NBR_ELEMS(stateStack)) {
        char str[STRLEN+1] = "";
        if (jitFuncName)
            snprintf(str, STRLEN, "\njit() was invoked in %s", jitFuncName);
        error("functions called from a JIT block are nested too deeply%s",
              str);
    }
    setJitState(newState, "pushJitState");
    tracePushJitState(call, newState);
}

void popJitState(CSEXP call)
{
    assert(iStateStack >= 0);
    if (iStateStack == 0) {     // leaving the jit block?
        tracePopJitState(call, TRUE);
        jitOff(FALSE);
    } else {
        setJitState(stateStack[--iStateStack], "popJitState");
        tracePopJitState(call, FALSE);
    }
}


void jitContextChangedAux(int nest)     // called by findcontext()
{
    // use "> 0" to skip nest==0 because applyClosure takes care of that

    if (nest > 0)
        popJitState(RNIL);
}

static int jitUnresolvedAtSuspend;

// prevent genjit code generation for the moment

void jitSuspendAux(const char msg[])
{
    Dassert(jitCompiling());
    jitUnresolvedAtSuspend = jitUnresolved;
    setJitState(JITS_SUSPENDED, msg);
}

void jitUnsuspendAux(void) // reallow jit code generation
{
    Dassert(jitState == JITS_SUSPENDED);
    jitUnresolved = jitUnresolvedAtSuspend;
    setJitState(JITS_COMPILING, "jitUnsuspendAux");
}

//-----------------------------------------------------------------------------
void decJitUnresolved(int n)
{
    if (jitCompiling()) {
        jitUnresolved -= n;
        assert(jitUnresolved >= 0);
    }
}

static R_INLINE void assertSxpInfoZero(SEXP s) // play safe
{
    Dassert(TYPEOF(s) == LANGSXP);
    assert(s->sxpinfo.obj == 0);
    assert(s->sxpinfo.named == 0);
    assert(s->sxpinfo.gp == 0);
    // assert(s->sxpinfo.mark == 0);
    if (s->sxpinfo.debug)
        disallowIfJitting(_("use \"debug\""));
    if (s->sxpinfo.trace)
        disallowIfJitting(_("use \"trace\""));
    assert(s->sxpinfo.spare == 0);
    // assert(p->sxpinfo.gcgen == 0);
    assert(s->sxpinfo.gccls == 0);
}

// Convert jitted expressions in jitted array back to their unjitted form.
// Also clear all jitted symbols' JITTED_BIT and CANNOT_JIT_BIT.
// Called by jit(0) and when returning from a function that invoked jit(1).

static void unjit(void)
{
    if (njitted) { // pre-test for efficiency
        int i;
        traceUnjit();
        for (i = 0; i < njitted; i++) {
            int gcgen;
            SEXP p = jitted[i];
            SEXP pjit = p->u.jitsxp.pjit;
            JIT_RECORD *prec = (JIT_RECORD *)RAW(pjit);
            Dassert(TYPEOF(p) == JITSXP);
            Dassert(TYPEOF(pjit) == RAWSXP);
            assertSxpInfoZero(prec->original);

            // restore original expression
            gcgen = p->sxpinfo.gcgen;
            p->sxpinfo = prec->original->sxpinfo;
            p->sxpinfo.gcgen = gcgen;                   // RA_TODO revisit!
            ATTRIB(p) = ATTRIB(prec->original);
            p->u.listsxp = prec->original->u.listsxp;   // update car, cdr, tag
        }
        njitted = 0;
    }
    clearJittedBits();
}

// This warning is issued only if the user is jitting at the main prompt.
// Using REprintf is not the best way to issue a warning, but we don't
// want to call warning() while in error (this function can be invoked
// from error).  The test against jitFuncName ensures that this msg is
// only issued if the user is jitting at the main prompt level.

static R_INLINE void jitOffWarning(Rboolean issueWarning)
{
    if (issueWarning && jitDirective && jitFuncName == NULL)
        REprintf(_("\nWarning: jitting is now disabled\n"));
}

// turn off jitting -- called on return from a jitted function or on error

void jitOff(Rboolean issueWarning)
{
    jitOffWarning(issueWarning);
    unjit();
    setJitState(JITS_IDLE, "jitOff");
    jitDirective = 0;
    jitTrace = 0;
    genex = NULL;
    iStateStack = 0;    // no longer in a nested state
    istack = 0;         // no longer in evalJit
    printSxpDepth = 0;  // not the cleanest place for this, but convenient
}

// This is called during a compilation if we know we should not continue
// e.g. we reached the end of a basic block of R code.
// Used as efficiency measure too, if there is no point in continuing
// within a basic block.

static void terminateCompile(const char msg[])
{
    if (jitCompiling()) {
        setJitState(JITS_TERMINATED, msg);
        genex = NULL;
        compex->sxpinfo.gp |= CANNOT_JIT_BIT;
        traceTerminateCompile(msg);
    }
}

// Prevent further attempts to compile e by setting CANNOT_JIT_BIT.
// Note that sub-expressions of e, if any, are still potentially compilable.
//
// Called from jitEpilog for an unsuccessful just-in-time compilation
// i.e. we reached the end of the expression e being compiled, and couldn't
// compile everything in the expression.

static R_INLINE void markAsNotJittable(CSEXP e, const char * const msg)
{
    traceMarkAsNoJittable(e, msg);
    e->sxpinfo.gp |= CANNOT_JIT_BIT;
}

// At the point we call this function, the evaluator has just created
// a new [<- expression e on the fly.
// It looks like this: x <- `[<-`(`*tmp*`, index, value = rhs).
// It's pointless compiling a temporary expression, so mark it
// as not compilable.
// Note that because e is temporary, there is no need to call jitPutHash(e)
// to remember that e is marked with the CANNOT_JIT_BIT.

void markSubassignAsNotJittable(CSEXP e)
{
    if (jitDirective) {                         // not strictly necessary
        e->sxpinfo.gp |= CANNOT_JIT_BIT;        // mark x <- ...
        CADDR(e)->sxpinfo.gp |= CANNOT_JIT_BIT; // mark `[<-`(`*tmp*`, ...)
    }
}

// Start the just-in-time compiler on e, where e is the LANGSXP
// expression currently being evaluated by eval().

static R_INLINE void fireUpCompiler(CSEXP e)
{
    JIT_RECORD *prec;
    setJitState(JITS_COMPILING, "fireUpCompiler");
    ngenex = 0;

    // Allocate a JIT_RECORD to store the generated jit instructions.
    // We allocate genex as a RAWSXP but use it as a JIT_RECORD.
    // It gets protected from garbage collection in ForwardJitNodes.

    genex = allocVector(RAWSXP, sizeof(JIT_RECORD));
    prec = (JIT_RECORD *)RAW(genex);
    prec->original = RNIL;
    prec->ans = RNIL;
    jitUnresolved = 0;
    subas.depth = 0;
    terminateCompileMsg[0] = 0;
    compex = e;
}

// called by evalLang and genjitFor

Rboolean jitProlog(CSEXP e, const char msg[])   
{
    Rboolean fireup;

    if (!jitDirective)          // for efficiency, not strictly needed
        return FALSE;

    fireup = (jitState == JITS_IN_LOOP) && !(e->sxpinfo.gp & CANNOT_JIT_BIT);

    traceJitProlog(e, fireup, msg);
    if (fireup)
        fireUpCompiler(e);      // will change state to JITS_COMPILING
    jitUnresolved++;            // will be decremented later if can compile e
    return fireup;
}

// An efficiency measure: "template" specifies the buffer type and length
// to store the evaluation result.  However, if the last opcode is
// JIT_eval etc. then we don't need to store the result.

static R_INLINE SEXP possiblyNullTemplate(CSEXP template, JIT_RECORD *prec)
{
    JIT_OPCODE lastOpcode = prec->ops[ngenex-1].opcode;
    if (isEvalOpcode(lastOpcode))
        return RNIL;
    return template;
}

// Called on successful jit generation i.e. we reached the end of the
// expression e being compiled, and were able to compile
// everything in the expression.
// This changes e from a LANGSXP to a JITSXP. See jit-data-structures*.jpg.

static void goodCompile(SEXP e, CSEXP resultTemplate)
{
    JIT_RECORD *prec = (JIT_RECORD *)RAW(genex);
    SEXP ans, original;
    CSEXP template = possiblyNullTemplate(resultTemplate, prec);

    Dassert(TYPEOF(e) == LANGSXP);
    Dassert(ngenex > 0);
    Dassert(template == RNIL ||
            TYPEOF(template) == LGLSXP ||
            TYPEOF(template) == INTSXP ||
            TYPEOF(template) == REALSXP);
    Dassert(LENGTH(template) > 0);
    Dassert(jitUnresolved == 0);
    assertSxpInfoZero(e);

    jitUnresolved = 1;  // for check in decJitUnresolved in genjit
    genjit1(JIT_endop);
    if (template == RNIL)
        PROTECT(ans = RNIL);
    else
        PROTECT(ans = allocVector(TYPEOF(template), LENGTH(template)));
    PROTECT(original = allocSExp(TYPEOF(e)));
    prec->ans = ans;
    prec->original = original;                  // save original expression
    prec->original->u.listsxp = e->u.listsxp;   // set car,cdr, and tag
    ATTRIB(prec->original) = ATTRIB(e);
    SET_TYPEOF(e, JITSXP);
    SETCAR(e, genex);                     // car is pjit
    SETCDR(e, RNIL);                      // not strictly necessary
    SET_TAG(e, RNIL);                     // not strictly necessary
    assert(njitted < NBR_ELEMS(jitted));
    jitted[njitted++] = e;
    traceGoodCompile(e, prec);
    UNPROTECT(2);
}

// Called by evalLang and genjitFor, but only if the previous jitProlog
// fired up the compiler.

void jitEpilog(CSEXP resultTemplate, const char msg[])
{
    PROTECT(resultTemplate);
    traceEpilog(msg);
    if (jitState & (JITS_COMPILING|JITS_NO_AS|JITS_AWAITING_AS)) {
        if (jitUnresolved) // not everything in compex was compiled?
            markAsNotJittable(compex, "unresolved");
        else if (njitted >= NBR_ELEMS(jitted))
            markAsNotJittable(compex, "too long");
        else
            goodCompile(compex, resultTemplate);
        setJitState(JITS_IN_LOOP, "jitEpilog");
    } else if (jitState == JITS_TERMINATED) {
        markAsNotJittable(compex, terminateCompileMsg);
        setJitState(JITS_IN_LOOP, "jitEpilog, previous jitState TERMINATED");
    }
    genex = NULL;
    UNPROTECT(1);
}

// Allow or disallow generation of assignment ops JIT_as_x_x
// Assignment is disabled when eval is evaluating
// a temporary expression for subscripted assignment.
// We still accumulate JIT_pushes etc. when assignment is disabled.

void jitAllowAssign(Rboolean allow)
{
    if (allow) {
        Dassert(jitState == JITS_NO_AS);
        setJitState(JITS_COMPILING, "jitAllowAssign");
    } else {
        Dassert(jitState == JITS_COMPILING);
        setJitState(JITS_NO_AS, "jitAllowAssign");
    }
}

// Called via jitEnterLoop at start of an R loop.  Returns the
// previous jitState if must call jitExitLoop later, else returns 0.

unsigned jitEnterLoopAux(CSEXP s, CSEXP body)
{
    if (jitState == JITS_AWAITING_LOOP) {
          traceJitEnterLoop(s);
          setJitState(JITS_IN_LOOP, "jitEnterLoopAux");
          return JITS_AWAITING_LOOP;
    }
    else if (jitState & JITS_COMPILING_STATES) {
        // The start of a loop ends the current basic block.
        // Preempt the current compilation and start a new one.
        // The CANNOT_JIT bit may possibly be cleared in genjitFor later.

        markAsNotJittable(compex, "entered loop");
        terminateCompile("entered loop");
        jitEpilog(RNIL, "jitEnterLoopAux");
        return JITS_COMPILING;
    }
    return 0;
}

// Invoked on exit from the R loop that changed jit state in jitEnterLoopAux

void jitExitLoop(CSEXP s, unsigned prevJitState)
{
    if (jitState & (JITS_IN_LOOP | JITS_COMPILING_STATES)) {

        if (prevJitState & (JITS_IN_LOOP | JITS_COMPILING_STATES))
            setJitState(JITS_IN_LOOP, "jitExitLoop");
        else
            setJitState(JITS_AWAITING_LOOP, "jitExitLoop");

        genex = NULL;

    } else if (jitState != JITS_IDLE) // idle if exec'ed jit(0) in jitted loop
        badJitState("jitExitLoop");

    traceJitExitLoop(s, prevJitState);
}
//-----------------------------------------------------------------------------
// Routines to generate JIT instructions

// genjitAux generates the given jit instruction i.e. appends the
// instruction to the jit instructions in genex.

static R_INLINE void genjitAux(JIT_OPCODE opcode,
                        CSEXP operand, FUNC_TYPE func, IFUNC_TYPE ifunc, int n,
                        int resultType, int resultLen, CSEXP resultTemplate,
                        CSEXP sym, CSEXP env)
{
    JIT_RECORD * const prec = (JIT_RECORD *)RAW(genex);
    JIT_OP * const op = prec->ops + ngenex;

    Dassert(genex);
    Dassert(ngenex < NBR_ELEMS(prec->ops));
    Dassert(jitDirective);
    Dassert(jitCompiling());
    Dassert(opcode >= JIT_endop && opcode < JIT_last);

    ngenex++;
    op->opcode = opcode;
    op->operand = operand;
    op->func = func;
    op->ifunc = ifunc;
    op->n = n;
    op->sym = sym;
    op->env = env;
    op->result = RNIL;  // preassign because allocVector may cause gc
    if (resultLen == 0 && resultTemplate != RNIL)
        resultLen = LENGTH(resultTemplate);
    if (resultLen) {
        if (resultType == NILSXP)
            resultType = TYPEOF(resultTemplate);
        op->result = allocVector(resultType, resultLen);
    }
    decJitUnresolved(1);
    traceGenjitOp(op);
}

static void genjit(JIT_OPCODE opcode,
                   CSEXP operand, FUNC_TYPE func, IFUNC_TYPE ifunc, int n,
                   int resultType, int resultLen, CSEXP resultTemplate,
                   CSEXP sym, CSEXP env)
{
    Dassert(jitState & JITS_COMPILING_STATES);

    if (ngenex >= MAX_EXP_LEN)
        terminateCompile("too long");

    else if (jitState & (JITS_COMPILING | JITS_NO_AS | JITS_AWAITING_AS))
        genjitAux(opcode, operand, func, ifunc, n,
                  resultType, resultLen, resultTemplate, sym, env);
    else
        traceSkipGen(opcode);
}

static R_INLINE void genjit1(const JIT_OPCODE opcode) // gen a no param opcode
{
    genjit(opcode, RNIL, NULL, NULL, 0, 0, 0, RNIL, RNIL, RNIL);
}

// change opcode by adding offset for the types of operands x and y

static R_INLINE int adjustForTypes1(const JIT_OPCODE opcode,
                                    const unsigned xtype, const unsigned ytype)
{
    int adjust = 0;

    if (xtype == INTSXP || xtype == LGLSXP)
        adjust += JIT_add_i_r - JIT_add_r_r; // op_r_r becomes op_i_r

    if (ytype == INTSXP || ytype == LGLSXP)
        adjust += JIT_add_r_i - JIT_add_r_r; // op_r_r becomes op_r_i

    return opcode + adjust;
}

static R_INLINE int adjustForTypes(const JIT_OPCODE opcode, CSEXP x, CSEXP y)
{
    return adjustForTypes1(opcode, TYPEOF(x), TYPEOF(y));
}

void genjitPush(SEXP e)                     // invoked for numeric consts
{
    jitUnresolved++;
    genjit(JIT_push, e, NULL, NULL, 0, NILSXP, 0, RNIL, RNIL, RNIL);
}

void genjitPushsym(SEXP loc, SEXP env)     // invoked for symbols
{
    SEXP sym;

    if (loc == NULL)
        disallowIfJitting(_("use a \"...\" variable"));
    Dassert(TYPEOF(loc) == LISTSXP || TYPEOF(loc) == SYMSXP);
    if (loc->sxpinfo.gp & CANNOT_JIT_BIT)
        terminateCompile("user specified nojit");
    else {
        sym = getSymFromLoc(loc);
        Dassert(TYPEOF(sym) == SYMSXP);

        if (sym != R_TmpvalSymbol) {
            JIT_OPCODE opcode = JIT_endop;
            SEXP val = getSymValFromLoc(loc);
            if (TYPEOF(val) == PROMSXP)
                val = PRVALUE(val);
            Dassert(val != R_UnboundValue && val != RNIL);
            switch(TYPEOF(val)) {
                case LGLSXP:
                case INTSXP:
                case REALSXP:
                    opcode = JIT_pushsym;
                    break;
                default:
                    break;
            }
            if (opcode != JIT_endop) {
                setJittedBit(loc);
                genjit(opcode, loc, NULL, NULL, 0, NILSXP, 0, RNIL, sym, env);
            }
        }
    }
}

void genjitUnary(JIT_OPCODE opcode, CSEXP x) // invoked for unary minus etc.
{
    if (LENGTH(x) == 1)
        opcode++;       // e.g. change JIT_uminus_i to JIT_uminus_i1
    PROTECT(x);
    genjit(opcode, RNIL, NULL, NULL, 0, NILSXP, 0, x, RNIL, RNIL);
    UNPROTECT(1);
}

static R_INLINE void binHelper(JIT_OPCODE opcode,
                          SEXPTYPE ansType, int ansLen)
{
    genjit(opcode, RNIL, NULL, NULL, 0, ansType, ansLen, RNIL, RNIL, RNIL);
}

// Note that real_binary() typecasts both args to real.  We don't want
// to do that here because we have already pushed the args in their
// original type.

void genjitBinAux(JIT_OPCODE opcode, CSEXP x, CSEXP y, SEXPTYPE ansType)
{
    const int nx = LENGTH(x);
    const int ny = LENGTH(y);
    if (ny == 1) {
        opcode = adjustForTypes(opcode, x, y);
        if (nx == 1)
            binHelper(opcode+3, ansType, nx);   // r_r + 3 is r1_r1
        else if (nx)
            binHelper(opcode+1, ansType, nx);   // r_r + 1 is r_r1
    } else if (nx == 1) {
        opcode = adjustForTypes(opcode, x, y);
        if (ny)
            binHelper(opcode+2, ansType, ny);   // r_r + 2 is r1_r
    } else if (nx == ny) {
        if (nx == 0)
            return;
        opcode = adjustForTypes(opcode, x, y);
        binHelper(opcode, ansType, nx);         // r_r     no change
    }
}

// invoked for real arith ops like "+"

void genjitRealBin(ARITHOP_TYPE oper, CSEXP x, CSEXP y)
{
    static JIT_OPCODE arithToJit[] = { // see ARITHOP_TYPE
        JIT_endop,    // unused
        JIT_add_r_r,  // PLUSOP = 1
        JIT_sub_r_r,  // MINUSOP
        JIT_mul_r_r,  // TIMESOP
        JIT_div_r_r,  // DIVOP
        JIT_pow_r_r,  // POWOP
        JIT_mod_r_r,  // MODOP
        JIT_idiv_r_r  // IDIVOP
    };
    Dassert(oper > 0 && oper <= IDIVOP);
    Dassert(TYPEOF(x) == REALSXP || TYPEOF(y) == REALSXP);
    genjitBinAux(arithToJit[oper], x, y, REALSXP);
}

// invoked for comparison ops like "<"

void genjitRelop(RELOP_TYPE oper, CSEXP x, CSEXP y)
{
    static JIT_OPCODE relopToJit[] = { // see RELOP_TYPE
        JIT_endop,      // unused
        JIT_eq_r_r,     // EQOP = 1,
        JIT_ne_r_r,     // NEOP,
        JIT_lt_r_r,     // LTOP,
        JIT_le_r_r,     // LEOP,
        JIT_ge_r_r,     // GEOP,
        JIT_gt_r_r,     // GTOP
    };
    SEXPTYPE xtype = TYPEOF(x);
    SEXPTYPE ytype = TYPEOF(y);
    Dassert(oper > 0 && oper <= GTOP);
    if ((xtype == LGLSXP || xtype == INTSXP || xtype == REALSXP) &&
        (ytype == LGLSXP || ytype == INTSXP || ytype == REALSXP)) {

        genjitBinAux(relopToJit[oper], x, y, LGLSXP);
    }
}

// Invoked for math primitives with a single argument e.g. sin()
// Returns true if generated an instruction.

static R_INLINE Rboolean genjitMath1aux(double (* const func)(),
                                        SEXP argTemplate,
                                        int resultType, int resultLen)
{
    JIT_OPCODE opcode = JIT_endop;
    switch (TYPEOF(argTemplate)) {
        case LGLSXP:                    // treat logicals as integers
        case INTSXP:
            opcode = JIT_math1_i;
            break;
        case REALSXP:
            opcode = JIT_math1_r;
            break;
        default:
            break;
    }
    const Rboolean generate = (opcode != JIT_endop);
    if (generate) {
        if (LENGTH(argTemplate) == 1)
            opcode++;
        genjit(opcode, RNIL, func, NULL, 0,
               resultType, resultLen, RNIL, RNIL, RNIL);
    }
    return generate;
}

Rboolean genjitMath1(double (* const func)(),
                     CSEXP argTemplate, CSEXP ansTemplate)
{
    PROTECT(argTemplate);
    PROTECT(ansTemplate);
    const Rboolean result = genjitMath1aux(func, argTemplate,
                                           TYPEOF(ansTemplate),
                                           LENGTH(ansTemplate));
    UNPROTECT(2);
    return result;
}

static R_INLINE void genjitIntMath1(int (* const ifunc)(), CSEXP argTemplate)
{
    JIT_OPCODE opcode = JIT_endop;
    SEXPTYPE argType = TYPEOF(argTemplate);
    switch (argType) {
        case LGLSXP:                    // treat logicals as integers
        case INTSXP:
            opcode = JIT_math1i_i;      // return int given int
            break;
        case REALSXP:
            opcode = JIT_math1_r;       // return double given double
            break;
        default:
            break;
    }
    if (opcode != JIT_endop) {
        const int n = LENGTH(argTemplate);
        if (n == 1)
            opcode++;
        genjit(opcode, RNIL, NULL, ifunc, 0, argType, n, RNIL, RNIL, RNIL);
    }
}

// Note: for INTEGER and DOUBLE args abs returns the same type as its arg

void genjitAbs(CSEXP argTemplate)
{
    if (TYPEOF(argTemplate) == REALSXP)
        genjitMath1(fabs, argTemplate, argTemplate);
    else
        genjitIntMath1(abs, argTemplate);
}

// The following code is lifted from arithmetic.c.
// RA_TODO There appears to be an inconsistency in arithmetic.c:
// Standard R always call R_log for "log" (to predictably handle arg<=0)
// But it calls the system log2 which bypasses R_log if HAVE_LOG2
// Thus when called from R, "log2" will handle arg<=0 like "log"
// only if the system log2 is consistent with R_log.
// Likewise for log10. Jitted code does the same thing.

static R_INLINE double R_log(double x) {
    return x > 0 ? log(x) : x < 0 ? R_NaN : R_NegInf;
}

#ifndef HAVE_LOG2
static double jitLog2(double x)
{
    static const double Log2 = R_log(2);
    return log(x) / R_Log2;
}
#endif

#ifndef HAVE_LOG10
static double jitLog10(double x)
{
    static const double Log10 = R_log(10);
    return R_log(x) / Log10;
}
#endif

Rboolean genjitLog(CSEXP argTemplate, CSEXP base)
{
    Rboolean generate = FALSE;
    FUNC_TYPE func = NULL;
    int b = 0;
    if (base != RNIL)
        b = (int)REAL(base)[0];
    switch (b) {
        case 0:
            func = R_log;
            break;
        case 2:
#ifdef HAVE_LOG2
            func = log2;
#else
            func = jitLog2;
#endif
            break;
        case 10:
#ifdef HAVE_LOG10
            func = log10;
#else
            func = jitLog10;
#endif
            break;
    }
    if (func) {
        PROTECT(base);
        if (genjitMath1aux(func, argTemplate, REALSXP, LENGTH(argTemplate))) {
            pushJitState(RNIL, JITS_SUSPENDED);
            generate = TRUE;
        }
        UNPROTECT(1);
    }
    return generate;
}

void genjitLogDone(CSEXP call)
{
    Dassert(jitState == JITS_SUSPENDED);
    popJitState(call);  // no longer in JITS_SUSPENDED
    decJitUnresolved(1);
}

// Note that LOGICAL indices are not jitted, so in evalJit JIT_subset_x
// can create the C index by simply subtracting 1 from the R index.
// RA_TODO This routine could be made more efficient I think.

void genjitSubset(CSEXP x, CSEXP subset)    // for rhs expressions like x[i]
{
    static const JIT_OPCODE subsetOps[4][2] =
    {
        { JIT_subset_r_r,  JIT_subset_r_r1 },
        { JIT_subset_r_i,  JIT_subset_r_i1 },
        { JIT_subset_i_r,  JIT_subset_i_r1 },
        { JIT_subset_i_i,  JIT_subset_i_i1 },
    };
    if ((TYPEOF(x) == INTSXP || TYPEOF(x) == REALSXP) &&
            (TYPEOF(subset) == INTSXP || TYPEOF(subset) == REALSXP)) {
        const int icol = (LENGTH(subset) == 1);
        const int irow = 2 * (TYPEOF(x) == INTSXP) + (TYPEOF(subset) == INTSXP);
        JIT_OPCODE opcode = subsetOps[irow][icol];
        if (icol == 1) {  // RA_TODO for now, evalJit only supports len 1 subs
            genjit(opcode, RNIL, NULL, NULL, 0,
                   NILSXP, LENGTH(subset), x, RNIL, RNIL);
        }
    }
}

void DCheckGenjitAssignParams(CSEXP sym, SEXP loc,
                              CSEXP value, CSEXP env, const char msg[])
{
#if DEBUG_JIT
    Dassert(TYPEOF(sym) == SYMSXP);
    Dassert(TYPEOF(loc) == LISTSXP || TYPEOF(loc) == SYMSXP);
    Dassert(loc != RNIL && loc != R_UnboundValue);
#endif
#if DEBUG_JIT_SYM
    if (sym != loc) {
        SEXP findVarLoc1 = findVarLoc(sym, env);
        assert(findVarLoc1 != R_UnboundValue);
        assert(getSymFromLoc(findVarLoc1) == sym);
        if (loc != RNIL && loc != findVarLoc1) {
            printf("Passed in from %s\n", msg);
            printfSxp(loc,  "  loc");
            printf("  sym "); printSxp(sym, env, TRUE);
            printfSxp(env, "  env");
            printfSxp(findVarLoc1, "Calculated\n  findVarLoc1");
            assertFail(__FILE__, __LINE__, "see above messages");
       }
    }
#endif
}

// Generate jit instruction for subassign: x[i] = y
// When executing in evalJit, there will be 3 values already on the
// stack at the subassign instruction: y, x, index (index is TOS).
// This func and genjitSubas rely on the order of evaluation in subassign.c.

static R_INLINE void doSubas(void)
{
    Dassert(jitState == JITS_AWAITING_AS);
    if (LENGTH(subas.index) == 1) {
        int xtype  = TYPEOF(subas.x);
        int itype  = TYPEOF(subas.index);
        int ytype  = TYPEOF(subas.y);
        int ix = -999, ii = -999, iy = -999; // opcode type adjustment
        int opcode;

        if (xtype == LGLSXP || xtype == INTSXP)
            ix = JIT_subas_i_r1_r - JIT_subas_r_r1_r;
        else if (xtype == REALSXP)
            ix = 0;

        if (itype == LGLSXP || itype == INTSXP)
            ii = JIT_subas_r_i1_r - JIT_subas_r_r1_r;
        else if (itype == REALSXP)
            ii = 0;

        if (ytype == LGLSXP || ytype == INTSXP)
            iy = JIT_subas_r_r1_i - JIT_subas_r_r1_r;
        else if (ytype == REALSXP)
            iy = 0;

        opcode = JIT_subas_r_r1_r + ix + ii + iy;

        if (opcode >= 0) {
            decJitUnresolved(3); // account for the y, x, i
            genjit((JIT_OPCODE)opcode, RNIL, NULL, NULL, 0,
                   xtype, 1, RNIL, RNIL, RNIL);
        }
    }
    setJitState(JITS_COMPILING, "doSubas");
}

// Invoked for R subscripted assignments: x[index] = y.
// This just stashes the information.  The actual instruction will
// be generated later in doSubas (which is called from genjitAssign).
//
// The "subas.depth > R_EvalDepth" catches nested subassigns.
// An example nested subassign is y[ x[1]<-2 ] <- 3.
// Since we don't have a subas stack we jit only the innermost subassign.
// It doesn't really matter because nested subassigns are unusual.
//
// RA_TODO Sometimes give "nested subassignment" when should give "unresolved"
// msg, to reproduce: time-jit.R with trace.flag<-2, grep for "nested".

void genjitSubas(CSEXP x, CSEXP index, CSEXP y)
{
    Dassert(jitState == JITS_COMPILING);
    if (subas.depth > R_EvalDepth)
        terminateCompile("nested subassignment");
    else {
        subas.depth = R_EvalDepth;
        subas.x = x;
        subas.index = index;
        subas.y = y;
        setJitState(JITS_AWAITING_AS, "genjitSubas");
    }
}

// Invoked for R assignments.
//
// Regular assignment x <- y:
//   We have already generated code to push the value onto the stack
//   We now generate a JIT_as opcode with y as the
//   operand (y is not pushed).
//
// Subscripted assignment y[index] <- x:
//   When compiling:
//     The evaluator has converted the subscripted assign to a regular assign.
//     y, x, and index were saved earlier by genjitSubas.
//     We now generate a JIT_subas opcode.
//   When in evalJit:
//     y, x, and index are already on the stack when we get to the
//     JIT_subas instruction.
//
// The check and early return against jitUnresolved==0 are for
// this (unusual) code: if (a) z <- if (b) 2   (notice no else).
// But note that this code gets generated ok: if (a) z <- if (b) 2 else 3

void genjitAssign(CSEXP sym, SEXP loc, CSEXP y,  // y is the evaluated rhs
                  CSEXP env, const char msg[])
{
    SEXP symval;
    SEXPTYPE ytype = TYPEOF(y);
    int ny = LENGTH(y);

    Dassert(jitCompiling());

    if (jitUnresolved == 0)
        return;
    if (BINDING_IS_LOCKED(loc))
        error("cannot jit a locked binding");
    if (IS_ACTIVE_BINDING(loc))
        error("cannot jit an active binding");
    if (ytype != LGLSXP && ytype != INTSXP && ytype != REALSXP)
        return;
    if (ny == 0)
        return;
    if (jitState == JITS_NO_AS) {
        traceNoas();
        return;
    }
    if (sym->sxpinfo.gp & CANNOT_JIT_BIT)
        terminateCompile("user specified nojit");
    else {
        DCheckGenjitAssignParams(sym, loc, y, env, msg);
        symval = getSymValFromLoc(loc);
        if (symval == R_UnboundValue)
            ;
        else if (jitState == JITS_AWAITING_AS)
            doSubas();      // subscripted assign: x[i] = y
        else {              // standard assign: x = y
            JIT_OPCODE opcode = adjustForTypes(JIT_as_r_r, symval, y);
            if (ny == 1)
                opcode += 3;                // r_r + 3 is r1_r1
            assert(ny == LENGTH(symval));   // check that both side have same len
            setJittedBit(loc);

            // convert ny to size in bytes for memcpy in evalJitAs
            if (ytype == LGLSXP || ytype == INTSXP)     
                ny *= sizeof(int);
            else // REALSXP
                ny *= sizeof(double);

            genjit(opcode, loc, NULL,  NULL, ny, 0, 0, y, sym, env);
       }
   }
}

static void genjitEval(JIT_OPCODE opcode, CSEXP e, CSEXP env)
{
    genjit(opcode, e,  NULL, NULL, 0, NILSXP, 0, RNIL, RNIL, env);
}

// R "if" statements are compiled as follows.
//
// if (CONDITION) ifbody:
//     ops to evaluate CONDITION
//     JIT_if_x
//     JIT_eval ifbody
//
// if (CONDITION) ifbody else elsebody:
//     ops to evaluate CONDITION
//     JIT_ifelse_x
//     JIT_eval ifbody
//     JIT_eval elsebody
//
// The JIT_evals will actually be evalated as JIT_evaljits
// if the body is a jitted expression.
//
// Note that this may call JitSuspend, so must call JitUnsuspend later

void genjitIf(CSEXP evaluatedCondition, CSEXP result,
              CSEXP call, CSEXP args, CSEXP env)
{
    JIT_OPCODE opcode = JIT_endop;
    const SEXPTYPE iftype = TYPEOF(evaluatedCondition);
    if (iftype == LGLSXP || iftype == INTSXP)
        opcode = JIT_if_i;
    else if (iftype == REALSXP)
        opcode = JIT_if_r;
    if (opcode != JIT_endop) {
        PROTECT(evaluatedCondition);
        PROTECT(result);
        if (length(args) < 3) { // no else clause?
            jitUnresolved++;    // prevent assert fail in decJitUnresolved
            genjit1(opcode);
            genjitEval(JIT_eval, CADR(args),  env);
        } else {                // has else clause
            opcode += (JIT_ifelse_i - JIT_if_i); // change opcode to "else" version
            jitUnresolved += 2;
            genjit1(opcode);
            genjitEval(JIT_eval, CADR(args),  env);
            genjitEval(JIT_eval, CADDR(args), env);
        }
        // prevent JIT generation while evaluating if and else clauses
        jitSuspend("genjitIf");
        UNPROTECT(2);
    }
}

// We only invoke this for jit blocks commencing with jit(2), not jit(1).
// And also it is only invoked for the inner "for" loops  of nested loops.
//
// Generate the following instructions:
//   for_i  operand=indexVarBindingLoc  sym=sym  env=env
//   args   operand=evaluated rhs of index expression
//   args   operand=body or operand=JITTED(body)

void genjitFor(CSEXP rhs, CSEXP sym, CSEXP body, CSEXP call, CSEXP env)
{
    Dassert(jitDirective >= 2);
    Dassert(TYPEOF(rhs) == INTSXP);
    call->sxpinfo.gp &= ~CANNOT_JIT_BIT; // was set in jitEnterLoopAux
    if (jitProlog(call, "genjitFor")) {
        jitUnresolved = 3;      // matches the 3 genjits below

        genjit(JIT_for_i, findVarLoc(sym, env), NULL, NULL, 0,
               NILSXP, 0, RNIL, sym, env);

        genjit(JIT_arg, rhs, NULL, NULL, 0, NILSXP, 0, RNIL, RNIL, RNIL);

        genjit(JIT_arg, body,  NULL, NULL, 0, NILSXP, 0, RNIL, RNIL, RNIL);

        jitEpilog(RNIL, "genjitFor");
    }
}

Generated by  Doxygen 1.6.0   Back to index