Mercurial > hg > xemacs-beta

view src/bytecode.c @ 814:a634e3b7acc8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-04-14 12:41:59 by ben] latest changes TODO.ben-mule-21-5: Update. make-docfile.c: Add basic support for handling ISO 2022 doc strings -- we parse the basic charset designation sequences so we know whether we're in ASCII and have to pay attention to end quotes and such. Reformat code according to coding standards. abbrev.el: Add `global-abbrev-mode', which turns on or off abbrev-mode in all buffers. Added `defining-abbrev-turns-on-abbrev-mode' -- if non-nil, defining an abbrev through an interactive function will automatically turn on abbrev-mode, either globally or locally depending on the command. This is the "what you'd expect" behavior. indent.el: general function for indenting a balanced expression in a mode-correct way. Works similar to indent-region in that a mode can specify a specific command to do the whole operation; if not, figure out the region using forward-sexp and indent each line using indent-according-to-mode. keydefs.el: Removed. Modify M-C-backslash to do indent-region-or-balanced-expression. Make S-Tab just insert a TAB char, like it's meant to do. make-docfile.el: Now that we're using the call-process-in-lisp, we need to load an extra file win32-native.el because we're running a bare temacs. menubar-items.el: Totally redo the Cmds menu so that most used commands appear directly on the menu and less used commands appear in submenus. The old way may have been very pretty, but rather impractical. process.el: Under Windows, don't ever use old-call-process-internal, even in batch mode. We can do processes in batch mode. subr.el: Someone recoded truncate-string-to-width, saying "the FSF version is too complicated and does lots of hard-to-understand stuff" but the resulting recoded version was *totally* wrong! it misunderstood the basic point of this function, which is work in *columns* not chars. i dumped ours and copied the version from FSF 21.1. Also added truncate-string-with-continuation-dots, since this idiom is used often. config.inc.samp, xemacs.mak: Separate out debug and optimize flags. Remove all vestiges of USE_MINIMAL_TAGBITS, USE_INDEXED_LRECORD_IMPLEMENTATION, and GUNG_HO, since those ifdefs have long been removed. Make error-checking support actually work. Some rearrangement of config.inc.samp to make it more logical. Remove callproc.c and ntproc.c from xemacs.mak, no longer used. Make pdump the default. lisp.h: Add support for strong type-checking of Bytecount, Bytebpos, Charcount, Charbpos, and others, by making them classes, overloading the operators to provide integer-like operation and carefully controlling what operations are allowed. Not currently enabled in C++ builds because there are still a number of compile errors, and it won't really work till we merge in my "8-bit-Mule" workspace, in which I make use of the new types Charxpos, Bytexpos, Memxpos, representing a "position" either in a buffer or a string. (This is especially important in the extent code.) abbrev.c, alloc.c, eval.c, buffer.c, buffer.h, editfns.c, fns.c, text.h: Warning fixes, some of them related to new C++ strict type checking of Bytecount, Charbpos, etc. dired.c: Caught an actual error due to strong type checking -- char len being passed when should be byte len. alloc.c, backtrace.h, bytecode.c, bytecode.h, eval.c, sysdep.c: Further optimize Ffuncall: -- process arg list at compiled-function creation time, converting into an array for extra-quick access at funcall time. -- rewrite funcall_compiled_function to use it, and inline this function. -- change the order of check for magic stuff in SPECBIND_FAST_UNSAFE to be faster. -- move the check for need to garbage collect into the allocation code, so only a single flag needs to be checked in funcall. buffer.c, symbols.c: add debug funs to check on mule optimization info in buffers and strings. eval.c, emacs.c, text.c, regex.c, scrollbar-msw.c, search.c: Fix evil crashes due to eistrings not properly reinitialized under pdump. Redo a bit some of the init routines; convert some complex_vars_of() into simple vars_of(), because they didn't need complex processing. callproc.c, emacs.c, event-stream.c, nt.c, process.c, process.h, sysdep.c, sysdep.h, syssignal.h, syswindows.h, ntproc.c: Delete. Hallelujah, praise the Lord, there is no god but Allah!!! fix so that processes can be invoked in bare temacs -- thereby eliminating any need for callproc.c. (currently only eliminated under NT.) remove all crufty and unnecessary old process code in ntproc.c and elsewhere. move non-callproc-specific stuff (mostly environment) into process.c, so callproc.c can be left out under NT. console-tty.c, doc.c, file-coding.c, file-coding.h, lstream.c, lstream.h: fix doc string handling so it works with Japanese, etc docs. change handling of "character mode" so callers don't have to manually set it (quite error-prone). event-msw.c: spacing fixes. lread.c: eliminate unused crufty vintage-19 "FSF defun hack" code. lrecord.h: improve pdump description docs. buffer.c, ntheap.c, unexnt.c, win32.c, emacs.c: Mule-ize some unexec and startup code. It was pseudo-Mule-ized before by simply always calling the ...A versions of functions, but that won't cut it -- eventually we want to be able to run properly even if XEmacs has been installed in a Japanese directory. (The current problem is the timing of the loading of the Unicode tables; this will eventually be fixed.) Go through and fix various other places where the code was not Mule-clean. Provide a function mswindows_get_module_file_name() to get our own name without resort to PATH_MAX and such. Add a big comment in main() about the problem with Unicode table load timing that I just alluded to. emacs.c: When error-checking is enabled (interpreted as "user is developing XEmacs"), don't ask user to "pause to read messages" when a fatal error has occurred, because it will wedge if we are in an inner modal loop (typically when a menu is popped up) and make us unable to get a useful stack trace in the debugger. text.c: Correct update_entirely_ascii_p_flag to actually work. lisp.h, symsinit.h: declarations for above changes.
author ben
date Sun, 14 Apr 2002 12:43:31 +0000
parents 2b676dc88c66
children 6728e641994e
line wrap: on
line source

/* Execution of byte code produced by bytecomp.el.
   Implementation of compiled-function objects.
   Copyright (C) 1992, 1993 Free Software Foundation, Inc.
   Copyright (C) 1995, 2002 Ben Wing.

This file is part of XEmacs.

XEmacs 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, or (at your option) any
later version.

XEmacs 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 XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Synched up with: Mule 2.0, FSF 19.30. */

/* This file has been Mule-ized. */


/* Authorship:

   FSF: long ago.

hacked on by jwz@jwz.org 1991-06
  o  added a compile-time switch to turn on simple sanity checking;
  o  put back the obsolete byte-codes for error-detection;
  o  added a new instruction, unbind_all, which I will use for
     tail-recursion elimination;
  o  made temp_output_buffer_show be called with the right number
     of args;
  o  made the new bytecodes be called with args in the right order;
  o  added metering support.

by Hallvard:
  o  added relative jump instructions;
  o  all conditionals now only do QUIT if they jump.

   Ben Wing: some changes for Mule, 1995-06.

   Martin Buchholz: performance hacking, 1998-09.
   See Internals Manual, Evaluation.
 */

#include <config.h>
#include "lisp.h"
#include "backtrace.h"
#include "buffer.h"
#include "bytecode.h"
#include "opaque.h"
#include "syntax.h"

EXFUN (Ffetch_bytecode, 1);

Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;

enum Opcode /* Byte codes */
{
  Bvarref  		= 010,
  Bvarset  		= 020,
  Bvarbind 		= 030,
  Bcall    		= 040,
  Bunbind  		= 050,

  Bnth     		= 070,
  Bsymbolp 		= 071,
  Bconsp   		= 072,
  Bstringp 		= 073,
  Blistp   		= 074,
  Bold_eq  		= 075,
  Bold_memq 		= 076,
  Bnot    		= 077,
  Bcar    		= 0100,
  Bcdr 	  		= 0101,
  Bcons   		= 0102,
  Blist1  		= 0103,
  Blist2  		= 0104,
  Blist3  		= 0105,
  Blist4  		= 0106,
  Blength 		= 0107,
  Baref   		= 0110,
  Baset   		= 0111,
  Bsymbol_value 	= 0112,
  Bsymbol_function 	= 0113,
  Bset    		= 0114,
  Bfset   		= 0115,
  Bget    		= 0116,
  Bsubstring 		= 0117,
  Bconcat2 		= 0120,
  Bconcat3 		= 0121,
  Bconcat4 		= 0122,
  Bsub1 		= 0123,
  Badd1 		= 0124,
  Beqlsign 		= 0125,
  Bgtr 			= 0126,
  Blss 			= 0127,
  Bleq 			= 0130,
  Bgeq 			= 0131,
  Bdiff 		= 0132,
  Bnegate 		= 0133,
  Bplus 		= 0134,
  Bmax 			= 0135,
  Bmin 			= 0136,
  Bmult 		= 0137,

  Bpoint 		= 0140,
  Beq 			= 0141, /* was Bmark,
				   but no longer generated as of v18 */
  Bgoto_char 		= 0142,
  Binsert 		= 0143,
  Bpoint_max 		= 0144,
  Bpoint_min 		= 0145,
  Bchar_after 		= 0146,
  Bfollowing_char 	= 0147,
  Bpreceding_char 	= 0150,
  Bcurrent_column 	= 0151,
  Bindent_to 		= 0152,
  Bequal 		= 0153, /* was Bscan_buffer,
				   but no longer generated as of v18 */
  Beolp 		= 0154,
  Beobp 		= 0155,
  Bbolp 		= 0156,
  Bbobp 		= 0157,
  Bcurrent_buffer 	= 0160,
  Bset_buffer 		= 0161,
  Bsave_current_buffer 	= 0162, /* was Bread_char,
				   but no longer generated as of v19 */
  Bmemq 		= 0163, /* was Bset_mark,
				   but no longer generated as of v18 */
  Binteractive_p 	= 0164, /* Needed since interactive-p takes
				   unevalled args */
  Bforward_char 	= 0165,
  Bforward_word 	= 0166,
  Bskip_chars_forward 	= 0167,
  Bskip_chars_backward 	= 0170,
  Bforward_line 	= 0171,
  Bchar_syntax 		= 0172,
  Bbuffer_substring 	= 0173,
  Bdelete_region 	= 0174,
  Bnarrow_to_region 	= 0175,
  Bwiden 		= 0176,
  Bend_of_line 		= 0177,

  Bconstant2 		= 0201,
  Bgoto 		= 0202,
  Bgotoifnil 		= 0203,
  Bgotoifnonnil 	= 0204,
  Bgotoifnilelsepop 	= 0205,
  Bgotoifnonnilelsepop 	= 0206,
  Breturn 		= 0207,
  Bdiscard 		= 0210,
  Bdup 			= 0211,

  Bsave_excursion 	= 0212,
  Bsave_window_excursion= 0213,
  Bsave_restriction 	= 0214,
  Bcatch 		= 0215,

  Bunwind_protect 	= 0216,
  Bcondition_case 	= 0217,
  Btemp_output_buffer_setup = 0220,
  Btemp_output_buffer_show  = 0221,

  Bunbind_all 		= 0222,

  Bset_marker 		= 0223,
  Bmatch_beginning 	= 0224,
  Bmatch_end 		= 0225,
  Bupcase 		= 0226,
  Bdowncase 		= 0227,

  Bstring_equal 	= 0230,
  Bstring_lessp     	= 0231,
  Bold_equal 	 	= 0232,
  Bnthcdr 	 	= 0233,
  Belt 		 	= 0234,
  Bold_member 	 	= 0235,
  Bold_assq 	 	= 0236,
  Bnreverse 	 	= 0237,
  Bsetcar 	 	= 0240,
  Bsetcdr 	 	= 0241,
  Bcar_safe 	 	= 0242,
  Bcdr_safe 	 	= 0243,
  Bnconc 	 	= 0244,
  Bquo 		 	= 0245,
  Brem 		 	= 0246,
  Bnumberp 	 	= 0247,
  Bintegerp 	 	= 0250,

  BRgoto 		= 0252,
  BRgotoifnil 		= 0253,
  BRgotoifnonnil 	= 0254,
  BRgotoifnilelsepop 	= 0255,
  BRgotoifnonnilelsepop = 0256,

  BlistN 		= 0257,
  BconcatN 		= 0260,
  BinsertN 		= 0261,
  Bmember 		= 0266, /* new in v20 */
  Bassq 		= 0267, /* new in v20 */

  Bconstant 		= 0300
};
typedef enum Opcode Opcode;


Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
				   const Opbyte *program_ptr,
				   Opcode opcode);

/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
   This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
/* #define BYTE_CODE_METER */


#ifdef BYTE_CODE_METER

Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
int byte_metering_on;

static void
meter_code (Opcode prev_opcode, Opcode this_opcode)
{
  if (byte_metering_on)
    {
      Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
      p[0] = INT_PLUS1 (p[0]);
      if (prev_opcode)
	p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
    }
}

#endif /* BYTE_CODE_METER */


static Lisp_Object
bytecode_negate (Lisp_Object obj)
{
 retry:

  if (INTP    (obj)) return make_int (- XINT (obj));
#ifdef LISP_FLOAT_TYPE
  if (FLOATP  (obj)) return make_float (- XFLOAT_DATA (obj));
#endif
  if (CHARP   (obj)) return make_int (- ((int) XCHAR (obj)));
  if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));

  obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
  goto retry;
}

static Lisp_Object
bytecode_nreverse (Lisp_Object list)
{
  REGISTER Lisp_Object prev = Qnil;
  REGISTER Lisp_Object tail = list;

  while (!NILP (tail))
    {
      REGISTER Lisp_Object next;
      CHECK_CONS (tail);
      next = XCDR (tail);
      XCDR (tail) = prev;
      prev = tail;
      tail = next;
    }
  return prev;
}


/* We have our own two-argument versions of various arithmetic ops.
   Only two-argument arithmetic operations have their own byte codes. */
static int
bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
{
  retry:

#ifdef LISP_FLOAT_TYPE
  {
    EMACS_INT ival1, ival2;

    if      (INTP    (obj1)) ival1 = XINT  (obj1);
    else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
    else if (MARKERP (obj1)) ival1 = marker_position (obj1);
    else goto arithcompare_float;

    if      (INTP    (obj2)) ival2 = XINT  (obj2);
    else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
    else if (MARKERP (obj2)) ival2 = marker_position (obj2);
    else goto arithcompare_float;

    return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
  }

 arithcompare_float:

  {
    double dval1, dval2;

    if      (FLOATP  (obj1)) dval1 = XFLOAT_DATA (obj1);
    else if (INTP    (obj1)) dval1 = (double) XINT  (obj1);
    else if (CHARP   (obj1)) dval1 = (double) XCHAR (obj1);
    else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
    else
      {
	obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
	goto retry;
      }

    if      (FLOATP  (obj2)) dval2 = XFLOAT_DATA (obj2);
    else if (INTP    (obj2)) dval2 = (double) XINT  (obj2);
    else if (CHARP   (obj2)) dval2 = (double) XCHAR (obj2);
    else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
    else
      {
	obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
	goto retry;
      }

    return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
  }
#else /* !LISP_FLOAT_TYPE */
  {
    EMACS_INT ival1, ival2;

    if      (INTP    (obj1)) ival1 = XINT  (obj1);
    else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
    else if (MARKERP (obj1)) ival1 = marker_position (obj1);
    else
      {
	obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
	goto retry;
      }

    if      (INTP    (obj2)) ival2 = XINT  (obj2);
    else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
    else if (MARKERP (obj2)) ival2 = marker_position (obj2);
    else
      {
	obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
	goto retry;
      }

    return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
  }
#endif /* !LISP_FLOAT_TYPE */
}

static Lisp_Object
bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
{
#ifdef LISP_FLOAT_TYPE
  EMACS_INT ival1, ival2;
  int float_p;

 retry:

  float_p = 0;

  if      (INTP    (obj1)) ival1 = XINT  (obj1);
  else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
  else if (MARKERP (obj1)) ival1 = marker_position (obj1);
  else if (FLOATP  (obj1)) ival1 = 0, float_p = 1;
  else
    {
      obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
      goto retry;
    }

  if      (INTP    (obj2)) ival2 = XINT  (obj2);
  else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
  else if (MARKERP (obj2)) ival2 = marker_position (obj2);
  else if (FLOATP  (obj2)) ival2 = 0, float_p = 1;
  else
    {
      obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
      goto retry;
    }

  if (!float_p)
    {
      switch (opcode)
	{
	case Bplus: ival1 += ival2; break;
	case Bdiff: ival1 -= ival2; break;
	case Bmult: ival1 *= ival2; break;
	case Bquo:
	  if (ival2 == 0) Fsignal (Qarith_error, Qnil);
	  ival1 /= ival2;
	  break;
	case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
	case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
	}
      return make_int (ival1);
    }
  else
    {
      double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
      double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
      switch (opcode)
	{
	case Bplus: dval1 += dval2; break;
	case Bdiff: dval1 -= dval2; break;
	case Bmult: dval1 *= dval2; break;
	case Bquo:
	  if (dval2 == 0) Fsignal (Qarith_error, Qnil);
	  dval1 /= dval2;
	  break;
	case Bmax:  if (dval1 < dval2) dval1 = dval2; break;
	case Bmin:  if (dval1 > dval2) dval1 = dval2; break;
	}
      return make_float (dval1);
    }
#else /* !LISP_FLOAT_TYPE */
  EMACS_INT ival1, ival2;

 retry:

  if      (INTP    (obj1)) ival1 = XINT  (obj1);
  else if (CHARP   (obj1)) ival1 = XCHAR (obj1);
  else if (MARKERP (obj1)) ival1 = marker_position (obj1);
  else
    {
      obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
      goto retry;
    }

  if      (INTP    (obj2)) ival2 = XINT  (obj2);
  else if (CHARP   (obj2)) ival2 = XCHAR (obj2);
  else if (MARKERP (obj2)) ival2 = marker_position (obj2);
  else
    {
      obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
      goto retry;
    }

  switch (opcode)
    {
    case Bplus: ival1 += ival2; break;
    case Bdiff: ival1 -= ival2; break;
    case Bmult: ival1 *= ival2; break;
    case Bquo:
      if (ival2 == 0) Fsignal (Qarith_error, Qnil);
      ival1 /= ival2;
      break;
    case Bmax:  if (ival1 < ival2) ival1 = ival2; break;
    case Bmin:  if (ival1 > ival2) ival1 = ival2; break;
    }
  return make_int (ival1);
#endif /* !LISP_FLOAT_TYPE */
}


/* Read next uint8 from the instruction stream. */
#define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)

/* Read next uint16 from the instruction stream. */
#define READ_UINT_2						\
  (program_ptr += 2,						\
   (((unsigned int) (unsigned char) program_ptr[-1]) * 256 +	\
    ((unsigned int) (unsigned char) program_ptr[-2])))

/* Read next int8 from the instruction stream. */
#define READ_INT_1 ((int) (signed char) *program_ptr++)

/* Read next int16 from the instruction stream. */
#define READ_INT_2					\
  (program_ptr += 2,					\
   (((int) (  signed char) program_ptr[-1]) * 256 +	\
    ((int) (unsigned char) program_ptr[-2])))

/* Read next int8 from instruction stream; don't advance program_pointer */
#define PEEK_INT_1 ((int) (signed char) program_ptr[0])

/* Read next int16 from instruction stream; don't advance program_pointer */
#define PEEK_INT_2					\
  ((((int) (  signed char) program_ptr[1]) * 256) |	\
    ((int) (unsigned char) program_ptr[0]))

/* Do relative jumps from the current location.
   We only do a QUIT if we jump backwards, for efficiency.
   No infloops without backward jumps! */
#define JUMP_RELATIVE(jump) do {	\
  int JR_jump = (jump);			\
  if (JR_jump < 0) QUIT;		\
  program_ptr += JR_jump;		\
} while (0)

#define JUMP  JUMP_RELATIVE (PEEK_INT_2)
#define JUMPR JUMP_RELATIVE (PEEK_INT_1)

#define JUMP_NEXT  ((void) (program_ptr += 2))
#define JUMPR_NEXT ((void) (program_ptr += 1))

/* Push x onto the execution stack. */
#define PUSH(x) (*++stack_ptr = (x))

/* Pop a value off the execution stack. */
#define POP (*stack_ptr--)

/* Discard n values from the execution stack.  */
#define DISCARD(n) (stack_ptr -= (n))

/* Get the value which is at the top of the execution stack,
   but don't pop it. */
#define TOP (*stack_ptr)

/* The actual interpreter for byte code.
   This function has been seriously optimized for performance.
   Don't change the constructs unless you are willing to do
   real benchmarking and profiling work -- martin */


Lisp_Object
execute_optimized_program (const Opbyte *program,
			   int stack_depth,
			   Lisp_Object *constants_data)
{
  /* This function can GC */
  REGISTER const Opbyte *program_ptr = (Opbyte *) program;
  REGISTER Lisp_Object *stack_ptr
    = alloca_array (Lisp_Object, stack_depth + 1);
  int speccount = specpdl_depth ();
  struct gcpro gcpro1;

#ifdef BYTE_CODE_METER
  Opcode this_opcode = 0;
  Opcode prev_opcode;
#endif

#ifdef ERROR_CHECK_BYTE_CODE
  Lisp_Object *stack_beg = stack_ptr;
  Lisp_Object *stack_end = stack_beg + stack_depth;
#endif

  /* Initialize all the objects on the stack to Qnil,
     so we can GCPRO the whole stack.
     The first element of the stack is actually a dummy. */
  {
    int i;
    Lisp_Object *p;
    for (i = stack_depth, p = stack_ptr; i--;)
      *++p = Qnil;
  }

  GCPRO1 (stack_ptr[1]);
  gcpro1.nvars = stack_depth;

  while (1)
    {
      REGISTER Opcode opcode = (Opcode) READ_UINT_1;
#ifdef ERROR_CHECK_BYTE_CODE
      if (stack_ptr > stack_end)
	stack_overflow ("byte code stack overflow", Qunbound);
      if (stack_ptr < stack_beg)
	stack_overflow ("byte code stack underflow", Qunbound);
#endif

#ifdef BYTE_CODE_METER
      prev_opcode = this_opcode;
      this_opcode = opcode;
      meter_code (prev_opcode, this_opcode);
#endif

      switch (opcode)
	{
	  REGISTER int n;

	default:
	  if (opcode >= Bconstant)
	    PUSH (constants_data[opcode - Bconstant]);
	  else
	    stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
	  break;

	case Bvarref:
	case Bvarref+1:
	case Bvarref+2:
	case Bvarref+3:
	case Bvarref+4:
	case Bvarref+5: n = opcode - Bvarref; goto do_varref;
	case Bvarref+7: n = READ_UINT_2;      goto do_varref;
	case Bvarref+6: n = READ_UINT_1; /* most common */
	do_varref:
	{
	  Lisp_Object symbol = constants_data[n];
	  Lisp_Object value = XSYMBOL (symbol)->value;
	  if (SYMBOL_VALUE_MAGIC_P (value))
	    value = Fsymbol_value (symbol);
	  PUSH (value);
	  break;
	}

	case Bvarset:
	case Bvarset+1:
	case Bvarset+2:
	case Bvarset+3:
	case Bvarset+4:
	case Bvarset+5: n = opcode - Bvarset; goto do_varset;
	case Bvarset+7: n = READ_UINT_2;      goto do_varset;
	case Bvarset+6: n = READ_UINT_1; /* most common */
	do_varset:
	{
	  Lisp_Object symbol = constants_data[n];
	  Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
	  Lisp_Object old_value = symbol_ptr->value;
	  Lisp_Object new_value = POP;
	  if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
	    symbol_ptr->value = new_value;
	  else
	    Fset (symbol, new_value);
	  break;
	}

	case Bvarbind:
	case Bvarbind+1:
	case Bvarbind+2:
	case Bvarbind+3:
	case Bvarbind+4:
	case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
	case Bvarbind+7: n = READ_UINT_2;       goto do_varbind;
	case Bvarbind+6: n = READ_UINT_1; /* most common */
	do_varbind:
	{
	  Lisp_Object symbol = constants_data[n];
	  Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
	  Lisp_Object old_value = symbol_ptr->value;
	  Lisp_Object new_value = POP;
	  if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
	    {
	      specpdl_ptr->symbol    = symbol;
	      specpdl_ptr->old_value = old_value;
	      specpdl_ptr->func      = 0;
	      specpdl_ptr++;
	      specpdl_depth_counter++;

	      symbol_ptr->value = new_value;
	    }
	  else
	    specbind_magic (symbol, new_value);
	  break;
	}

	case Bcall:
	case Bcall+1:
	case Bcall+2:
	case Bcall+3:
	case Bcall+4:
	case Bcall+5:
	case Bcall+6:
	case Bcall+7:
	  n = (opcode <  Bcall+6 ? opcode - Bcall :
	       opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
	  DISCARD (n);
#ifdef BYTE_CODE_METER
	  if (byte_metering_on && SYMBOLP (TOP))
	    {
	      Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
	      if (INTP (val))
		Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
	    }
#endif
	  TOP = Ffuncall (n + 1, &TOP);
	  break;

	case Bunbind:
	case Bunbind+1:
	case Bunbind+2:
	case Bunbind+3:
	case Bunbind+4:
	case Bunbind+5:
	case Bunbind+6:
	case Bunbind+7:
	  UNBIND_TO (specpdl_depth() -
		     (opcode <  Bunbind+6 ? opcode-Bunbind :
		      opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
	  break;


	case Bgoto:
	  JUMP;
	  break;

	case Bgotoifnil:
	  if (NILP (POP))
	    JUMP;
	  else
	    JUMP_NEXT;
	  break;

	case Bgotoifnonnil:
	  if (!NILP (POP))
	    JUMP;
	  else
	    JUMP_NEXT;
	  break;

	case Bgotoifnilelsepop:
	  if (NILP (TOP))
	    JUMP;
	  else
	    {
	      DISCARD (1);
	      JUMP_NEXT;
	    }
	  break;

	case Bgotoifnonnilelsepop:
	  if (!NILP (TOP))
	    JUMP;
	  else
	    {
	      DISCARD (1);
	      JUMP_NEXT;
	    }
	  break;


	case BRgoto:
	  JUMPR;
	  break;

	case BRgotoifnil:
	  if (NILP (POP))
	    JUMPR;
	  else
	    JUMPR_NEXT;
	  break;

	case BRgotoifnonnil:
	  if (!NILP (POP))
	    JUMPR;
	  else
	    JUMPR_NEXT;
	  break;

	case BRgotoifnilelsepop:
	  if (NILP (TOP))
	    JUMPR;
	  else
	    {
	      DISCARD (1);
	      JUMPR_NEXT;
	    }
	  break;

	case BRgotoifnonnilelsepop:
	  if (!NILP (TOP))
	    JUMPR;
	  else
	    {
	      DISCARD (1);
	      JUMPR_NEXT;
	    }
	  break;

	case Breturn:
	  UNGCPRO;
#ifdef ERROR_CHECK_BYTE_CODE
	  /* Binds and unbinds are supposed to be compiled balanced.  */
	  if (specpdl_depth() != speccount)
	    invalid_byte_code ("unbalanced specbinding stack", Qunbound);
#endif
	  return TOP;

	case Bdiscard:
	  DISCARD (1);
	  break;

	case Bdup:
	  {
	    Lisp_Object arg = TOP;
	    PUSH (arg);
	    break;
	  }

	case Bconstant2:
	  PUSH (constants_data[READ_UINT_2]);
	  break;

	case Bcar:
	  TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
	  break;

	case Bcdr:
	  TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
	  break;


	case Bunbind_all:
	  /* To unbind back to the beginning of this frame.  Not used yet,
	     but will be needed for tail-recursion elimination. */
	  unbind_to (speccount);
	  break;

	case Bnth:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fcar (Fnthcdr (TOP, arg));
	    break;
	  }

	case Bsymbolp:
	  TOP = SYMBOLP (TOP) ? Qt : Qnil;
	  break;

	case Bconsp:
	  TOP = CONSP (TOP) ? Qt : Qnil;
	  break;

	case Bstringp:
	  TOP = STRINGP (TOP) ? Qt : Qnil;
	  break;

	case Blistp:
	  TOP = LISTP (TOP) ? Qt : Qnil;
	  break;

	case Bnumberp:
	  TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
	  break;

	case Bintegerp:
	  TOP = INTP (TOP) ? Qt : Qnil;
	  break;

	case Beq:
	  {
	    Lisp_Object arg = POP;
	    TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
	    break;
	  }

	case Bnot:
	  TOP = NILP (TOP) ? Qt : Qnil;
	  break;

	case Bcons:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fcons (TOP, arg);
	    break;
	  }

	case Blist1:
	  TOP = Fcons (TOP, Qnil);
	  break;


	case BlistN:
	  n = READ_UINT_1;
	  goto do_list;

	case Blist2:
	case Blist3:
	case Blist4:
	  /* common case */
	  n = opcode - (Blist1 - 1);
	do_list:
	  {
	    Lisp_Object list = Qnil;
	  list_loop:
	    list = Fcons (TOP, list);
	    if (--n)
	      {
		DISCARD (1);
		goto list_loop;
	      }
	    TOP = list;
	    break;
	  }


	case Bconcat2:
	case Bconcat3:
	case Bconcat4:
	  n = opcode - (Bconcat2 - 2);
	  goto do_concat;

	case BconcatN:
	  /* common case */
	  n = READ_UINT_1;
	do_concat:
	  DISCARD (n - 1);
	  TOP = Fconcat (n, &TOP);
	  break;


	case Blength:
	  TOP = Flength (TOP);
	  break;

	case Baset:
	  {
	    Lisp_Object arg2 = POP;
	    Lisp_Object arg1 = POP;
	    TOP = Faset (TOP, arg1, arg2);
	    break;
	  }

	case Bsymbol_value:
	  TOP = Fsymbol_value (TOP);
	  break;

	case Bsymbol_function:
	  TOP = Fsymbol_function (TOP);
	  break;

	case Bget:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fget (TOP, arg, Qnil);
	    break;
	  }

	case Bsub1:
	  TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
	  break;

	case Badd1:
	  TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
	  break;


	case Beqlsign:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
	    break;
	  }

	case Bgtr:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
	    break;
	  }

	case Blss:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
	    break;
	  }

	case Bleq:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
	    break;
	  }

	case Bgeq:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
	    break;
	  }


	case Bnegate:
	  TOP = bytecode_negate (TOP);
	  break;

	case Bnconc:
	  DISCARD (1);
	  TOP = bytecode_nconc2 (&TOP);
	  break;

	case Bplus:
	  {
	    Lisp_Object arg2 = POP;
	    Lisp_Object arg1 = TOP;
	    TOP = INTP (arg1) && INTP (arg2) ?
	      INT_PLUS (arg1, arg2) :
	      bytecode_arithop (arg1, arg2, opcode);
	    break;
	  }

	case Bdiff:
	  {
	    Lisp_Object arg2 = POP;
	    Lisp_Object arg1 = TOP;
	    TOP = INTP (arg1) && INTP (arg2) ?
	      INT_MINUS (arg1, arg2) :
	      bytecode_arithop (arg1, arg2, opcode);
	    break;
	  }

	case Bmult:
	case Bquo:
	case Bmax:
	case Bmin:
	  {
	    Lisp_Object arg = POP;
	    TOP = bytecode_arithop (TOP, arg, opcode);
	    break;
	  }

	case Bpoint:
	  PUSH (make_int (BUF_PT (current_buffer)));
	  break;

	case Binsert:
	  TOP = Finsert (1, &TOP);
	  break;

	case BinsertN:
	  n = READ_UINT_1;
	  DISCARD (n - 1);
	  TOP = Finsert (n, &TOP);
	  break;

	case Baref:
	  {
	    Lisp_Object arg = POP;
	    TOP = Faref (TOP, arg);
	    break;
	  }

	case Bmemq:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fmemq (TOP, arg);
	    break;
	  }

	case Bset:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fset (TOP, arg);
	    break;
	  }

	case Bequal:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fequal (TOP, arg);
	    break;
	  }

	case Bnthcdr:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fnthcdr (TOP, arg);
	    break;
	  }

	case Belt:
	  {
	    Lisp_Object arg = POP;
	    TOP = Felt (TOP, arg);
	    break;
	  }

	case Bmember:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fmember (TOP, arg);
	    break;
	  }

	case Bgoto_char:
	  TOP = Fgoto_char (TOP, Qnil);
	  break;

	case Bcurrent_buffer:
	  {
	    Lisp_Object buffer = wrap_buffer (current_buffer);

	    PUSH (buffer);
	    break;
	  }

	case Bset_buffer:
	  TOP = Fset_buffer (TOP);
	  break;

	case Bpoint_max:
	  PUSH (make_int (BUF_ZV (current_buffer)));
	  break;

	case Bpoint_min:
	  PUSH (make_int (BUF_BEGV (current_buffer)));
	  break;

	case Bskip_chars_forward:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fskip_chars_forward (TOP, arg, Qnil);
	    break;
	  }

	case Bassq:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fassq (TOP, arg);
	    break;
	  }

	case Bsetcar:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fsetcar (TOP, arg);
	    break;
	  }

	case Bsetcdr:
	  {
	    Lisp_Object arg = POP;
	    TOP = Fsetcdr (TOP, arg);
	    break;
	  }

	case Bnreverse:
	  TOP = bytecode_nreverse (TOP);
	  break;

	case Bcar_safe:
	  TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
	  break;

	case Bcdr_safe:
	  TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
	  break;

	}
    }
}

/* It makes a worthwhile performance difference (5%) to shunt
   lesser-used opcodes off to a subroutine, to keep the switch in
   execute_optimized_program small.  If you REALLY care about
   performance, you want to keep your heavily executed code away from
   rarely executed code, to minimize cache misses.

   Don't make this function static, since then the compiler might inline it. */
Lisp_Object *
execute_rare_opcode (Lisp_Object *stack_ptr,
		     const Opbyte *program_ptr,
		     Opcode opcode)
{
  switch (opcode)
    {

    case Bsave_excursion:
      record_unwind_protect (save_excursion_restore,
			     save_excursion_save ());
      break;

    case Bsave_window_excursion:
      {
	int count = specpdl_depth ();
	record_unwind_protect (save_window_excursion_unwind,
			       Fcurrent_window_configuration (Qnil));
	TOP = Fprogn (TOP);
	unbind_to (count);
	break;
      }

    case Bsave_restriction:
      record_unwind_protect (save_restriction_restore,
			     save_restriction_save ());
      break;

    case Bcatch:
      {
	Lisp_Object arg = POP;
	TOP = internal_catch (TOP, Feval, arg, 0);
	break;
      }

    case Bskip_chars_backward:
      {
	Lisp_Object arg = POP;
	TOP = Fskip_chars_backward (TOP, arg, Qnil);
	break;
      }

    case Bunwind_protect:
      record_unwind_protect (Fprogn, POP);
      break;

    case Bcondition_case:
      {
	Lisp_Object arg2 = POP; /* handlers */
	Lisp_Object arg1 = POP; /* bodyform */
	TOP = condition_case_3 (arg1, TOP, arg2);
	break;
      }

    case Bset_marker:
      {
	Lisp_Object arg2 = POP;
	Lisp_Object arg1 = POP;
	TOP = Fset_marker (TOP, arg1, arg2);
	break;
      }

    case Brem:
      {
	Lisp_Object arg = POP;
	TOP = Frem (TOP, arg);
	break;
      }

    case Bmatch_beginning:
      TOP = Fmatch_beginning (TOP);
      break;

    case Bmatch_end:
      TOP = Fmatch_end (TOP);
      break;

    case Bupcase:
      TOP = Fupcase (TOP, Qnil);
      break;

    case Bdowncase:
      TOP = Fdowncase (TOP, Qnil);
      break;

    case Bfset:
      {
	Lisp_Object arg = POP;
	TOP = Ffset (TOP, arg);
	break;
      }

    case Bstring_equal:
      {
	Lisp_Object arg = POP;
	TOP = Fstring_equal (TOP, arg);
	break;
      }

    case Bstring_lessp:
      {
	Lisp_Object arg = POP;
	TOP = Fstring_lessp (TOP, arg);
	break;
      }

    case Bsubstring:
      {
	Lisp_Object arg2 = POP;
	Lisp_Object arg1 = POP;
	TOP = Fsubstring (TOP, arg1, arg2);
	break;
      }

    case Bcurrent_column:
      PUSH (make_int (current_column (current_buffer)));
      break;

    case Bchar_after:
      TOP = Fchar_after (TOP, Qnil);
      break;

    case Bindent_to:
      TOP = Findent_to (TOP, Qnil, Qnil);
      break;

    case Bwiden:
      PUSH (Fwiden (Qnil));
      break;

    case Bfollowing_char:
      PUSH (Ffollowing_char (Qnil));
      break;

    case Bpreceding_char:
      PUSH (Fpreceding_char (Qnil));
      break;

    case Beolp:
      PUSH (Feolp (Qnil));
      break;

    case Beobp:
      PUSH (Feobp (Qnil));
      break;

    case Bbolp:
      PUSH (Fbolp (Qnil));
      break;

    case Bbobp:
      PUSH (Fbobp (Qnil));
      break;

    case Bsave_current_buffer:
      record_unwind_protect (save_current_buffer_restore,
			     Fcurrent_buffer ());
      break;

    case Binteractive_p:
      PUSH (Finteractive_p ());
      break;

    case Bforward_char:
      TOP = Fforward_char (TOP, Qnil);
      break;

    case Bforward_word:
      TOP = Fforward_word (TOP, Qnil);
      break;

    case Bforward_line:
      TOP = Fforward_line (TOP, Qnil);
      break;

    case Bchar_syntax:
      TOP = Fchar_syntax (TOP, Qnil);
      break;

    case Bbuffer_substring:
      {
	Lisp_Object arg = POP;
	TOP = Fbuffer_substring (TOP, arg, Qnil);
	break;
      }

    case Bdelete_region:
      {
	Lisp_Object arg = POP;
	TOP = Fdelete_region (TOP, arg, Qnil);
	break;
      }

    case Bnarrow_to_region:
      {
	Lisp_Object arg = POP;
	TOP = Fnarrow_to_region (TOP, arg, Qnil);
	break;
      }

    case Bend_of_line:
      TOP = Fend_of_line (TOP, Qnil);
      break;

    case Btemp_output_buffer_setup:
      temp_output_buffer_setup (TOP);
      TOP = Vstandard_output;
      break;

    case Btemp_output_buffer_show:
      {
	Lisp_Object arg = POP;
	temp_output_buffer_show (TOP, Qnil);
	TOP = arg;
	/* GAG ME!! */
	/* pop binding of standard-output */
	unbind_to (specpdl_depth() - 1);
	break;
      }

    case Bold_eq:
      {
	Lisp_Object arg = POP;
	TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
	break;
      }

    case Bold_memq:
      {
	Lisp_Object arg = POP;
	TOP = Fold_memq (TOP, arg);
	break;
      }

    case Bold_equal:
      {
	Lisp_Object arg = POP;
	TOP = Fold_equal (TOP, arg);
	break;
      }

    case Bold_member:
      {
	Lisp_Object arg = POP;
	TOP = Fold_member (TOP, arg);
	break;
      }

    case Bold_assq:
      {
	Lisp_Object arg = POP;
	TOP = Fold_assq (TOP, arg);
	break;
      }

    default:
      abort();
      break;
    }
  return stack_ptr;
}


DOESNT_RETURN
invalid_byte_code (const CIntbyte *reason, Lisp_Object frob)
{
  signal_error (Qinvalid_byte_code, reason, frob);
}

/* Check for valid opcodes.  Change this when adding new opcodes.  */
static void
check_opcode (Opcode opcode)
{
  if ((opcode < Bvarref) ||
      (opcode == 0251)   ||
      (opcode > Bassq && opcode < Bconstant))
    invalid_byte_code ("invalid opcode in instruction stream",
		       make_int (opcode));
}

/* Check that IDX is a valid offset into the `constants' vector */
static void
check_constants_index (int idx, Lisp_Object constants)
{
  if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
    signal_ferror
      (Qinvalid_byte_code,
       "reference %d to constants array out of range 0, %ld",
       idx, XVECTOR_LENGTH (constants) - 1);
}

