## Jitter specification for the JitterLisp VM.

## Copyright (C) 2017, 2018, 2020 Luca Saiu
## Written by Luca Saiu

## This file is part of JitterLisp, distributed as an example along with Jitter
## under the same license.

## Jitter 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 3 of the License, or
## (at your option) any later version.

## Jitter 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 Jitter.  If not, see <http://www.gnu.org/licenses/>.


## Global configuration.
#################################################################

vm
  set prefix "jitterlispvm"
end




## Stacks and register classes.
#################################################################

stack m
  long-name "mainstack"
  c-element-type "jitterlisp_object"
  c-initial-value "JITTERLISP_UNDEFINED"
  tos-optimized
end

stack t
  long-name "returnstack"
  c-element-type "jitterlisp_object"
  c-initial-value "JITTERLISP_UNDEFINED"
  non-tos-optimized
end

register-class r
  c-type "jitterlisp_object"
  c-initial-value "JITTERLISP_UNDEFINED"
  fast-register-no 0 #2
end




## Functions and globals to wrap.
#################################################################

wrapped-functions
  # Libc cunctions which may be implicitly called by compiled code, for
  # example when passing parameters.
# FIXME: no, GCC is not stupid and generates these directly in its
# intermediate representation.  The hack doesn't work here.

  # Temporary/debugging stuff.
  debug_pointer
#  printf
  jitterlisp_print

  # Calling interpreted closures from compiled code.
  jitterlisp_call_interpreted

  # These are needed in operations, as per jitterlisp-operations.h .  Only
  # the functions we call *directly* thru instructions need to be wrapped:
  # low-priority primitives, not worth optimizing, are all called via the
  # "primitive" VM instruction which invokes a function pointer given as an
  # instruction argument.
  # (None yet.)
  # [FIXME: I'll need some function related to eval, to call interpreted
  # code from VM code]

  # Some primitives, notably cons , allocate heap memory from VM instructions.
  jitterlisp_allocate

  # Erroring out from instructions.
  jitterlisp_fail_from_vm
  jitterlispvm_error_invalid_primitive_argument_type_unfriendly
  jitterlispvm_error_invalid_primitive_argument_type_friendly
end

wrapped-globals
  stack_printf_format_string
end

early-header-c
  code
#   include "jitterlisp.h"
  end
end

initialization-c
  code
  end
end

finalization-c
  code
  end
end

early-c
  code
#   include <stdio.h>
  end
end
late-c
  code
__attribute__ ((unused))
void
debug_pointer (jitter_int index, const void *pointer)
{
  return;
  printf ("[DEBUG: %lli %p]\n", (long long) index, pointer);
  fflush (stdout);
}

/* Open an argument-type-checking sequence, for the given number of arguments
   to be read from the main stack.  This is a helper macro for
   JITTERLISPVM_CHECK_TYPES_* . */
#define JITTERLISPVM_BEGIN_CHECK_TYPES_(_jitterlisp_vm_in_arity)  \
  JITTER_BEGIN_                                                   \
    int _jitterlispvm_arg_no = (_jitterlisp_vm_in_arity);         \
    int _jitterlispvm_arg_index __attribute__ ((unused)) = 0;     \
    int _jitterlispvm_arg_depth __attribute__ ((unused)) \
      = _jitterlispvm_arg_no - 1;

/* Check the next argument in the sequence, failing if its type doesn't match
   the given uppercase suffix.  Do nothing if compiling an unsafe JitterLisp. */
#ifdef JITTERLISP_UNSAFE
# define JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type,    \
                                       _jitterlisp_error_fast_label)  \
    { /* Do nothing. */ }
#else
# define JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type,     \
                                       _jitterlisp_error_fast_label)   \
    {                                                                  \
      /* Branch-fast to the given label if the next object type is     \
         not the required one. */                                      \
      JITTER_CONCATENATE_TWO (JITTERLISP_BRANCH_FAST_UNLESS_,          \
                              _jitterlisp_uppercase_type)              \
         (JITTER_AT_DEPTH_MAINSTACK(_jitterlispvm_arg_depth),          \
          _jitterlisp_error_fast_label);                               \
      _jitterlispvm_arg_depth --;                                      \
      _jitterlispvm_arg_index ++;                                      \
    }
#endif // #ifdef JITTERLISP_UNSAFE

/* Close an argument-type-checking sequence.  This is a helper macro for
   JITTERLISPVM_CHECK_TYPES_* . */
#define JITTERLISPVM_END_CHECK_TYPES_  \
  JITTER_END_

/* For in-arity N, check that the topmost N arguments have the given N types
   expressed as uppercase suffixes, respectively.  This functionality is
   provided for a few common values of N . */
#define JITTERLISPVM_CHECK_TYPES_1(_jitterlisp_uppercase_type_0,  \
                                   _jitterlisp_error_fast_label)  \
  JITTERLISPVM_BEGIN_CHECK_TYPES_(1)                              \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_0,   \
                                  _jitterlisp_error_fast_label);  \
  JITTERLISPVM_END_CHECK_TYPES_
#define JITTERLISPVM_CHECK_TYPES_2(_jitterlisp_uppercase_type_0,  \
                                   _jitterlisp_uppercase_type_1,  \
                                   _jitterlisp_error_fast_label)  \
  JITTERLISPVM_BEGIN_CHECK_TYPES_(2)                              \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_0,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_1,   \
                                  _jitterlisp_error_fast_label);  \
  JITTERLISPVM_END_CHECK_TYPES_
#define JITTERLISPVM_CHECK_TYPES_3(_jitterlisp_uppercase_type_0,  \
                                   _jitterlisp_uppercase_type_1,  \
                                   _jitterlisp_uppercase_type_2,  \
                                   _jitterlisp_error_fast_label)  \
  JITTERLISPVM_BEGIN_CHECK_TYPES_(3)                              \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_0,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_1,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_2,   \
                                  _jitterlisp_error_fast_label);  \
  JITTERLISPVM_END_CHECK_TYPES_
#define JITTERLISPVM_CHECK_TYPES_4(_jitterlisp_uppercase_type_0,  \
                                   _jitterlisp_uppercase_type_1,  \
                                   _jitterlisp_uppercase_type_2,  \
                                   _jitterlisp_uppercase_type_3,  \
                                   _jitterlisp_error_fast_label)  \
  JITTERLISPVM_BEGIN_CHECK_TYPES_(4)                              \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_0,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_1,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_2,   \
                                  _jitterlisp_error_fast_label);  \
    JITTERLISPVM_CHECK_NEXT_TYPE_(_jitterlisp_uppercase_type_3,   \
                                  _jitterlisp_error_fast_label);  \
  JITTERLISPVM_END_CHECK_TYPES_

#if 0
# define JITTERLISPVM_ERROR_INVALID_PRIMITIVE_ARGUMENT_TYPE_          \
    jitterlispvm_error_invalid_primitive_argument_type_unfriendly ()