/* Get next character from Lisp instructions string. */
#define READ_INSTRUCTION_CHAR(lvalue) do {				\
  (lvalue) = charptr_emchar (ptr);					\
  INC_CHARPTR (ptr);							\
  *icounts_ptr++ = program_ptr - program;				\
  if (lvalue > UCHAR_MAX)						\
    invalid_byte_code							\
      ("Invalid character in byte code string", make_char (lvalue));	\
} while (0)

/* Get opcode from Lisp instructions string. */
#define READ_OPCODE do {		\
  unsigned int c;			\
  READ_INSTRUCTION_CHAR (c);		\
  opcode = (Opcode) c;			\
} while (0)

/* Get next operand, a uint8, from Lisp instructions string. */
#define READ_OPERAND_1 do {		\
  READ_INSTRUCTION_CHAR (arg);		\
  argsize = 1;				\
} while (0)

/* Get next operand, a uint16, from Lisp instructions string. */
#define READ_OPERAND_2 do {		\
  unsigned int arg1, arg2;		\
  READ_INSTRUCTION_CHAR (arg1);		\
  READ_INSTRUCTION_CHAR (arg2);		\
  arg = arg1 + (arg2 << 8);		\
  argsize = 2;				\
} while (0)

/* Write 1 byte to PTR, incrementing PTR */
#define WRITE_INT8(value, ptr) do {	\
  *((ptr)++) = (value);			\
} while (0)

/* Write 2 bytes to PTR, incrementing PTR */
#define WRITE_INT16(value, ptr) do {			\
  WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr));	\
  WRITE_INT8 (((unsigned) (value)) >> 8    , (ptr));	\
} while (0)

/* We've changed our minds about the opcode we've already written. */
#define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))

/* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
#define WRITE_NARGS(base_opcode) do {		\
  if (arg <= 5)					\
    {						\
      REWRITE_OPCODE (base_opcode + arg);	\
    }						\
  else if (arg <= UCHAR_MAX)			\
    {						\
      REWRITE_OPCODE (base_opcode + 6);		\
      WRITE_INT8 (arg, program_ptr);		\
    }						\
  else						\
    {						\
      REWRITE_OPCODE (base_opcode + 7);		\
      WRITE_INT16 (arg, program_ptr);		\
    }						\
} while (0)

/* Encode a constants reference within the opcode, or as a 2-byte operand. */
#define WRITE_CONSTANT do {			\
  check_constants_index(arg, constants);	\
  if (arg <= UCHAR_MAX - Bconstant)		\
    {						\
      REWRITE_OPCODE (Bconstant + arg);		\
    }						\
  else						\
    {						\
      REWRITE_OPCODE (Bconstant2);		\
      WRITE_INT16 (arg, program_ptr);		\
    }						\
} while (0)