#else
# define JITTERLISPVM_ERROR_INVALID_PRIMITIVE_ARGUMENT_TYPE_     \
    jitterlispvm_error_invalid_primitive_argument_type_friendly  \
       (JITTER_SPECIALIZED_INSTRUCTION_OPCODE,                   \
        _jitterlispvm_arg_index,                                 \
        JITTER_AT_DEPTH_MAINSTACK(_jitterlispvm_arg_depth))
#endif


// Unfortunately the attribute is invisible across the wrapper.
// This is convenient for debugging, but I don't want to use it in production:
// passing parameters at every call makes the code much bigger, even if the
// call is not executed.
__attribute__ ((noreturn, unused))
static void
jitterlispvm_error_invalid_primitive_argument_type_friendly
   (int sins_opcode,
    int arg_index,
    jitterlisp_object o)
{
  /* Print information about the argument and its hex representation:
     don't dare yet to print it as a Lisp object, as the printer might
     crash if there is a bug and the object is invalid. */
  char buffer [1000];
  printf (buffer,
          "%s: About the %i-th (0-based) primitive argument %p\n",
          jitterlispvm_specialized_instruction_names [sins_opcode],
          arg_index, (void *) o);
  jitterlisp_print_error_char_star (buffer);

  /* This shouldn't be needed on GNU, but flush the output so that we can be
     sure that the previous line is visible before we crash. */
  jitter_print_flush (jitterlisp_print_context);

  /* Okay, now we can print in in Lisp. */
  jitterlisp_print_error_char_star ("  (in Lisp ");
  jitterlisp_print_error (o);
  jitterlisp_print_error_char_star ("):\n");

  jitterlisp_error_cloned ("invalid primitive argument type");
}

__attribute__ ((noreturn, unused))
static void
jitterlispvm_error_invalid_primitive_argument_type_unfriendly (void)
{
  jitterlisp_error_cloned ("invalid primitive argument type");
}

static void
jitterlisp_fail_from_vm (void)
{
  jitterlisp_error_cloned ("unspecified error raised by VM code");
}

    static const char *stack_printf_format_string __attribute__ ((unused))
      = "%" JITTER_PRIi "\n";
  end
end




## Custom literal argument printer.
#################################################################

printer-c
  code
    /* Not really needed.  The printer is jitterlisp_print. */
  end
end




## Debugging code for instructions.
#################################################################

early-c
  code
  end
end

late-c
#initialization-c
  code
  end
end

instruction-beginning-c
  code
  end
end

instruction-end-c
  code
  end
end




## User-defined state fields (scratch).
#################################################################

early-header-c
  code
/* If enabled, use my nonworking heap allocation stub.  This is useful to me,
   for playing with the still non-existent Jitter garbage collector and reason
   about its API. */
//#define JITTER_GC_STUB
  end
end

late-header-c
  code
  end
end

late-c
  code
  end
end

state-struct-runtime-c
  code
#ifdef JITTER_GC_STUB
    /* A pointer to the next free byte in the nursery.  Untagged. */
    char *allocation_next;

    /* The nursery allocation limit, untagged -- which is to say, the maximum
       valid address in the nursery plus 1.
       Notice that it is correct, is slightly conservative, to compare even a
       tagged pointer against this in an expression like
          new_tagged_pointer < allocation_limit
       , since a tagged pointer is always greater than or equal to its untagged
       counterpart. */
    char *allocation_limit;
#endif // #ifdef JITTER_GC_STUB
  end
end

state-initialization-c
  code
#ifdef JITTER_GC_STUB
  /* Initialize the next pointer and the limit pointer to refer to a fixed-size
     nursery.  There is no real GC yet, so when next hits limit there will be
     a failure; still, allocation should work up to that point. */
  size_t nursery_size = 1024 * 1024 * 10;
  char *nursery = jitter_xmalloc (nursery_size);
  jitter_state_runtime->allocation_next = nursery;
  jitter_state_runtime->allocation_limit = nursery + nursery_size;
#endif // #ifdef JITTER_GC_STUB
  end
end




## Instructions.
#################################################################

instruction nop ()
  code
  end
end

instruction dup ()
  code
    JITTER_DUP_MAINSTACK();
  end
end

instruction drop ()
  code
    JITTER_DROP_MAINSTACK();
  end
end

instruction nip ()
  code
    JITTER_NIP_MAINSTACK();
  end
end

instruction nip-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end

instruction drop-nip ()
  code
    JITTER_DROP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end

# FIXME: make a one-argument version generalizing these.  These zero-argument
# versions are useful to generate from rewrite rules right now, before Jitter
# support is ready.
# Each of these VM instructions compiles to just one fast hardware instruction,
# decrementing a register by a constant without touching memory.
instruction nip-two ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end
instruction nip-three ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end
instruction nip-four ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end
instruction nip-five ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end
instruction nip-six ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
  end
end

# Each of these has the same cost of a single drop.
# FIXME: generalize into a unary instruction when Jitter rewrite rules become
# expressive enough to obtain these by rewriting.
instruction nip-two-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end
instruction nip-three-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end
instruction nip-four-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end
instruction nip-five-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end
instruction nip-six-drop ()
  code
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end

# FIXME: is this ever needed?
instruction push-unspecified ()
  code
    JITTER_PUSH_UNSPECIFIED_MAINSTACK();
  end
end

instruction push-register (?R)
  code
    jitterlisp_object k = JITTER_ARG0;
    JITTER_PUSH_MAINSTACK(k);
  end
end

instruction push-literal (?n jitterlisp_print)
  code
    jitterlisp_object k = JITTER_ARGN0;
    JITTER_PUSH_MAINSTACK(k);
  end
end

instruction push-global (?n jitterlisp_print, ?f)
  code
    jitterlisp_object tagged_symbol = JITTER_ARGN0;
    struct jitterlisp_symbol * symbol = JITTERLISP_SYMBOL_DECODE(tagged_symbol);

#ifndef JITTERLISP_UNSAFE
    JITTER_BRANCH_FAST_IF_EQUAL (symbol->global_value, JITTERLISP_UNDEFINED,
                                 JITTER_ARGF1);
#endif // #ifndef JITTERLISP_UNSAFE

//    JITTER_PUSH_MAINSTACK(symbol->global_value);
    JITTER_PUSH_UNSPECIFIED_MAINSTACK();
    JITTER_TOP_MAINSTACK() = symbol->global_value;
  end
end

# FIXME: use these, in rewrites.
instruction push-nil ()
  code
    JITTER_PUSH_MAINSTACK(JITTERLISP_EMPTY_LIST);
  end
end
instruction push-zero ()
  code
    JITTER_PUSH_MAINSTACK(JITTERLISP_FIXNUM_ENCODE(0));
  end
end
instruction push-one ()
  code
    JITTER_PUSH_MAINSTACK(JITTERLISP_FIXNUM_ENCODE(1));
  end