#define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)

/* Compile byte code instructions into free space provided by caller, with
   size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
   Returns length of compiled code. */
static void
optimize_byte_code (/* in */
		    Lisp_Object instructions,
		    Lisp_Object constants,
		    /* out */
		    Opbyte * const program,
		    int * const program_length,
		    int * const varbind_count)
{
  Bytecount instructions_length = XSTRING_LENGTH (instructions);
  Elemcount comfy_size = (Elemcount) (2 * instructions_length);

  int * const icounts = alloca_array (int, comfy_size);
  int * icounts_ptr = icounts;

  /* We maintain a table of jumps in the source code. */
  struct jump
  {
    int from;
    int to;
  };
  struct jump * const jumps = alloca_array (struct jump, comfy_size);
  struct jump *jumps_ptr = jumps;

  Opbyte *program_ptr = program;

  const Intbyte *ptr = XSTRING_DATA (instructions);
  const Intbyte * const end = ptr + instructions_length;

  *varbind_count = 0;

  while (ptr < end)
    {
      Opcode opcode;
      int arg;
      int argsize = 0;
      READ_OPCODE;
      WRITE_OPCODE;

      switch (opcode)
	{
	  Lisp_Object val;

	case Bvarref+7: READ_OPERAND_2; goto do_varref;
	case Bvarref+6: READ_OPERAND_1; goto do_varref;
	case Bvarref:   case Bvarref+1: case Bvarref+2:
	case Bvarref+3: case Bvarref+4: case Bvarref+5:
	  arg = opcode - Bvarref;
	do_varref:
	  check_constants_index (arg, constants);
	   val = XVECTOR_DATA (constants) [arg];
	   if (!SYMBOLP (val))
	     invalid_byte_code ("variable reference to non-symbol", val);
	   if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
	     invalid_byte_code ("variable reference to constant symbol", val);
	   WRITE_NARGS (Bvarref);
	   break;

	case Bvarset+7: READ_OPERAND_2; goto do_varset;
	case Bvarset+6: READ_OPERAND_1; goto do_varset;
	case Bvarset:   case Bvarset+1: case Bvarset+2:
	case Bvarset+3: case Bvarset+4: case Bvarset+5:
	  arg = opcode - Bvarset;
	do_varset:
	  check_constants_index (arg, constants);
	  val = XVECTOR_DATA (constants) [arg];
	  if (!SYMBOLP (val))
	    wtaerror ("attempt to set non-symbol", val);
	  if (EQ (val, Qnil) || EQ (val, Qt))
	    signal_error (Qsetting_constant, 0, val);
	  /* Ignore assignments to keywords by converting to Bdiscard.
	     For backward compatibility only - we'd like to make this an error.  */
	  if (SYMBOL_IS_KEYWORD (val))
	    REWRITE_OPCODE (Bdiscard);
	  else
	    WRITE_NARGS (Bvarset);
	  break;

	case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
	case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
	case Bvarbind:   case Bvarbind+1: case Bvarbind+2:
	case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
	  arg = opcode - Bvarbind;
	do_varbind:
	  (*varbind_count)++;
	  check_constants_index (arg, constants);
	  val = XVECTOR_DATA (constants) [arg];
	  if (!SYMBOLP (val))
	    wtaerror ("attempt to let-bind non-symbol", val);
	  if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
	    signal_error (Qsetting_constant,
			  "attempt to let-bind constant symbol", val);
	  WRITE_NARGS (Bvarbind);
	  break;

	case Bcall+7: READ_OPERAND_2; goto do_call;
	case Bcall+6: READ_OPERAND_1; goto do_call;
	case Bcall:   case Bcall+1: case Bcall+2:
	case Bcall+3: case Bcall+4: case Bcall+5:
	  arg = opcode - Bcall;
	do_call:
	  WRITE_NARGS (Bcall);
	  break;

	case Bunbind+7: READ_OPERAND_2; goto do_unbind;
	case Bunbind+6: READ_OPERAND_1; goto do_unbind;
	case Bunbind:   case Bunbind+1: case Bunbind+2:
	case Bunbind+3: case Bunbind+4: case Bunbind+5:
	  arg = opcode - Bunbind;
	do_unbind:
	  WRITE_NARGS (Bunbind);
	  break;

	case Bgoto:
	case Bgotoifnil:
	case Bgotoifnonnil:
	case Bgotoifnilelsepop:
	case Bgotoifnonnilelsepop:
	  READ_OPERAND_2;
	  /* Make program_ptr-relative */
	  arg += icounts - (icounts_ptr - argsize);
	  goto do_jump;

	case BRgoto:
	case BRgotoifnil:
	case BRgotoifnonnil:
	case BRgotoifnilelsepop:
	case BRgotoifnonnilelsepop:
	  READ_OPERAND_1;
	  /* Make program_ptr-relative */
	  arg -= 127;
	do_jump:
	  /* Record program-relative goto addresses in `jumps' table */
	  jumps_ptr->from = icounts_ptr - icounts - argsize;
	  jumps_ptr->to   = jumps_ptr->from + arg;
	  jumps_ptr++;
	  if (arg >= -1 && arg <= argsize)
	    invalid_byte_code ("goto instruction is its own target", Qunbound);
	  if (arg <= SCHAR_MIN ||
	      arg >  SCHAR_MAX)
	    {
	      if (argsize == 1)
		REWRITE_OPCODE (opcode + Bgoto - BRgoto);
	      WRITE_INT16 (arg, program_ptr);
	    }
	  else
	    {
	      if (argsize == 2)
		REWRITE_OPCODE (opcode + BRgoto - Bgoto);
	      WRITE_INT8 (arg, program_ptr);
	    }
	  break;

	case Bconstant2:
	  READ_OPERAND_2;
	  WRITE_CONSTANT;
	  break;

	case BlistN:
	case BconcatN:
	case BinsertN:
	  READ_OPERAND_1;
	  WRITE_INT8 (arg, program_ptr);
	  break;

	default:
	  if (opcode < Bconstant)
	    check_opcode (opcode);
	  else
	    {
	      arg = opcode - Bconstant;
	      WRITE_CONSTANT;
	    }
	  break;
	}
    }

  /* Fix up jumps table to refer to NEW offsets. */
  {
    struct jump *j;
    for (j = jumps; j < jumps_ptr; j++)
      {
#ifdef ERROR_CHECK_BYTE_CODE
	assert (j->from < icounts_ptr - icounts);
	assert (j->to   < icounts_ptr - icounts);
#endif
	j->from = icounts[j->from];
	j->to   = icounts[j->to];
#ifdef ERROR_CHECK_BYTE_CODE
	assert (j->from < program_ptr - program);
	assert (j->to   < program_ptr - program);
	check_opcode ((Opcode) (program[j->from-1]));
#endif
	check_opcode ((Opcode) (program[j->to]));
      }
  }

  /* Fixup jumps in byte-code until no more fixups needed */
  {
    int more_fixups_needed = 1;

    while (more_fixups_needed)
      {
	struct jump *j;
	more_fixups_needed = 0;
	for (j = jumps; j < jumps_ptr; j++)
	{
	  int from = j->from;
	  int to   = j->to;
	  int jump = to - from;
	  Opbyte *p = program + from;
	  Opcode opcode = (Opcode) p[-1];
	  if (!more_fixups_needed)
	    check_opcode ((Opcode) p[jump]);
	  assert (to >= 0 && program + to < program_ptr);
	  switch (opcode)
	    {
	      case Bgoto:
	      case Bgotoifnil:
	      case Bgotoifnonnil:
	      case Bgotoifnilelsepop:
	      case Bgotoifnonnilelsepop:
		WRITE_INT16 (jump, p);
		break;

	      case BRgoto:
	      case BRgotoifnil:
	      case BRgotoifnonnil:
	      case BRgotoifnilelsepop:
	      case BRgotoifnonnilelsepop:
		if (jump >  SCHAR_MIN &&
		    jump <= SCHAR_MAX)
		  {
		    WRITE_INT8 (jump, p);
		  }
		else		/* barf */
		  {
		    struct jump *jj;
		    for (jj = jumps; jj < jumps_ptr; jj++)
		      {
			assert (jj->from < program_ptr - program);
			assert (jj->to   < program_ptr - program);
			if (jj->from > from) jj->from++;
			if (jj->to   > from) jj->to++;
		      }
		    p[-1] += Bgoto - BRgoto;
		    more_fixups_needed = 1;
		    memmove (p+1, p, program_ptr++ - p);
		    WRITE_INT16 (jump, p);
		  }
		break;

	    default:
	      abort();
	      break;
	    }
	}
      }
  }

  /* *program_ptr++ = 0; */
  *program_length = program_ptr - program;
}