end
instruction push-false ()
  code
    JITTER_PUSH_MAINSTACK(JITTERLISP_FALSE);
  end
end
instruction push-nothing ()
  code
    JITTER_PUSH_MAINSTACK(JITTERLISP_NOTHING);
  end
end

instruction pop-to-register (!R)
  code
    JITTER_ARG0 = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end

instruction pop-to-global (?n jitterlisp_print, ?f)
  code
    jitterlisp_object tagged_symbol = JITTER_ARGN0;
    struct jitterlisp_symbol *symbol = JITTERLISP_SYMBOL_DECODE(tagged_symbol);
#ifndef JITTERLISP_UNSAFE
    JITTER_BRANCH_FAST_IF_NONZERO (symbol->global_constant, JITTER_ARGF1);
#endif // #ifndef JITTERLISP_UNSAFE
    symbol->global_value = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end

instruction pop-to-global-defined (?n jitterlisp_print, ?f)
  code
    jitterlisp_object tagged_symbol = JITTER_ARGN0;
    struct jitterlisp_symbol *symbol = JITTERLISP_SYMBOL_DECODE(tagged_symbol);
#ifndef JITTERLISP_UNSAFE
    JITTER_BRANCH_FAST_IF_NONZERO (symbol->global_constant, JITTER_ARGF1);
    JITTER_BRANCH_FAST_IF_EQUAL (symbol->global_value, JITTERLISP_UNDEFINED,
                                 JITTER_ARGF1);
#endif // #ifndef JITTERLISP_UNSAFE
    symbol->global_value = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
  end
end

# The first argument must not be zero.
# Rationale: when I switch to JITTER_AT_DEPTH_UNSAFE_MAINSTACK this will make the
# unspecialized case faster by avoiding a conditional.
instruction at-depth-to-register (?n 1 2 3 4 5 6 7 8 9 10, !R)
  code
    // FIXME: replace with JITTER_AT_DEPTH_UNSAFE_MAINSTACK after I implement
    // unsafe at-depth operations.
    JITTER_ARG1 = JITTER_AT_DEPTH_MAINSTACK(JITTER_ARGN0);
  end
end

instruction copy-to-register (!R)
  code
    JITTER_ARG0 = JITTER_TOP_MAINSTACK();
  end
end

instruction copy-from-register (?R)
  code
    JITTER_TOP_MAINSTACK() = JITTER_ARG0;
  end
end

instruction copy-from-literal (?n jitterlisp_print)
  code
    JITTER_TOP_MAINSTACK() = JITTER_ARGN0;
  end
end

instruction literal-to-register (?n jitterlisp_print, !R)
  code
    JITTER_ARG1 = JITTER_ARGN0;
  end
end

instruction register-to-register (?R, !R)
  code
    JITTER_ARG1 = JITTER_ARG0;
  end
end

# Do a check on the top element, fast-branching to the given error-handling
# routine in case of mismatch, and do nothing otherwise.
# Do *not* pop an operand from the stack.
# FIXME: factor into a common comment for checking instructions.
instruction check-closure (?f)
  code
#   ifndef JITTERLISP_UNSAFE
      jitterlisp_object top = JITTER_TOP_MAINSTACK();
      if (! JITTERLISP_IS_CLOSURE(top))
        JITTER_BRANCH_FAST(JITTER_ARGF0);
#   endif // #ifndef JITTERLISP_UNSAFE
  end
end

# Fast-branch to the given error label if the given argument, a tagged symbol,
# is not globally bound.
instruction check-global-defined (?n jitterlisp_print, ?f)
  code
#ifndef JITTERLISP_UNSAFE
    jitterlisp_object tagged_symbol = JITTER_ARGN0;
    struct jitterlisp_symbol * symbol = JITTERLISP_SYMBOL_DECODE(tagged_symbol);
    JITTER_BRANCH_FAST_IF_EQUAL (symbol->global_value, JITTERLISP_UNDEFINED,
                                 JITTER_ARGF1);
#endif // #ifndef JITTERLISP_UNSAFE
  end
end

# This versions is the one failing under no-threading.  I want to keep it for tests
# even if it's not the best implementation.
# # The fixnum argument is untagged.
instruction check-in-arity--alt (?n 0 1 2 3 4 5 6 7 8 9 10, ?f)
  code
    // FIXME: this loops forever with no-threading (not with the other dispatching models
    // including minimal threading) when the callee is compiled.  A Jitter bug.
    /* Here we can assume that the top object is a closure, without checking: we either
       already performed a type check, or the compiler decided it wasn't necessary. */
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(top);

    /* FIXME: this is optimizable.  I should store the in-arity as a field, independently
       from the closure compiledness.  [Done] */
    if (JITTERLISP_IS_COMPILED_CLOSURE(top))
      {
        if (c->in_arity != JITTER_ARGN0)
          JITTER_BRANCH_FAST(JITTER_ARGF1);
      }
    else
      {
        /* The closure is interpreted.  Compute its in-arity.  We can assume that
           the formal list is well-formal, which is to say actually a proper list
           of distinct symbols. */
        struct jitterlisp_interpreted_closure *ic = & c->interpreted;
        jitterlisp_object rest = ic->formals;
        jitter_uint in_arity = 0;
        while (! JITTERLISP_IS_EMPTY_LIST(rest))
          {
            in_arity ++;
            rest = JITTERLISP_EXP_C_A_CDR(rest);
          }
        if (in_arity != JITTER_ARGN0)
          JITTER_BRANCH_FAST(JITTER_ARGF1);
      }
  end
end

instruction check-in-arity (?n 0 1 2 3 4 5 6 7 8 9 10, ?f)
  code
#   ifndef JITTERLISP_UNSAFE
      /* Here we can assume that the top object is a closure, without checking:
         we either already performed a type check, or the compiler decided it
         wasn't necessary. */
      jitterlisp_object top = JITTER_TOP_MAINSTACK();
      struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(top);

      JITTER_BRANCH_FAST_IF_NOTEQUAL(c->in_arity, JITTER_ARGN0, JITTER_ARGF1);
#   endif // #ifndef JITTERLISP_UNSAFE
  end
end


instruction branch (?f)
  code
    JITTER_BRANCH_FAST(JITTER_ARGF0);
  end
end

instruction branch-if-false (?f)
  code
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
    JITTER_BRANCH_FAST_IF_EQUAL(top, JITTERLISP_FALSE, JITTER_ARGF0);
  end
end

instruction branch-if-true (?f)
  code
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
    JITTER_BRANCH_FAST_IF_NOTEQUAL(top, JITTERLISP_FALSE, JITTER_ARGF0);
  end
end

instruction branch-if-null (?f)
  code
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
    JITTER_BRANCH_FAST_IF_EQUAL(top, JITTERLISP_EMPTY_LIST, JITTER_ARGF0);
  end
end

instruction branch-if-not-null (?f)
  code
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
    JITTER_BRANCH_FAST_IF_NOTEQUAL(top, JITTERLISP_EMPTY_LIST, JITTER_ARGF0);
  end
end

instruction canonicalize-boolean ()
  code
    JITTERLISP_BOOLEAN_CANONICALIZE_(JITTER_TOP_MAINSTACK(),
                                     JITTER_TOP_MAINSTACK());
  end
end

# The first argument is a primitive function pointer.
# The second is its in-arity.
# instruction primitive (?n, ?n 0 1 2 3 4, ?l)
#  non-relocatable
instruction primitive (?n, ?n 0 1 2 3 4, ?f)
  code
    /* The error-handling label is not actually used in this case: the
       primitive function, written in C, has its own handling.  It's
       harmless to have it anyway, as it makes the C code generator
       more uniform. */
    jitterlisp_primitive_function p
      = (jitterlisp_primitive_function) JITTER_ARGP0;
    const jitter_uint in_arity = JITTER_ARGN1;
    JITTER_PUSH_UNSPECIFIED_MAINSTACK();
    //asm volatile ("nop");
    jitterlisp_object *first_arg
      // FIXME: add a stack operator to compute this address.
      = (& JITTER_UNDER_TOP_MAINSTACK()) - in_arity + 1;
    /* This workaround is needed for Alpha.  I have macros to make this nicer in
       ~luca/repos/jitter/gcc-call-function-macro.c , still to be integrated into
       Jitter. */
/*
    void *saved_gp;
    asm volatile ("stq $gp, %[saved_gp]"
                  : [saved_gp] "=o" (saved_gp),
                    "+X" (p));
*/
    jitterlisp_object res = p (first_arg);
    /* Second part of the Alpha workaround. */
/*
    asm volatile ("ldq $gp, %[saved_gp]"
                  : "+X" (res)
                  : [saved_gp] "o" (saved_gp));
*/

    jitter_uint i;
    // Remove as many elements as the primitive in-arity, but not more:
    // the top unspecified value we pushed will be replaced with the result.
    for (i = 0; i < in_arity; i ++)
      JITTER_NIP_MAINSTACK();
    //asm ("unop" : "+g" (jitter_state_runtime));
    JITTER_TOP_MAINSTACK() = res;
  end
end