/* Optimize the byte code and store the optimized program, only
   understood by bytecode.c, in an opaque object in the
   instructions slot of the Compiled_Function object. */
void
optimize_compiled_function (Lisp_Object compiled_function)
{
  Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
  int program_length;
  int varbind_count;
  Opbyte *program;

  /* If we have not actually read the bytecode string
     and constants vector yet, fetch them from the file.  */
  if (CONSP (f->instructions))
    Ffetch_bytecode (compiled_function);

  if (STRINGP (f->instructions))
    {
      /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
	 which would be slightly more `proper' */
      program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
      optimize_byte_code (f->instructions, f->constants,
			  program, &program_length, &varbind_count);
      f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
      f->instructions =
	make_opaque (program, program_length * sizeof (Opbyte));
    }

  assert (OPAQUEP (f->instructions));
}

/************************************************************************/
/*		The compiled-function object type			*/
/************************************************************************/
static void
print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
			 int escapeflag)
{
  /* This function can GC */
  Lisp_Compiled_Function *f =
    XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
  int docp = f->flags.documentationp;
  int intp = f->flags.interactivep;
  struct gcpro gcpro1, gcpro2;
  GCPRO2 (obj, printcharfun);

  write_c_string (print_readably ? "#[" : "#<compiled-function ", printcharfun);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
  if (!print_readably)
    {
      Lisp_Object ann = compiled_function_annotation (f);
      if (!NILP (ann))
	write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann);
    }
#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
  /* COMPILED_ARGLIST = 0 */
  print_internal (compiled_function_arglist (f), printcharfun, escapeflag);

  /* COMPILED_INSTRUCTIONS = 1 */
  write_c_string (" ", printcharfun);
  {
    struct gcpro ngcpro1;
    Lisp_Object instructions = compiled_function_instructions (f);
    NGCPRO1 (instructions);
    if (STRINGP (instructions) && !print_readably)
      {
	/* We don't usually want to see that junk in the bytecode. */
	write_fmt_string (printcharfun, "\"...(%ld)\"",
			  (long) XSTRING_CHAR_LENGTH (instructions));
      }
    else
      print_internal (instructions, printcharfun, escapeflag);
    NUNGCPRO;
  }

  /* COMPILED_CONSTANTS = 2 */
  write_c_string (" ", printcharfun);
  print_internal (compiled_function_constants (f), printcharfun, escapeflag);

  /* COMPILED_STACK_DEPTH = 3 */
  write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f));

  /* COMPILED_DOC_STRING = 4 */
  if (docp || intp)
    {
      write_c_string (" ", printcharfun);
      print_internal (compiled_function_documentation (f), printcharfun,
		      escapeflag);
    }

  /* COMPILED_INTERACTIVE = 5 */
  if (intp)
    {
      write_c_string (" ", printcharfun);
      print_internal (compiled_function_interactive (f), printcharfun,
		      escapeflag);
    }

  UNGCPRO;
  write_c_string (print_readably ? "]" : ">", printcharfun);
}


static Lisp_Object
mark_compiled_function (Lisp_Object obj)
{
  Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
  int i;

  mark_object (f->instructions);
  mark_object (f->arglist);
  mark_object (f->doc_and_interactive);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
  mark_object (f->annotated);
#endif
  for (i = 0; i < f->args_in_array; i++)
    mark_object (f->args[i]);

  /* tail-recurse on constants */
  return f->constants;
}

static int
compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
  Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
  Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
  return
    (f1->flags.documentationp == f2->flags.documentationp &&
     f1->flags.interactivep   == f2->flags.interactivep   &&
     f1->flags.domainp        == f2->flags.domainp        && /* I18N3 */
     internal_equal (compiled_function_instructions (f1),
		     compiled_function_instructions (f2), depth + 1) &&
     internal_equal (f1->constants,    f2->constants,    depth + 1) &&
     internal_equal (f1->arglist,      f2->arglist,      depth + 1) &&
     internal_equal (f1->doc_and_interactive,
		     f2->doc_and_interactive, depth + 1));
}

static Hashcode
compiled_function_hash (Lisp_Object obj, int depth)
{
  Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
  return HASH3 ((f->flags.documentationp << 2) +
		(f->flags.interactivep << 1) +
		f->flags.domainp,
		internal_hash (f->instructions, depth + 1),
		internal_hash (f->constants,    depth + 1));
}

static const struct lrecord_description lo_description_1[] = {
  { XD_LISP_OBJECT, 0 },
  { XD_END }
};

static const struct struct_description lo_description = {
  sizeof (Lisp_Object),
  lo_description_1
};

static const struct lrecord_description compiled_function_description[] = {
  { XD_INT,         offsetof (Lisp_Compiled_Function, args_in_array) },
  { XD_STRUCT_PTR,  offsetof (Lisp_Compiled_Function, args),
      XD_INDIRECT (0, 0), &lo_description },
  { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
  { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
  { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
  { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
  { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
#endif
  { XD_END }
};

DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
				     mark_compiled_function,
				     print_compiled_function, 0,
				     compiled_function_equal,
				     compiled_function_hash,
				     compiled_function_description,
				     Lisp_Compiled_Function);

DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
Return t if OBJECT is a byte-compiled function object.
*/
       (object))
{
  return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
}

/************************************************************************/
/*		compiled-function object accessor functions		*/
/************************************************************************/

Lisp_Object
compiled_function_arglist (Lisp_Compiled_Function *f)
{
  return f->arglist;
}

Lisp_Object
compiled_function_instructions (Lisp_Compiled_Function *f)
{
  if (! OPAQUEP (f->instructions))
    return f->instructions;

  {
    /* Invert action performed by optimize_byte_code() */
    Lisp_Opaque *opaque = XOPAQUE (f->instructions);

    Intbyte * const buffer =
      alloca_array (Intbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN);
    Intbyte *bp = buffer;

    const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
    const Opbyte *program_ptr = program;
    const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);

    while (program_ptr < program_end)
      {
	Opcode opcode = (Opcode) READ_UINT_1;
	bp += set_charptr_emchar (bp, opcode);
	switch (opcode)
	  {
	  case Bvarref+7:
	  case Bvarset+7:
	  case Bvarbind+7:
	  case Bcall+7:
	  case Bunbind+7:
	  case Bconstant2:
	    bp += set_charptr_emchar (bp, READ_UINT_1);
	    bp += set_charptr_emchar (bp, READ_UINT_1);
	    break;

	  case Bvarref+6:
	  case Bvarset+6:
	  case Bvarbind+6:
	  case Bcall+6:
	  case Bunbind+6:
	  case BlistN:
	  case BconcatN:
	  case BinsertN:
	    bp += set_charptr_emchar (bp, READ_UINT_1);
	    break;

	  case Bgoto:
	  case Bgotoifnil:
	  case Bgotoifnonnil:
	  case Bgotoifnilelsepop:
	  case Bgotoifnonnilelsepop:
	    {
	      int jump = READ_INT_2;
	      Opbyte buf2[2];
	      Opbyte *buf2p = buf2;
	      /* Convert back to program-relative address */
	      WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
	      bp += set_charptr_emchar (bp, buf2[0]);
	      bp += set_charptr_emchar (bp, buf2[1]);
	      break;
	    }

	  case BRgoto:
	  case BRgotoifnil:
	  case BRgotoifnonnil:
	  case BRgotoifnilelsepop:
	  case BRgotoifnonnilelsepop:
	    bp += set_charptr_emchar (bp, READ_INT_1 + 127);
	    break;

	  default:
	    break;
	  }
      }
    return make_string (buffer, bp - buffer);
  }
}

Lisp_Object
compiled_function_constants (Lisp_Compiled_Function *f)
{
  return f->constants;
}

int
compiled_function_stack_depth (Lisp_Compiled_Function *f)
{
  return f->stack_depth;
}

/* The compiled_function->doc_and_interactive slot uses the minimal
   number of conses, based on compiled_function->flags; it may take
   any of the following forms:

	doc
	interactive
	domain
	(doc . interactive)
	(doc . domain)
	(interactive . domain)
	(doc . (interactive . domain))
 */

/* Caller must check flags.interactivep first */
Lisp_Object
compiled_function_interactive (Lisp_Compiled_Function *f)
{
  assert (f->flags.interactivep);
  if (f->flags.documentationp && f->flags.domainp)
    return XCAR (XCDR (f->doc_and_interactive));
  else if (f->flags.documentationp)
    return XCDR (f->doc_and_interactive);
  else if (f->flags.domainp)
    return XCAR (f->doc_and_interactive);
  else
    return f->doc_and_interactive;
}

/* Caller need not check flags.documentationp first */
Lisp_Object
compiled_function_documentation (Lisp_Compiled_Function *f)
{
  if (! f->flags.documentationp)
    return Qnil;
  else if (f->flags.interactivep && f->flags.domainp)
    return XCAR (f->doc_and_interactive);
  else if (f->flags.interactivep)
    return XCAR (f->doc_and_interactive);
  else if (f->flags.domainp)
    return XCAR (f->doc_and_interactive);
  else
    return f->doc_and_interactive;
}

/* Caller need not check flags.domainp first */
Lisp_Object
compiled_function_domain (Lisp_Compiled_Function *f)
{
  if (! f->flags.domainp)
    return Qnil;
  else if (f->flags.documentationp && f->flags.interactivep)
    return XCDR (XCDR (f->doc_and_interactive));
  else if (f->flags.documentationp)
    return XCDR (f->doc_and_interactive);
  else if (f->flags.interactivep)
    return XCDR (f->doc_and_interactive);
  else
    return f->doc_and_interactive;
}

#ifdef COMPILED_FUNCTION_ANNOTATION_HACK

Lisp_Object
compiled_function_annotation (Lisp_Compiled_Function *f)
{
  return f->annotated;
}

#endif

/* used only by Snarf-documentation; there must be doc already. */
void
set_compiled_function_documentation (Lisp_Compiled_Function *f,
				     Lisp_Object new_doc)
{
  assert (f->flags.documentationp);
  assert (INTP (new_doc) || STRINGP (new_doc));

  if (f->flags.interactivep && f->flags.domainp)
    XCAR (f->doc_and_interactive) = new_doc;
  else if (f->flags.interactivep)
    XCAR (f->doc_and_interactive) = new_doc;
  else if (f->flags.domainp)
    XCAR (f->doc_and_interactive) = new_doc;
  else
    f->doc_and_interactive = new_doc;
}


DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
Return the argument list of the compiled-function object FUNCTION.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return compiled_function_arglist (XCOMPILED_FUNCTION (function));
}

DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
Return the byte-opcode string of the compiled-function object FUNCTION.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return compiled_function_instructions (XCOMPILED_FUNCTION (function));
}

DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
Return the constants vector of the compiled-function object FUNCTION.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return compiled_function_constants (XCOMPILED_FUNCTION (function));
}

DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
Return the maximum stack depth of the compiled-function object FUNCTION.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
}

DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
Return the doc string of the compiled-function object FUNCTION, if available.
Functions that had their doc strings snarfed into the DOC file will have
an integer returned instead of a string.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return compiled_function_documentation (XCOMPILED_FUNCTION (function));
}

DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
Return the interactive spec of the compiled-function object FUNCTION, or nil.
If non-nil, the return value will be a list whose first element is
`interactive' and whose second element is the interactive spec.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return XCOMPILED_FUNCTION (function)->flags.interactivep
    ? list2 (Qinteractive,
	     compiled_function_interactive (XCOMPILED_FUNCTION (function)))
    : Qnil;
}

#ifdef COMPILED_FUNCTION_ANNOTATION_HACK

/* Remove the `xx' if you wish to restore this feature */
xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
Return the annotation of the compiled-function object FUNCTION, or nil.
The annotation is a piece of information indicating where this
compiled-function object came from.  Generally this will be
a symbol naming a function; or a string naming a file, if the
compiled-function object was not defined in a function; or nil,
if the compiled-function object was not created as a result of
a `load'.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return compiled_function_annotation (XCOMPILED_FUNCTION (function));
}

#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */

DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
Return the domain of the compiled-function object FUNCTION, or nil.
This is only meaningful if I18N3 was enabled when emacs was compiled.
*/
       (function))
{
  CHECK_COMPILED_FUNCTION (function);
  return XCOMPILED_FUNCTION (function)->flags.domainp
    ? compiled_function_domain (XCOMPILED_FUNCTION (function))
    : Qnil;
}



DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
*/
       (function))
{
  Lisp_Compiled_Function *f;
  CHECK_COMPILED_FUNCTION (function);
  f = XCOMPILED_FUNCTION (function);

  if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
    return function;

  if (CONSP (f->instructions))
    {
      Lisp_Object tem = read_doc_string (f->instructions);
      if (!CONSP (tem))
	signal_error (Qinvalid_byte_code,
			   "Invalid lazy-loaded byte code", tem);
      /* v18 or v19 bytecode file.  Need to Ebolify. */
      if (f->flags.ebolified && VECTORP (XCDR (tem)))
	ebolify_bytecode_constants (XCDR (tem));
      f->instructions = XCAR (tem);
      f->constants    = XCDR (tem);
      return function;
    }
  abort ();
  return Qnil; /* not (usually) reached */
}

DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
Convert compiled function FUNCTION into an optimized internal form.
*/
       (function))
{
  Lisp_Compiled_Function *f;
  CHECK_COMPILED_FUNCTION (function);
  f = XCOMPILED_FUNCTION (function);

  if (OPAQUEP (f->instructions)) /* Already optimized? */
    return Qnil;

  optimize_compiled_function (function);
  return Qnil;
}

DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
Function used internally in byte-compiled code.
First argument INSTRUCTIONS is a string of byte code.
Second argument CONSTANTS is a vector of constants.
Third argument STACK-DEPTH is the maximum stack depth used in this function.
If STACK-DEPTH is incorrect, Emacs may crash.
*/
       (instructions, constants, stack_depth))
{
  /* This function can GC */
  int varbind_count;
  int program_length;
  Opbyte *program;

  CHECK_STRING (instructions);
  CHECK_VECTOR (constants);
  CHECK_NATNUM (stack_depth);

  /* Optimize the `instructions' string, just like when executing a
     regular compiled function, but don't save it for later since this is
     likely to only be executed once. */
  program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
  optimize_byte_code (instructions, constants, program,
		      &program_length, &varbind_count);
  SPECPDL_RESERVE (varbind_count);
  return execute_optimized_program (program,
				    XINT (stack_depth),
				    XVECTOR_DATA (constants));
}


void
syms_of_bytecode (void)
{
  INIT_LRECORD_IMPLEMENTATION (compiled_function);

  DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
  DEFSYMBOL (Qbyte_code);
  DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp);

  DEFSUBR (Fbyte_code);
  DEFSUBR (Ffetch_bytecode);
  DEFSUBR (Foptimize_compiled_function);

  DEFSUBR (Fcompiled_function_p);
  DEFSUBR (Fcompiled_function_instructions);
  DEFSUBR (Fcompiled_function_constants);
  DEFSUBR (Fcompiled_function_stack_depth);
  DEFSUBR (Fcompiled_function_arglist);
  DEFSUBR (Fcompiled_function_interactive);
  DEFSUBR (Fcompiled_function_doc_string);
  DEFSUBR (Fcompiled_function_domain);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
  DEFSUBR (Fcompiled_function_annotation);
#endif

#ifdef BYTE_CODE_METER
  DEFSYMBOL (Qbyte_code_meter);
#endif
}

void
vars_of_bytecode (void)
{
#ifdef BYTE_CODE_METER

  DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
A vector of vectors which holds a histogram of byte code usage.
\(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
opcode CODE has been executed.
\(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
indicates how many times the byte opcodes CODE1 and CODE2 have been
executed in succession.
*/ );
  DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
If non-nil, keep profiling information on byte code usage.
The variable `byte-code-meter' indicates how often each byte opcode is used.
If a symbol has a property named `byte-code-meter' whose value is an
integer, it is incremented each time that symbol's function is called.
*/ );

  byte_metering_on = 0;
  Vbyte_code_meter = make_vector (256, Qzero);
  {
    int i = 256;
    while (i--)
      XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
  }
#endif /* BYTE_CODE_METER */
}