instruction primitive-car (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(CONS, JITTER_ARGF0);
    JITTERLISP_CAR_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-cdr (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(CONS, JITTER_ARGF0);
    JITTERLISP_CDR_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction heap-allocate (?n 4 8 12 16 24 32 36 48 52 64)
  code
#ifdef JITTER_GC_STUB
    /* FIXME: I might want to merge this, along with the body of other
       instructions, into a macro.  This may still be factored in a different
       way, but the idea looks correct and promising. */
    /* Bump the allocation pointer, unconditionally.  Another instruction
       will check if it went out of the nursery. */
    const size_t allocation_size = JITTER_ARGN0;
    JITTER_STATE_RUNTIME_FIELD (allocation_next) += allocation_size;
#else
    /* Nothing to do.  With the ordinary non-stub heap all the actual
       memory allocation happens in primitive-cons-special. */
#endif //#ifdef JITTER_GC_STUB
  end
end

instruction gc-if-needed (?f)
  code
#ifdef JITTER_GC_STUB
    /* FIXME: I might want to merge this, along with the body of other
       instructions, into a macro.  This may still be factored in a different
       way, but the idea looks correct and promising. */
    /* Branch to the slow path of the allocation, which includes a minor GC,
       in case the allocation pointer is now out of the nursery.  Do nothing
       otherwise.
       Rationale: separating branches from instructions having effect on the VM
       state prevents defective instructions; even if I have reason to believe
       that this particular state effect (unconditionally incrementing a runtime
       field) is not problematic with respect to defects, I will need to seriously
       stress the system after defect replacement is really implemented. */
    JITTER_BRANCH_FAST_IF_NOTLESS_UNSIGNED
       (JITTER_STATE_RUNTIME_FIELD (allocation_next),
        JITTER_STATE_RUNTIME_FIELD (allocation_limit),
        JITTER_ARGF0);
#else
    /* Nothing to do.  With the ordinary non-stub heap all the actual
       memory allocation happens in primitive-cons-special. */
#endif //#ifdef JITTER_GC_STUB
  end
end

# This doesn't nip, in the hope that the separate nip instruction generated
# right after this will be rewritten.
instruction primitive-cons-special ()
  code
#ifdef JITTER_GC_STUB
    /* This is a preliminary version of the allocation fast path, using a
       still non-existing Jitter garbage collector.
       Of course most of this should be factored into a macro. */
    const size_t allocation_size
      = JITTER_BYTES_PER_WORD * 2;
    const size_t header_size = 0;
    jitterlisp_object tagged_cons
      = JITTERLISP_CONS_ENCODE
          (JITTER_STATE_RUNTIME_FIELD (allocation_next)
           - allocation_size + header_size);
    JITTERLISP_CONS_DECODE (tagged_cons)->car = JITTER_UNDER_TOP_MAINSTACK();
    JITTERLISP_CONS_DECODE (tagged_cons)->cdr = JITTER_TOP_MAINSTACK();
    JITTER_TOP_MAINSTACK() = tagged_cons;
#else // ! JITTER_GC_STUB
    JITTERLISP_CONS_(JITTER_TOP_MAINSTACK(),
                     JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
#endif //#ifdef JITTER_GC_STUB
  end
end

# The two VM instructions for the set-car! and set-cdr! operations do not
# consume any operand from the stack, and so are followed by other VM
# instructions to adjust the stack and set the TOS in compiled code.  Such
# separate instructions can often be rewritten away.
instruction primitive-set-carb-special (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(CONS, ANYTHING, JITTER_ARGF0);
    jitterlisp_object useless __attribute__ ((unused));
    JITTERLISP_SET_CARB_(useless,
                         JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    /* Leave the two operands on the stack. */
  end
end
instruction primitive-set-cdrb-special (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(CONS, ANYTHING, JITTER_ARGF0);
    jitterlisp_object useless __attribute__ ((unused));
    JITTERLISP_SET_CDRB_(useless,
                         JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    /* Leave the two operands on the stack. */
  end
end

instruction primitive-box ()
  code
    JITTERLISP_BOX_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-box-get (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(BOX, JITTER_ARGF0);
    JITTERLISP_BOX_GET_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

# See the comment above for set-car! and set-cdr! .  The same performance
# considerations hold for box-set! .
instruction primitive-box-setb-special (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(BOX, ANYTHING, JITTER_ARGF0);
    jitterlisp_object useless __attribute__ ((unused));
    JITTERLISP_BOX_SETB_(useless,
                         JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    /* Leave the two operands on the stack. */
  end
end

instruction primitive-eqp ()
  code
    JITTERLISP_EQP_(JITTER_TOP_MAINSTACK(),
                    JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-not-eqp ()
  code
    JITTERLISP_NOT_EQP_(JITTER_TOP_MAINSTACK(),
                        JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-fixnum-eqp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_EQP_(JITTER_TOP_MAINSTACK(),
                    JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-fixnum-not-eqp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_NOT_EQP_(JITTER_TOP_MAINSTACK(),
                        JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-zerop (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_ZEROP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-zerop (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_NON_ZEROP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-positivep (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_POSITIVEP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-positivep (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_NON_POSITIVEP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-negativep (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_NEGATIVEP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-negativep (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_NON_NEGATIVEP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-lessp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_LESSP_(JITTER_TOP_MAINSTACK(),
                      JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-greaterp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_GREATERP_(JITTER_TOP_MAINSTACK(),
                         JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-not-lessp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_NOTLESSP_(JITTER_TOP_MAINSTACK(),
                         JITTER_UNDER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-not-greaterp (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_NOTGREATERP_(JITTER_TOP_MAINSTACK(),
                            JITTER_UNDER_TOP_MAINSTACK(),
                            JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-one-plus (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_1PLUS_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                  JITTER_TOP_MAINSTACK(),
                                  JITTER_ARGF0);
  end
end

instruction primitive-one-minus (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_1MINUS_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                   JITTER_TOP_MAINSTACK(),
                                   JITTER_ARGF0);
  end
end

instruction primitive-two-times (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_2TIMES_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                   JITTER_TOP_MAINSTACK(),
                                   JITTER_ARGF0);
  end
end

instruction primitive-two-divided (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_2DIVIDED_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-two-quotient (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_2QUOTIENT_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-two-remainder (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_2REMAINDER_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-negate (?f)
  code
    JITTERLISPVM_CHECK_TYPES_1(FIXNUM, JITTER_ARGF0);
    JITTERLISP_NEGATE_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                   JITTER_TOP_MAINSTACK(),
                                   JITTER_ARGF0);
  end
end

instruction primitive-primordial-plus (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_PLUS_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                 JITTER_UNDER_TOP_MAINSTACK(),
                                 JITTER_TOP_MAINSTACK(),
                                 JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-primordial-minus (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_MINUS_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                  JITTER_UNDER_TOP_MAINSTACK(),
                                  JITTER_TOP_MAINSTACK(),
                                  JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-primordial-times (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_TIMES_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                  JITTER_UNDER_TOP_MAINSTACK(),
                                  JITTER_TOP_MAINSTACK(),
                                  JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-primordial-divided (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_DIVIDED_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                    JITTER_UNDER_TOP_MAINSTACK(),
                                    JITTER_TOP_MAINSTACK(),
                                    JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-quotient (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_QUOTIENT_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                     JITTER_UNDER_TOP_MAINSTACK(),
                                     JITTER_TOP_MAINSTACK(),
                                     JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-remainder (?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF0);
    JITTERLISP_REMAINDER_OR_OVERFLOW_(JITTER_TOP_MAINSTACK(),
                                      JITTER_UNDER_TOP_MAINSTACK(),
                                      JITTER_TOP_MAINSTACK(),
                                      JITTER_ARGF0);
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-primordial-divided-unsafe (?f)
  code
    /* The second argument has already been validated if we are using this. */
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, ANYTHING, JITTER_ARGF0);
    JITTERLISP_DIVIDED_UNSAFE_(JITTER_TOP_MAINSTACK(),
                               JITTER_UNDER_TOP_MAINSTACK(),
                               JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-quotient-unsafe (?f)
  code
    /* The second argument has already been validated if we are using this. */
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, ANYTHING, JITTER_ARGF0);
    JITTERLISP_QUOTIENT_UNSAFE_(JITTER_TOP_MAINSTACK(),
                               JITTER_UNDER_TOP_MAINSTACK(),
                               JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-remainder-unsafe (?f)
  code
    /* The second argument has already been validated if we are using this. */
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, ANYTHING, JITTER_ARGF0);
    JITTERLISP_REMAINDER_UNSAFE_(JITTER_TOP_MAINSTACK(),
                                 JITTER_UNDER_TOP_MAINSTACK(),
                                 JITTER_TOP_MAINSTACK());
    JITTER_NIP_MAINSTACK();
  end
end

instruction primitive-nullp ()
  code
    JITTERLISP_NULLP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-nullp ()
  code
    JITTERLISP_NON_NULLP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-nothingp ()
  code
    JITTERLISP_NOTHINGP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-fixnump ()
  code
    JITTERLISP_FIXNUMP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-characterp ()
  code
    JITTERLISP_CHARACTERP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-uniquep ()
  code
    JITTERLISP_UNIQUEP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-consp ()
  code
    JITTERLISP_CONSP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-consp ()
  code
    JITTERLISP_NON_CONSP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-symbolp ()
  code
    JITTERLISP_SYMBOLP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-non-symbolp ()
  code
    JITTERLISP_NON_SYMBOLP_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-not ()
  code
    JITTERLISP_NOT_(JITTER_TOP_MAINSTACK(), JITTER_TOP_MAINSTACK());
  end
end

instruction primitive-boolean-canonicalize ()
  code
    JITTERLISP_BOOLEAN_CANONICALIZE_(JITTER_TOP_MAINSTACK(),
                                     JITTER_TOP_MAINSTACK());
  end
end

# Take a compiled closure (no type checking), its arguments already evaluated,
# and the number of arguments (untagged) on the top of stack.  Replace all the
# stack operands with the call result.
# Rationale: this instruction has been designed to be the first and only
# instruction executed in the driver VM routine, called from the AST interpreter
# in C.
# The same driver routine can be generated once at initialization, and then
# reused to launch procedures as needed: this is why the instruction takes
# the closure in-arity from the stack instead of from an instruction argument.
instruction call-from-c ()
  caller
  code
    /* Pop a number (untagged) off the stack, so that I know at which
       depth to find the closure.  The arity check must have been
       performed already on the interpreter side. */
    const jitter_uint in_arity_plus_one = JITTER_TOP_MAINSTACK();

    /* What follows is similar to the call instruction in the case of a compiled
       callee.  Shall I factor the common code with a macro? */

    /* Decode the closure. */
//#define STRESS
#ifndef STRESS
    // FIXME: This is correct, and faster ...
    jitterlisp_object callee
      = JITTER_AT_NONZERO_DEPTH_MAINSTACK(in_arity_plus_one);
    JITTER_DROP_MAINSTACK();
#else
    // FIXME ...But this stresses the code better (mips gcc 8, x86_64 gcc 7).
    JITTER_DROP_MAINSTACK();
    jitterlisp_object callee
      = JITTER_AT_DEPTH_MAINSTACK(in_arity_plus_one - 1);
#endif // #ifndef STRESS
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(callee);
    struct jitterlisp_compiled_closure *cc = & c->compiled;

    /* Make place for the return address in the return stack.  The
       actual value will be written by the callee. */
    JITTER_PUSH_UNSPECIFIED_RETURNSTACK();

    /* Branch-and-link.  This follows the ordinary calling convention,
       with the main stack containing the closure and its actuals, known
       to be in the correct number.  The next VM instruction will be a
       prolog saving the link; then execution will fall thru into the
       compiled closure body. */
    JITTER_BRANCH_AND_LINK(cc->first_program_point);
  end
end

# This is the generic code working for both compiled and interpreted closures.
# FIXME: factor with the other call instructions.
instruction call (?n 0 1 2 3 4 5 6 7 8 9 10)
  caller
  code
    const jitter_uint in_arity = JITTER_ARGN0;
    jitterlisp_object callee = JITTER_AT_DEPTH_MAINSTACK(in_arity);
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(callee);

    if (c->kind == jitterlisp_closure_type_compiled)
      {
        /* Make place for the return address in the return stack.  The
           actual value will be written by the callee. */
        JITTER_PUSH_UNSPECIFIED_RETURNSTACK();

        /* Branch-and-link to the native code, whose first instruction
           will be a prolog. */
        struct jitterlisp_compiled_closure *cc = & c->compiled;
        JITTER_BRANCH_AND_LINK(cc->first_program_point);
      }
    else
      {
        const struct jitterlisp_interpreted_closure *ic = & c->interpreted;

        /* Push an element on the main stack.  This way we can ensure that
           every actual is accessible thru memory in a contiguous array,
           even if the main stack is TOS-optimized.  Compute the address
           (on the main stack backing) where the actuals begin.

           Notice that the interpreted function we are calling is allowed
           to call into compiled code in its turn.  This is not a problem,
           as we are not moving stack pointers down until the call ends:
           the unused part of the main and return stacks is available to
           the callee. */
        JITTER_PUSH_UNSPECIFIED_MAINSTACK();
        jitterlisp_object *actuals
          // FIXME: add a stack operator to compute this address.
          = (& JITTER_UNDER_TOP_MAINSTACK()) - in_arity + 1;

        /* Call the interpreter. */
        jitterlisp_object interpretation_result
          = jitterlisp_call_interpreted (ic, actuals, in_arity);

        /* Remove as many elements as the in-arity plus one (the callee) from
           the stack, without affecting the top.  Unless JITTER_ARGN0 is
           residual this whole loops compiles to one instruction when the main
           stack is TOS-optimized, and doesn't touch memory. */
        int i;
        for (i = 0; i < in_arity + 1; i ++)
          JITTER_NIP_MAINSTACK();

        /* Now the stack is one element higher than it was before the call,
           containing the unspecified element at the top.  Replace it with
           the result.  Again this doesn't touch memory. */
        JITTER_TOP_MAINSTACK() = interpretation_result;
      }
  end
end

# FIXME: factor with the other call instructions.
instruction call-compiled (?n 0 1 2 3 4 5 6 7 8 9 10)
  caller
  code
    const jitter_uint in_arity = JITTER_ARGN0;
    jitterlisp_object callee = JITTER_AT_DEPTH_MAINSTACK(in_arity);
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(callee);

    /* Here we can assume that * c is a compiled closure without checking. */
    struct jitterlisp_compiled_closure *cc = & c->compiled;

    /* Make place for the return address in the return stack.  The
       actual value will be written by the callee. */
    JITTER_PUSH_UNSPECIFIED_RETURNSTACK();
//    JITTER_TOP_RETURNSTACK() = 0x4242aaaa; // FIXME: just a test.  Remove.

    /* Branch-and-link to the native code, whose first instruction
       will be a prolog. */
    JITTER_BRANCH_AND_LINK(cc->first_program_point);
  end
end

# FIXME: factor with the other call instructions.
instruction tail-call (?n 0 1 2 3 4 5 6 7 8 9 10)
  code
    const jitter_uint in_arity = JITTER_ARGN0;
    jitterlisp_object callee = JITTER_AT_DEPTH_MAINSTACK(in_arity);
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(callee);

    if (c->kind == jitterlisp_closure_type_compiled)
      {
        /* Extract the current return address from the return stack, to be
           reused.  Differently from non-tail calls, don't push anything on
           the return stack: the callee will overwrite the top with its
           current value, which is what we want. */
        jitterlispvm_program_point current_link
          = (jitterlispvm_program_point) JITTER_TOP_RETURNSTACK();

        /* Branch-and-relink to the native code, whose first instruction
           will be a prolog. */
        struct jitterlisp_compiled_closure *cc = & c->compiled;
        JITTER_BRANCH_AND_LINK_WITH(cc->first_program_point, current_link);
      }
    else
      {
        /* Unfortunately I cannot really tail-call from compiled code to
           interpreted code.  Instead I will call the interpreter as a C
           function and then return. */
        const struct jitterlisp_interpreted_closure *ic = & c->interpreted;

        /* Push an element on the main stack.  This way we can ensure that
           every actual is accessible thru memory in a contiguous array,
           even if the main stack is TOS-optimized.  Compute the address
           (on the main stack backing) where the actuals begin.

           Notice that the interpreted function we are calling is allowed
           to call into compiled code in its turn.  This is not a problem,
           as we are not moving stack pointers down until the call ends:
           the unused part of the main and return stacks is available to
           the callee. */
        JITTER_PUSH_UNSPECIFIED_MAINSTACK();
        jitterlisp_object *actuals
          // FIXME: add a stack operator to compute this address.
          = (& JITTER_UNDER_TOP_MAINSTACK()) - in_arity + 1;

        /* Call the interpreter. */
        jitterlisp_object interpretation_result
          = jitterlisp_call_interpreted (ic, actuals, in_arity);

        /* Remove as many elements as the in-arity plus one (the callee) from
           the stack, without affecting the top.  Unless JITTER_ARGN0 is
           residual this whole loops compiles to one instruction when the main
           stack is TOS-optimized, and doesn't touch memory. */
        int i;
        for (i = 0; i < in_arity + 1; i ++)
          JITTER_NIP_MAINSTACK();

        /* Now the stack is one element higher than it was before the call,
           containing the unspecified element at the top.  Replace it with
           the result.  Again this doesn't touch memory. */
        JITTER_TOP_MAINSTACK() = interpretation_result;

        /* Return to our original caller. */
        jitter_uint return_address = JITTER_TOP_RETURNSTACK();
        JITTER_DROP_RETURNSTACK();
        JITTER_RETURN(return_address);
      }
  end
end

# FIXME: factor with the other call instructions.
instruction tail-call-compiled (?n 0 1 2 3 4 5 6 7 8 9 10)
  #caller
  code
    const jitter_uint in_arity = JITTER_ARGN0;
    jitterlisp_object callee = JITTER_AT_DEPTH_MAINSTACK(in_arity);
    struct jitterlisp_closure *c = JITTERLISP_CLOSURE_DECODE(callee);

    /* Here we can assume that * c is a compiled closure without checking. */
    struct jitterlisp_compiled_closure *cc = & c->compiled;

    /* Take the current return address from the return stack: I want to keep
       returning there.  Differently from the case of non-tail calls I don't
       push anything on the return stack: the callee prolog will overwrite
       the current top with a copy of itself, which is fine. */
    jitterlispvm_program_point current_link
      = (jitterlispvm_program_point) JITTER_TOP_RETURNSTACK();

    /* Branch-and-relink to the native code, whose first instruction
       will be a prolog. */
    JITTER_BRANCH_AND_LINK_WITH(cc->first_program_point, current_link);
  end
end

instruction procedure-prolog ()
  callee
  code
    /* Fill the return stack slot with the return address.  The return
       stack has already been pushed (with an unspecified value on the
       top) by the caller. */
    JITTER_TOP_RETURNSTACK() = (jitterlisp_object) JITTER_LINK;
    //dump_stacks (0, the_jitter_state_runtime_pointer);
  end
end

instruction return ()
  code
    //dump_stacks (1, the_jitter_state_runtime_pointer);
    jitter_uint return_address = JITTER_TOP_RETURNSTACK();
    JITTER_DROP_RETURNSTACK();
    //dump_stacks (2, the_jitter_state_runtime_pointer);
    JITTER_RETURN(return_address);
    //dump_stacks (1, the_jitter_state_runtime_pointer);
  end
end

instruction save-register (?R)
  code
    JITTER_PUSH_RETURNSTACK(JITTER_ARG0);
  end
end

instruction restore-register (!R)
  code
    JITTER_ARG0 = JITTER_TOP_RETURNSTACK();
    JITTER_DROP_RETURNSTACK();
  end
end

instruction fail ()
  non-relocatable
  cold
  code
    jitterlisp_fail_from_vm ();
  end
end




## Optimization rewrites.
#################################################################

rule pop-to-register-push-register rewrite
  pop-to-register $a; push-register $b
into
  copy-to-register $a; copy-from-register $b
end
rule pop-to-register-push-literal rewrite
  pop-to-register $a; push-literal $b
into
  copy-to-register $a; copy-from-literal $b
end

rule push-literal-pop-to-register rewrite
  push-literal $a; pop-to-register $b
into
  literal-to-register $a, $b
end

rule drop-push-register rewrite
  drop; push-register $a
into
  copy-from-register $a
end
rule drop-push-literal rewrite
  drop; push-literal $a
into
  copy-from-literal $a
end
rule drop-push-unspecified rewrite
  drop; push-unspecified
into
  # Nothing.
end

rule push-register-pop-to-register rewrite
  push-register $a; pop-to-register $b
into
  register-to-register $a, $b
end

rule copy-from-register-pop-to-register rewrite
  copy-from-register $a; pop-to-register $b
into
  register-to-register $a, $b; drop
end

rule copy-from-literal-pop-to-register rewrite
  copy-from-literal $a; pop-to-register $b
into
  literal-to-register $a, $b; drop
end

rule push-register-push-register rewrite
  push-register $a; push-register $a
into
  push-register $a; dup
end

rule copy-from-register-push-register rewrite
  copy-from-register $a; push-register $a
into
  copy-from-register $a; dup
end

rule copy-to-register-and-push-the-same-register rewrite
  copy-to-register $a; push-register $a
into
  copy-to-register $a; dup
end

rule copy-to-and-from-the-same-register rewrite
  copy-to-register $a; copy-from-register $a
into
  copy-to-register $a
end

rule push-the-same-literal-twice rewrite
  push-literal $a; push-literal $a
into
  push-literal $a; dup
end

rule copy-from-literal-and-push-the-same-literal rewrite
  copy-from-literal $a; push-literal $a
into
  copy-from-literal $a; dup
end

# Remove the first instruction in a two-instruction sequence made of copy-from
# instructions.
rule copy-from-literal-then-from-another-literal rewrite
  copy-from-literal $a; copy-from-literal $b
into
  copy-from-literal $b
end
rule copy-from-literal-then-from-a-register rewrite
  copy-from-literal $a; copy-from-register $b
into
  copy-from-register $b
end
rule copy-from-a-register-then-from-literal rewrite
  copy-from-register $a; copy-from-literal $b
into
  copy-from-literal $b
end
rule copy-from-a-register-then-from-another-register rewrite
  copy-from-register $a; copy-from-register $b
into
  copy-from-register $b
end

# A copy-from instruction is useless when immediately followed by a drop.
rule useless-copy-from-literal-elimination rewrite
  copy-from-literal $a; drop
into
  drop
end
rule useless-copy-from-register-elimination rewrite
  copy-from-register $a; drop
into
  drop
end

rule push-register-drop rewrite
  push-register $a; drop
into
  # Nothing.
end
rule push-literal-drop rewrite
  push-literal $a; drop
into
  # Nothing.
end

rule pop-to-register-copy-from-register rewrite
  pop-to-register $a; copy-from-register $a
into
  copy-to-register $a; nip
end
rule pop-to-register-drop rewrite
  pop-to-register $a; drop
into
  nip; pop-to-register $a
end

rule pop-to-register-nip rewrite
  pop-to-register $a; nip
into
  copy-to-register $a; drop-nip
end

rule drop-nip rewrite
  drop; nip
into
  drop-nip
end

rule nip-drop rewrite
  nip; drop
into
  nip-drop
end

rule drop-drop rewrite
  drop; drop
into
  nip-drop
end

rule nip-drop-drop rewrite
  nip-drop; drop
into
  nip-two-drop
end
rule nip-two-drop-drop rewrite
  nip-two-drop; drop
into
  nip-three-drop
end
rule nip-three-drop-drop rewrite
  nip-three-drop; drop
into
  nip-four-drop
end
rule nip-four-drop-drop rewrite
  nip-four-drop; drop
into
  nip-five-drop
end
rule nip-five-drop-drop rewrite
  nip-five-drop; drop
into
  nip-six-drop
end

# Combine consecutive nip instructions into single instructions.  This
# implementation will become nicer and more general when Jitter rewrite rules
# become more expressive.
rule nip-nip rewrite
  nip; nip
into
  nip-two
end
rule nip-two-nip rewrite
  nip-two; nip
into
  nip-three
end
rule nip-three-nip rewrite
  nip-three; nip
into
  nip-four
end
rule nip-four-nip rewrite
  nip-four; nip
into
  nip-five
end
rule nip-five-nip rewrite
  nip-five; nip
into
  nip-six
end

# Move nip instructions before copy-from instructions.  This will make it
# easier to rewrite them into a single nip-multiple instruction.
rule nip-before-copy-from-register rewrite
  copy-from-register $a; nip
into
  nip; copy-from-register $a
end
rule nip-before-copy-from-literal rewrite
  copy-from-literal $a; nip
into
  nip; copy-from-literal $a
end

# Having copy-to-register at the end might make it possible to combine
# with some other instruction; nip is not easy to combine, except with
# other nips..
rule copy-to-register-nip rewrite
  copy-to-register $a; nip
into
  nip; copy-to-register $a
end

rule pop-to-register-return rewrite
  pop-to-register $a; return
into
  drop; return
end

rule copy-to-register-return rewrite
  copy-to-register $a; return
into
  return
end

# The AST rewriter takes care of removing most "not; branch-if-*" sequences,
# including every use of "not" as a condition and every use of
# "boolean-canonicalize" as a guard or condition; however
# "not; branch-if-true" sequnces remain as while guards, where the branch is
# always on a true condiion (I compile while loops as do..while, with the
# conditional branch at the end).  It's easier to optimize this pattern here
# than to add a special case to the compiler.
rule not-branch-if-true rewrite
  primitive-not; branch-if-true $b
into
  branch-if-false $b
end

rule nullp-branch-if-true rewrite
  primitive-nullp; branch-if-true $a
into
  branch-if-null $a
end
rule nullp-branch-if-false rewrite
  primitive-nullp; branch-if-false $a
into
  branch-if-not-null $a
end

rule non-nullp-branch-if-true rewrite
  primitive-non-nullp; branch-if-true $a
into
  branch-if-not-null $a
end
rule non-nullp-branch-if-false rewrite
  primitive-non-nullp; branch-if-false $a
into
  branch-if-null $a
end

# # Some save/restore pairs are easy to eliminate.
# # FIXME: no, this never fires because of the implicit label after the call,
# # which makes the sequence non-rewritable.  Do I really want this behavior?
# # I suspect not.  [FIXME: the behavior is no longer there.]
# rule rewrite
#   save-register $a; call $b; restore-register $a; primitive-primordial-plus $c; return
# into
#   call $b; primitive-primordial-plus $c; return
# end

# Some useless restore/save pairs come from compiling nested non-tail procedure calls.
# Notice that this fires multiple times with multiple nested pairs such as
#   restore-register %r1; restore-register %r0; save-register %r0; save-register %r1
# , until every pair has been eliminated.
rule restore-register-then-save-the-same-register rewrite
  restore-register $a; save-register $a
into
  # Nothing.
end


# # FIXME: this is a temporary kludge, to be used before I actually implement
# # tail calls.
# rule remove-tail-call--kludge rewrite
#   tail-call $a
# into
#   call $a; return
# end
# rule remove-tail-call-compiled--kludge rewrite
#   tail-call-compiled $a
# into
#   call-compiled $a; return
# end




## Scratch.
#################################################################

instruction branch-if-register-non-zero (?R, ?f, ?f)
  code
#if ! defined (JITTERLISP_UNSAFE)
    JITTERLISP_BRANCH_FAST_UNLESS_FIXNUM (JITTER_ARG0, JITTER_ARGF2);
#endif
    JITTER_BRANCH_FAST_IF_NOTEQUAL(JITTER_ARG0, JITTERLISP_FIXNUM_ENCODE(0),
                                   JITTER_ARGF1);
  end
end

rule scratch rewrite
  push-register $a; primitive-non-zerop $b; branch-if-true $c
into
  branch-if-register-non-zero $a, $c, $b
end

instruction branch-if-not-less (?f, ?f)
  code
    JITTERLISPVM_CHECK_TYPES_2(FIXNUM, FIXNUM, JITTER_ARGF1);
    jitterlisp_object undertop = JITTER_UNDER_TOP_MAINSTACK();
    jitterlisp_object top = JITTER_TOP_MAINSTACK();
    JITTER_NIP_MAINSTACK();
    JITTER_DROP_MAINSTACK();
    JITTER_BRANCH_FAST_IF_NOTLESS_SIGNED(undertop, top, JITTER_ARGF0);
  end
end
# FIXME: write more rules like this one.
# rule rewrite
#   primitive-lessp $a; branch-if-false $b
# into
#   branch-if-not-less $b, $a
# end

rule nip-drop-push-literal rewrite
  nip-drop; push-literal $a
into
  nip; copy-from-literal $a
end
rule nip-drop-push-register rewrite
  nip-drop; push-register $a
into
  nip; copy-from-register $a
end
rule nip-two-drop-push-literal rewrite
  nip-two-drop; push-literal $a
into
  nip-two; copy-from-literal $a
end
rule nip-two-drop-push-register rewrite
  nip-two-drop; push-register $a
into
  nip-two; copy-from-register $a
end
rule nip-three-drop-push-literal rewrite
  nip-three-drop; push-literal $a
into
  nip-three; copy-from-literal $a
end
rule nip-three-drop-push-register rewrite
  nip-three-drop; push-register $a
into
  nip-three; copy-from-register $a
end
rule nip-four-drop-push-literal  rewrite
  nip-four-drop; push-literal $a
into
  nip-four; copy-from-literal $a
end
rule nip-four-drop-push-register rewrite
  nip-four-drop; push-register $a
into
  nip-four; copy-from-register $a
end
rule nip-five-drop-push-literal rewrite
  nip-five-drop; push-literal $a
into
  nip-five; copy-from-literal $a
end
rule nip-five-drop-push-register rewrite
  nip-five-drop; push-register $a
into
  nip-five; copy-from-register $a
end
rule nip-six-drop-push-literal rewrite
  nip-six-drop; push-literal $a
into
  nip-six; copy-from-literal $a
end
rule nip-six-drop-push-register rewrite
  nip-six-drop; push-register $a
into
  nip-six; copy-from-register $a
end

# For these rule to fire the cons primitive use must be in a non-tail position,
# used as a non-last operand of a primitive or procedure.
# Testcases: alist-copy zip-reversed-iterative zip-reversed-tail-recursive-helper
#            zip-non-tail-recursive unzip-non-tail-recursive .
instruction nip-push-literal (?n)
  code
    JITTER_UNDER_TOP_MAINSTACK() = JITTER_TOP_MAINSTACK();
    JITTER_TOP_MAINSTACK() = JITTER_ARGN0;
  end
end
instruction nip-push-register (?R)
  code
    JITTER_UNDER_TOP_MAINSTACK() = JITTER_TOP_MAINSTACK();
    JITTER_TOP_MAINSTACK() = JITTER_ARG0;
  end
end
rule rewrite
  nip; push-literal $a
into
  nip-push-literal $a
end
rule rewrite
  nip; push-register $a
into
  nip-push-register $a
end

# Test case: (lambda () (while #t (cons 1 2)))
rule useless-cons-elimination rewrite
  heap-allocate $a; gc-if-needed $f; primitive-cons-special; nip-drop
into
  # Don't cons at all and drop the two cons operands as well, which will
  # hopefully rewrite further.  I don't generate just one nip-drop instruction
  # because the first rewritten drop might already rewrite along with its
  # previous instruction; and so may the second.
  drop; drop
end