428
+ − 1 /* Execution of byte code produced by bytecomp.el.
+ − 2 Implementation of compiled-function objects.
+ − 3 Copyright (C) 1992, 1993 Free Software Foundation, Inc.
814
+ − 4 Copyright (C) 1995, 2002 Ben Wing.
428
+ − 5
+ − 6 This file is part of XEmacs.
+ − 7
+ − 8 XEmacs is free software; you can redistribute it and/or modify it
+ − 9 under the terms of the GNU General Public License as published by the
+ − 10 Free Software Foundation; either version 2, or (at your option) any
+ − 11 later version.
+ − 12
+ − 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
+ − 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ − 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ − 16 for more details.
+ − 17
+ − 18 You should have received a copy of the GNU General Public License
+ − 19 along with XEmacs; see the file COPYING. If not, write to
+ − 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ − 21 Boston, MA 02111-1307, USA. */
+ − 22
+ − 23 /* Synched up with: Mule 2.0, FSF 19.30. */
+ − 24
+ − 25 /* This file has been Mule-ized. */
+ − 26
+ − 27
+ − 28 /* Authorship:
+ − 29
+ − 30 FSF: long ago.
+ − 31
+ − 32 hacked on by jwz@jwz.org 1991-06
+ − 33 o added a compile-time switch to turn on simple sanity checking;
+ − 34 o put back the obsolete byte-codes for error-detection;
+ − 35 o added a new instruction, unbind_all, which I will use for
+ − 36 tail-recursion elimination;
+ − 37 o made temp_output_buffer_show be called with the right number
+ − 38 of args;
+ − 39 o made the new bytecodes be called with args in the right order;
+ − 40 o added metering support.
+ − 41
+ − 42 by Hallvard:
+ − 43 o added relative jump instructions;
+ − 44 o all conditionals now only do QUIT if they jump.
+ − 45
+ − 46 Ben Wing: some changes for Mule, 1995-06.
+ − 47
+ − 48 Martin Buchholz: performance hacking, 1998-09.
+ − 49 See Internals Manual, Evaluation.
+ − 50 */
+ − 51
+ − 52 #include <config.h>
+ − 53 #include "lisp.h"
+ − 54 #include "backtrace.h"
+ − 55 #include "buffer.h"
+ − 56 #include "bytecode.h"
+ − 57 #include "opaque.h"
+ − 58 #include "syntax.h"
872
+ − 59 #include "window.h"
428
+ − 60
3092
+ − 61 #ifdef NEW_GC
+ − 62 static Lisp_Object
+ − 63 make_compiled_function_args (int totalargs)
+ − 64 {
+ − 65 Lisp_Compiled_Function_Args *args;
+ − 66 args = (Lisp_Compiled_Function_Args *)
+ − 67 alloc_lrecord
+ − 68 (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args,
+ − 69 Lisp_Object, args, totalargs),
+ − 70 &lrecord_compiled_function_args);
+ − 71 args->size = totalargs;
+ − 72 return wrap_compiled_function_args (args);
+ − 73 }
+ − 74
+ − 75 static Bytecount
+ − 76 size_compiled_function_args (const void *lheader)
+ − 77 {
+ − 78 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args,
+ − 79 Lisp_Object, args,
+ − 80 ((Lisp_Compiled_Function_Args *)
+ − 81 lheader)->size);
+ − 82 }
+ − 83
+ − 84 static const struct memory_description compiled_function_args_description[] = {
+ − 85 { XD_LONG, offsetof (Lisp_Compiled_Function_Args, size) },
+ − 86 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Compiled_Function_Args, args),
+ − 87 XD_INDIRECT(0, 0) },
+ − 88 { XD_END }
+ − 89 };
+ − 90
+ − 91 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("compiled-function-args",
+ − 92 compiled_function_args,
+ − 93 1, /*dumpable-flag*/
+ − 94 0, 0, 0, 0, 0,
+ − 95 compiled_function_args_description,
+ − 96 size_compiled_function_args,
+ − 97 Lisp_Compiled_Function_Args);
+ − 98 #endif /* NEW_GC */
+ − 99
428
+ − 100 EXFUN (Ffetch_bytecode, 1);
+ − 101
+ − 102 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
+ − 103
+ − 104 enum Opcode /* Byte codes */
+ − 105 {
+ − 106 Bvarref = 010,
+ − 107 Bvarset = 020,
+ − 108 Bvarbind = 030,
+ − 109 Bcall = 040,
+ − 110 Bunbind = 050,
+ − 111
+ − 112 Bnth = 070,
+ − 113 Bsymbolp = 071,
+ − 114 Bconsp = 072,
+ − 115 Bstringp = 073,
+ − 116 Blistp = 074,
+ − 117 Bold_eq = 075,
+ − 118 Bold_memq = 076,
+ − 119 Bnot = 077,
+ − 120 Bcar = 0100,
+ − 121 Bcdr = 0101,
+ − 122 Bcons = 0102,
+ − 123 Blist1 = 0103,
+ − 124 Blist2 = 0104,
+ − 125 Blist3 = 0105,
+ − 126 Blist4 = 0106,
+ − 127 Blength = 0107,
+ − 128 Baref = 0110,
+ − 129 Baset = 0111,
+ − 130 Bsymbol_value = 0112,
+ − 131 Bsymbol_function = 0113,
+ − 132 Bset = 0114,
+ − 133 Bfset = 0115,
+ − 134 Bget = 0116,
+ − 135 Bsubstring = 0117,
+ − 136 Bconcat2 = 0120,
+ − 137 Bconcat3 = 0121,
+ − 138 Bconcat4 = 0122,
+ − 139 Bsub1 = 0123,
+ − 140 Badd1 = 0124,
+ − 141 Beqlsign = 0125,
+ − 142 Bgtr = 0126,
+ − 143 Blss = 0127,
+ − 144 Bleq = 0130,
+ − 145 Bgeq = 0131,
+ − 146 Bdiff = 0132,
+ − 147 Bnegate = 0133,
+ − 148 Bplus = 0134,
+ − 149 Bmax = 0135,
+ − 150 Bmin = 0136,
+ − 151 Bmult = 0137,
+ − 152
+ − 153 Bpoint = 0140,
+ − 154 Beq = 0141, /* was Bmark,
+ − 155 but no longer generated as of v18 */
+ − 156 Bgoto_char = 0142,
+ − 157 Binsert = 0143,
+ − 158 Bpoint_max = 0144,
+ − 159 Bpoint_min = 0145,
+ − 160 Bchar_after = 0146,
+ − 161 Bfollowing_char = 0147,
+ − 162 Bpreceding_char = 0150,
+ − 163 Bcurrent_column = 0151,
+ − 164 Bindent_to = 0152,
+ − 165 Bequal = 0153, /* was Bscan_buffer,
+ − 166 but no longer generated as of v18 */
+ − 167 Beolp = 0154,
+ − 168 Beobp = 0155,
+ − 169 Bbolp = 0156,
+ − 170 Bbobp = 0157,
+ − 171 Bcurrent_buffer = 0160,
+ − 172 Bset_buffer = 0161,
+ − 173 Bsave_current_buffer = 0162, /* was Bread_char,
+ − 174 but no longer generated as of v19 */
+ − 175 Bmemq = 0163, /* was Bset_mark,
+ − 176 but no longer generated as of v18 */
+ − 177 Binteractive_p = 0164, /* Needed since interactive-p takes
+ − 178 unevalled args */
+ − 179 Bforward_char = 0165,
+ − 180 Bforward_word = 0166,
+ − 181 Bskip_chars_forward = 0167,
+ − 182 Bskip_chars_backward = 0170,
+ − 183 Bforward_line = 0171,
+ − 184 Bchar_syntax = 0172,
+ − 185 Bbuffer_substring = 0173,
+ − 186 Bdelete_region = 0174,
+ − 187 Bnarrow_to_region = 0175,
+ − 188 Bwiden = 0176,
+ − 189 Bend_of_line = 0177,
+ − 190
+ − 191 Bconstant2 = 0201,
+ − 192 Bgoto = 0202,
+ − 193 Bgotoifnil = 0203,
+ − 194 Bgotoifnonnil = 0204,
+ − 195 Bgotoifnilelsepop = 0205,
+ − 196 Bgotoifnonnilelsepop = 0206,
+ − 197 Breturn = 0207,
+ − 198 Bdiscard = 0210,
+ − 199 Bdup = 0211,
+ − 200
+ − 201 Bsave_excursion = 0212,
+ − 202 Bsave_window_excursion= 0213,
+ − 203 Bsave_restriction = 0214,
+ − 204 Bcatch = 0215,
+ − 205
+ − 206 Bunwind_protect = 0216,
+ − 207 Bcondition_case = 0217,
+ − 208 Btemp_output_buffer_setup = 0220,
+ − 209 Btemp_output_buffer_show = 0221,
+ − 210
+ − 211 Bunbind_all = 0222,
+ − 212
+ − 213 Bset_marker = 0223,
+ − 214 Bmatch_beginning = 0224,
+ − 215 Bmatch_end = 0225,
+ − 216 Bupcase = 0226,
+ − 217 Bdowncase = 0227,
+ − 218
+ − 219 Bstring_equal = 0230,
+ − 220 Bstring_lessp = 0231,
+ − 221 Bold_equal = 0232,
+ − 222 Bnthcdr = 0233,
+ − 223 Belt = 0234,
+ − 224 Bold_member = 0235,
+ − 225 Bold_assq = 0236,
+ − 226 Bnreverse = 0237,
+ − 227 Bsetcar = 0240,
+ − 228 Bsetcdr = 0241,
+ − 229 Bcar_safe = 0242,
+ − 230 Bcdr_safe = 0243,
+ − 231 Bnconc = 0244,
+ − 232 Bquo = 0245,
+ − 233 Brem = 0246,
+ − 234 Bnumberp = 0247,
+ − 235 Bintegerp = 0250,
+ − 236
+ − 237 BRgoto = 0252,
+ − 238 BRgotoifnil = 0253,
+ − 239 BRgotoifnonnil = 0254,
+ − 240 BRgotoifnilelsepop = 0255,
+ − 241 BRgotoifnonnilelsepop = 0256,
+ − 242
+ − 243 BlistN = 0257,
+ − 244 BconcatN = 0260,
+ − 245 BinsertN = 0261,
+ − 246 Bmember = 0266, /* new in v20 */
+ − 247 Bassq = 0267, /* new in v20 */
+ − 248
+ − 249 Bconstant = 0300
+ − 250 };
+ − 251 typedef enum Opcode Opcode;
+ − 252
+ − 253
+ − 254 Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr,
442
+ − 255 const Opbyte *program_ptr,
428
+ − 256 Opcode opcode);
+ − 257
+ − 258 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
+ − 259 This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
+ − 260 /* #define BYTE_CODE_METER */
+ − 261
+ − 262
+ − 263 #ifdef BYTE_CODE_METER
+ − 264
+ − 265 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
+ − 266 int byte_metering_on;
+ − 267
+ − 268 static void
+ − 269 meter_code (Opcode prev_opcode, Opcode this_opcode)
+ − 270 {
+ − 271 if (byte_metering_on)
+ − 272 {
+ − 273 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
+ − 274 p[0] = INT_PLUS1 (p[0]);
+ − 275 if (prev_opcode)
+ − 276 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
+ − 277 }
+ − 278 }
+ − 279
+ − 280 #endif /* BYTE_CODE_METER */
+ − 281
+ − 282
+ − 283 static Lisp_Object
+ − 284 bytecode_negate (Lisp_Object obj)
+ − 285 {
+ − 286 retry:
+ − 287
1983
+ − 288 if (INTP (obj)) return make_integer (- XINT (obj));
428
+ − 289 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
1983
+ − 290 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj)));
+ − 291 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj)));
+ − 292 #ifdef HAVE_BIGNUM
+ − 293 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg);
+ − 294 #endif
+ − 295 #ifdef HAVE_RATIO
+ − 296 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg);
+ − 297 #endif
+ − 298 #ifdef HAVE_BIG_FLOAT
+ − 299 if (BIGFLOAT_P (obj)) BIGFLOAT_ARITH_RETURN (obj, neg);
+ − 300 #endif
428
+ − 301
+ − 302 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ − 303 goto retry;
+ − 304 }
+ − 305
+ − 306 static Lisp_Object
+ − 307 bytecode_nreverse (Lisp_Object list)
+ − 308 {
+ − 309 REGISTER Lisp_Object prev = Qnil;
+ − 310 REGISTER Lisp_Object tail = list;
+ − 311
+ − 312 while (!NILP (tail))
+ − 313 {
+ − 314 REGISTER Lisp_Object next;
+ − 315 CHECK_CONS (tail);
+ − 316 next = XCDR (tail);
+ − 317 XCDR (tail) = prev;
+ − 318 prev = tail;
+ − 319 tail = next;
+ − 320 }
+ − 321 return prev;
+ − 322 }
+ − 323
+ − 324
+ − 325 /* We have our own two-argument versions of various arithmetic ops.
+ − 326 Only two-argument arithmetic operations have their own byte codes. */
+ − 327 static int
+ − 328 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
+ − 329 {
1983
+ − 330 #ifdef WITH_NUMBER_TYPES
+ − 331 switch (promote_args (&obj1, &obj2))
+ − 332 {
+ − 333 case FIXNUM_T:
+ − 334 {
+ − 335 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
+ − 336 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
+ − 337 }
+ − 338 #ifdef HAVE_BIGNUM
+ − 339 case BIGNUM_T:
+ − 340 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2));
+ − 341 #endif
+ − 342 #ifdef HAVE_RATIO
+ − 343 case RATIO_T:
+ − 344 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
+ − 345 #endif
1995
+ − 346 #ifdef HAVE_BIGFLOAT
+ − 347 case BIGFLOAT_T:
+ − 348 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
+ − 349 #endif
+ − 350 default: /* FLOAT_T */
1983
+ − 351 {
+ − 352 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
+ − 353 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
+ − 354 }
+ − 355 }
+ − 356 #else /* !WITH_NUMBER_TYPES */
428
+ − 357 retry:
+ − 358
+ − 359 {
+ − 360 EMACS_INT ival1, ival2;
+ − 361
+ − 362 if (INTP (obj1)) ival1 = XINT (obj1);
+ − 363 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
+ − 364 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
+ − 365 else goto arithcompare_float;
+ − 366
+ − 367 if (INTP (obj2)) ival2 = XINT (obj2);
+ − 368 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
+ − 369 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
+ − 370 else goto arithcompare_float;
+ − 371
+ − 372 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
+ − 373 }
+ − 374
+ − 375 arithcompare_float:
+ − 376
+ − 377 {
+ − 378 double dval1, dval2;
+ − 379
+ − 380 if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1);
+ − 381 else if (INTP (obj1)) dval1 = (double) XINT (obj1);
+ − 382 else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1);
+ − 383 else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1);
+ − 384 else
+ − 385 {
+ − 386 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
+ − 387 goto retry;
+ − 388 }
+ − 389
+ − 390 if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2);
+ − 391 else if (INTP (obj2)) dval2 = (double) XINT (obj2);
+ − 392 else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2);
+ − 393 else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2);
+ − 394 else
+ − 395 {
+ − 396 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
+ − 397 goto retry;
+ − 398 }
+ − 399
+ − 400 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
+ − 401 }
1983
+ − 402 #endif /* WITH_NUMBER_TYPES */
428
+ − 403 }
+ − 404
+ − 405 static Lisp_Object
+ − 406 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
+ − 407 {
1983
+ − 408 #ifdef WITH_NUMBER_TYPES
+ − 409 switch (promote_args (&obj1, &obj2))
+ − 410 {
+ − 411 case FIXNUM_T:
+ − 412 {
+ − 413 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
+ − 414 switch (opcode)
+ − 415 {
+ − 416 case Bplus: ival1 += ival2; break;
+ − 417 case Bdiff: ival1 -= ival2; break;
+ − 418 case Bmult:
+ − 419 #ifdef HAVE_BIGNUM
+ − 420 /* Due to potential overflow, we compute using bignums */
+ − 421 bignum_set_long (scratch_bignum, ival1);
+ − 422 bignum_set_long (scratch_bignum2, ival2);
+ − 423 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2);
+ − 424 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 425 #else
+ − 426 ival1 *= ival2; break;
+ − 427 #endif
+ − 428 case Bquo:
+ − 429 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
+ − 430 ival1 /= ival2;
+ − 431 break;
+ − 432 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
+ − 433 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
+ − 434 }
+ − 435 return make_integer (ival1);
+ − 436 }
+ − 437 #ifdef HAVE_BIGNUM
+ − 438 case BIGNUM_T:
+ − 439 switch (opcode)
+ − 440 {
+ − 441 case Bplus:
+ − 442 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1),
+ − 443 XBIGNUM_DATA (obj2));
+ − 444 break;
+ − 445 case Bdiff:
+ − 446 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1),
+ − 447 XBIGNUM_DATA (obj2));
+ − 448 break;
+ − 449 case Bmult:
+ − 450 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1),
+ − 451 XBIGNUM_DATA (obj2));
+ − 452 break;
+ − 453 case Bquo:
+ − 454 if (bignum_sign (XBIGNUM_DATA (obj2)) == 0)
+ − 455 Fsignal (Qarith_error, Qnil);
+ − 456 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1),
+ − 457 XBIGNUM_DATA (obj2));
+ − 458 break;
+ − 459 case Bmax:
+ − 460 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
+ − 461 ? obj1 : obj2;
+ − 462 case Bmin:
+ − 463 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
+ − 464 ? obj1 : obj2;
+ − 465 }
+ − 466 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
+ − 467 #endif
+ − 468 #ifdef HAVE_RATIO
+ − 469 case RATIO_T:
+ − 470 switch (opcode)
+ − 471 {
+ − 472 case Bplus:
+ − 473 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
+ − 474 break;
+ − 475 case Bdiff:
+ − 476 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
+ − 477 break;
+ − 478 case Bmult:
+ − 479 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
+ − 480 break;
+ − 481 case Bquo:
+ − 482 if (ratio_sign (XRATIO_DATA (obj2)) == 0)
+ − 483 Fsignal (Qarith_error, Qnil);
+ − 484 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
+ − 485 break;
+ − 486 case Bmax:
+ − 487 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
+ − 488 ? obj1 : obj2;
+ − 489 case Bmin:
+ − 490 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
+ − 491 ? obj1 : obj2;
+ − 492 }
+ − 493 return make_ratio_rt (scratch_ratio);
+ − 494 #endif
+ − 495 #ifdef HAVE_BIGFLOAT
+ − 496 case BIGFLOAT_T:
+ − 497 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1),
+ − 498 XBIGFLOAT_GET_PREC (obj2)));
+ − 499 switch (opcode)
+ − 500 {
+ − 501 case Bplus:
+ − 502 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
+ − 503 XBIGFLOAT_DATA (obj2));
+ − 504 break;
+ − 505 case Bdiff:
+ − 506 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
+ − 507 XBIGFLOAT_DATA (obj2));
+ − 508 break;
+ − 509 case Bmult:
+ − 510 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
+ − 511 XBIGFLOAT_DATA (obj2));
+ − 512 break;
+ − 513 case Bquo:
+ − 514 if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0)
+ − 515 Fsignal (Qarith_error, Qnil);
+ − 516 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
+ − 517 XBIGFLOAT_DATA (obj2));
+ − 518 break;
+ − 519 case Bmax:
+ − 520 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
+ − 521 ? obj1 : obj2;
+ − 522 case Bmin:
+ − 523 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
+ − 524 ? obj1 : obj2;
+ − 525 }
+ − 526 return make_bigfloat_bf (scratch_bigfloat);
+ − 527 #endif
1995
+ − 528 default: /* FLOAT_T */
+ − 529 {
+ − 530 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
+ − 531 switch (opcode)
+ − 532 {
+ − 533 case Bplus: dval1 += dval2; break;
+ − 534 case Bdiff: dval1 -= dval2; break;
+ − 535 case Bmult: dval1 *= dval2; break;
+ − 536 case Bquo:
+ − 537 if (dval2 == 0.0) Fsignal (Qarith_error, Qnil);
+ − 538 dval1 /= dval2;
+ − 539 break;
+ − 540 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
+ − 541 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
+ − 542 }
+ − 543 return make_float (dval1);
+ − 544 }
1983
+ − 545 }
+ − 546 #else /* !WITH_NUMBER_TYPES */
428
+ − 547 EMACS_INT ival1, ival2;
+ − 548 int float_p;
+ − 549
+ − 550 retry:
+ − 551
+ − 552 float_p = 0;
+ − 553
+ − 554 if (INTP (obj1)) ival1 = XINT (obj1);
+ − 555 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
+ − 556 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
+ − 557 else if (FLOATP (obj1)) ival1 = 0, float_p = 1;
+ − 558 else
+ − 559 {
+ − 560 obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1);
+ − 561 goto retry;
+ − 562 }
+ − 563
+ − 564 if (INTP (obj2)) ival2 = XINT (obj2);
+ − 565 else if (CHARP (obj2)) ival2 = XCHAR (obj2);
+ − 566 else if (MARKERP (obj2)) ival2 = marker_position (obj2);
+ − 567 else if (FLOATP (obj2)) ival2 = 0, float_p = 1;
+ − 568 else
+ − 569 {
+ − 570 obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2);
+ − 571 goto retry;
+ − 572 }
+ − 573
+ − 574 if (!float_p)
+ − 575 {
+ − 576 switch (opcode)
+ − 577 {
+ − 578 case Bplus: ival1 += ival2; break;
+ − 579 case Bdiff: ival1 -= ival2; break;
+ − 580 case Bmult: ival1 *= ival2; break;
+ − 581 case Bquo:
+ − 582 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
+ − 583 ival1 /= ival2;
+ − 584 break;
+ − 585 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
+ − 586 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
+ − 587 }
+ − 588 return make_int (ival1);
+ − 589 }
+ − 590 else
+ − 591 {
+ − 592 double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1;
+ − 593 double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2;
+ − 594 switch (opcode)
+ − 595 {
+ − 596 case Bplus: dval1 += dval2; break;
+ − 597 case Bdiff: dval1 -= dval2; break;
+ − 598 case Bmult: dval1 *= dval2; break;
+ − 599 case Bquo:
+ − 600 if (dval2 == 0) Fsignal (Qarith_error, Qnil);
+ − 601 dval1 /= dval2;
+ − 602 break;
+ − 603 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
+ − 604 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
+ − 605 }
+ − 606 return make_float (dval1);
+ − 607 }
1983
+ − 608 #endif /* WITH_NUMBER_TYPES */
428
+ − 609 }
+ − 610
+ − 611
+ − 612 /* Read next uint8 from the instruction stream. */
+ − 613 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
+ − 614
+ − 615 /* Read next uint16 from the instruction stream. */
+ − 616 #define READ_UINT_2 \
+ − 617 (program_ptr += 2, \
+ − 618 (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \
+ − 619 ((unsigned int) (unsigned char) program_ptr[-2])))
+ − 620
+ − 621 /* Read next int8 from the instruction stream. */
+ − 622 #define READ_INT_1 ((int) (signed char) *program_ptr++)
+ − 623
+ − 624 /* Read next int16 from the instruction stream. */
+ − 625 #define READ_INT_2 \
+ − 626 (program_ptr += 2, \
+ − 627 (((int) ( signed char) program_ptr[-1]) * 256 + \
+ − 628 ((int) (unsigned char) program_ptr[-2])))
+ − 629
+ − 630 /* Read next int8 from instruction stream; don't advance program_pointer */
+ − 631 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
+ − 632
+ − 633 /* Read next int16 from instruction stream; don't advance program_pointer */
+ − 634 #define PEEK_INT_2 \
+ − 635 ((((int) ( signed char) program_ptr[1]) * 256) | \
+ − 636 ((int) (unsigned char) program_ptr[0]))
+ − 637
+ − 638 /* Do relative jumps from the current location.
+ − 639 We only do a QUIT if we jump backwards, for efficiency.
+ − 640 No infloops without backward jumps! */
+ − 641 #define JUMP_RELATIVE(jump) do { \
+ − 642 int JR_jump = (jump); \
+ − 643 if (JR_jump < 0) QUIT; \
+ − 644 program_ptr += JR_jump; \
+ − 645 } while (0)
+ − 646
+ − 647 #define JUMP JUMP_RELATIVE (PEEK_INT_2)
+ − 648 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
+ − 649
+ − 650 #define JUMP_NEXT ((void) (program_ptr += 2))
+ − 651 #define JUMPR_NEXT ((void) (program_ptr += 1))
+ − 652
+ − 653 /* Push x onto the execution stack. */
+ − 654 #define PUSH(x) (*++stack_ptr = (x))
+ − 655
+ − 656 /* Pop a value off the execution stack. */
+ − 657 #define POP (*stack_ptr--)
+ − 658
+ − 659 /* Discard n values from the execution stack. */
+ − 660 #define DISCARD(n) (stack_ptr -= (n))
+ − 661
+ − 662 /* Get the value which is at the top of the execution stack,
+ − 663 but don't pop it. */
+ − 664 #define TOP (*stack_ptr)
+ − 665
1920
+ − 666 /* See comment before the big switch in execute_optimized_program(). */
1884
+ − 667 #define GCPRO_STACK (gcpro1.nvars = stack_ptr - stack_beg)
+ − 668
428
+ − 669 /* The actual interpreter for byte code.
+ − 670 This function has been seriously optimized for performance.
+ − 671 Don't change the constructs unless you are willing to do
+ − 672 real benchmarking and profiling work -- martin */
+ − 673
+ − 674
814
+ − 675 Lisp_Object
442
+ − 676 execute_optimized_program (const Opbyte *program,
428
+ − 677 int stack_depth,
+ − 678 Lisp_Object *constants_data)
+ − 679 {
+ − 680 /* This function can GC */
442
+ − 681 REGISTER const Opbyte *program_ptr = (Opbyte *) program;
1884
+ − 682 Lisp_Object *stack_beg = alloca_array (Lisp_Object, stack_depth + 1);
+ − 683 REGISTER Lisp_Object *stack_ptr = stack_beg;
428
+ − 684 int speccount = specpdl_depth ();
+ − 685 struct gcpro gcpro1;
+ − 686
+ − 687 #ifdef BYTE_CODE_METER
+ − 688 Opcode this_opcode = 0;
+ − 689 Opcode prev_opcode;
+ − 690 #endif
+ − 691
+ − 692 #ifdef ERROR_CHECK_BYTE_CODE
+ − 693 Lisp_Object *stack_end = stack_beg + stack_depth;
+ − 694 #endif
+ − 695
1920
+ − 696 /* We used to GCPRO the whole interpreter stack before entering this while
+ − 697 loop (21.5.14 and before), but that interferes with collection of weakly
+ − 698 referenced objects. Although strictly speaking there's no promise that
+ − 699 weak references will disappear by any given point in time, they should
+ − 700 be collected at the first opportunity. Waiting until exit from the
+ − 701 function caused test failures because "stale" objects "above" the top of
+ − 702 the stack were still GCPROed, and they were not getting collected until
+ − 703 after exit from the (byte-compiled) test!
+ − 704
+ − 705 Now the idea is to dynamically adjust the array of GCPROed objects to
+ − 706 include only the "active" region of the stack.
+ − 707
+ − 708 We use the "GCPRO1 the array base and set the nvars member" method. It
+ − 709 would be slightly inefficient but correct to use GCPRO1_ARRAY here. It
+ − 710 would just redundantly set nvars.
+ − 711 #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
+ − 712 after the switch?
+ − 713
+ − 714 GCPRO_STACK is something of a misnomer, because it suggests that a
+ − 715 struct gcpro is initialized each time. This is false; only the nvars
+ − 716 member of a single struct gcpro is being adjusted. This works because
+ − 717 each time a new object is assigned to a stack location, the old object
+ − 718 loses its reference and is effectively UNGCPROed, and the new object is
+ − 719 automatically GCPROed as long as nvars is correct. Only when we
+ − 720 return from the interpreter do we need to finalize the struct gcpro
+ − 721 itself, and that's done at case Breturn.
+ − 722 */
428
+ − 723 GCPRO1 (stack_ptr[1]);
1758
+ − 724
428
+ − 725 while (1)
+ − 726 {
+ − 727 REGISTER Opcode opcode = (Opcode) READ_UINT_1;
1920
+ − 728
+ − 729 GCPRO_STACK; /* Get nvars right before maybe signaling. */
428
+ − 730 #ifdef ERROR_CHECK_BYTE_CODE
+ − 731 if (stack_ptr > stack_end)
563
+ − 732 stack_overflow ("byte code stack overflow", Qunbound);
428
+ − 733 if (stack_ptr < stack_beg)
563
+ − 734 stack_overflow ("byte code stack underflow", Qunbound);
428
+ − 735 #endif
+ − 736
+ − 737 #ifdef BYTE_CODE_METER
+ − 738 prev_opcode = this_opcode;
+ − 739 this_opcode = opcode;
+ − 740 meter_code (prev_opcode, this_opcode);
+ − 741 #endif
+ − 742
+ − 743 switch (opcode)
+ − 744 {
+ − 745 REGISTER int n;
+ − 746
+ − 747 default:
+ − 748 if (opcode >= Bconstant)
+ − 749 PUSH (constants_data[opcode - Bconstant]);
+ − 750 else
1884
+ − 751 {
+ − 752 /* We're not sure what these do, so better safe than sorry. */
+ − 753 /* GCPRO_STACK; */
+ − 754 stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode);
+ − 755 }
428
+ − 756 break;
+ − 757
+ − 758 case Bvarref:
+ − 759 case Bvarref+1:
+ − 760 case Bvarref+2:
+ − 761 case Bvarref+3:
+ − 762 case Bvarref+4:
+ − 763 case Bvarref+5: n = opcode - Bvarref; goto do_varref;
+ − 764 case Bvarref+7: n = READ_UINT_2; goto do_varref;
+ − 765 case Bvarref+6: n = READ_UINT_1; /* most common */
+ − 766 do_varref:
+ − 767 {
+ − 768 Lisp_Object symbol = constants_data[n];
+ − 769 Lisp_Object value = XSYMBOL (symbol)->value;
+ − 770 if (SYMBOL_VALUE_MAGIC_P (value))
1920
+ − 771 /* I GCPRO_STACKed Fsymbol_value elsewhere, but I dunno why. */
+ − 772 /* GCPRO_STACK; */
428
+ − 773 value = Fsymbol_value (symbol);
+ − 774 PUSH (value);
+ − 775 break;
+ − 776 }
+ − 777
+ − 778 case Bvarset:
+ − 779 case Bvarset+1:
+ − 780 case Bvarset+2:
+ − 781 case Bvarset+3:
+ − 782 case Bvarset+4:
+ − 783 case Bvarset+5: n = opcode - Bvarset; goto do_varset;
+ − 784 case Bvarset+7: n = READ_UINT_2; goto do_varset;
+ − 785 case Bvarset+6: n = READ_UINT_1; /* most common */
+ − 786 do_varset:
+ − 787 {
+ − 788 Lisp_Object symbol = constants_data[n];
440
+ − 789 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
428
+ − 790 Lisp_Object old_value = symbol_ptr->value;
+ − 791 Lisp_Object new_value = POP;
1661
+ − 792 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
428
+ − 793 symbol_ptr->value = new_value;
1884
+ − 794 else {
+ − 795 /* Fset may call magic handlers */
+ − 796 /* GCPRO_STACK; */
428
+ − 797 Fset (symbol, new_value);
1884
+ − 798 }
+ − 799
428
+ − 800 break;
+ − 801 }
+ − 802
+ − 803 case Bvarbind:
+ − 804 case Bvarbind+1:
+ − 805 case Bvarbind+2:
+ − 806 case Bvarbind+3:
+ − 807 case Bvarbind+4:
+ − 808 case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind;
+ − 809 case Bvarbind+7: n = READ_UINT_2; goto do_varbind;
+ − 810 case Bvarbind+6: n = READ_UINT_1; /* most common */
+ − 811 do_varbind:
+ − 812 {
+ − 813 Lisp_Object symbol = constants_data[n];
440
+ − 814 Lisp_Symbol *symbol_ptr = XSYMBOL (symbol);
428
+ − 815 Lisp_Object old_value = symbol_ptr->value;
+ − 816 Lisp_Object new_value = POP;
+ − 817 if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value))
+ − 818 {
+ − 819 specpdl_ptr->symbol = symbol;
+ − 820 specpdl_ptr->old_value = old_value;
+ − 821 specpdl_ptr->func = 0;
+ − 822 specpdl_ptr++;
+ − 823 specpdl_depth_counter++;
+ − 824
+ − 825 symbol_ptr->value = new_value;
853
+ − 826
+ − 827 #ifdef ERROR_CHECK_CATCH
+ − 828 check_specbind_stack_sanity ();
+ − 829 #endif
428
+ − 830 }
+ − 831 else
1884
+ − 832 {
+ − 833 /* does an Fset, may call magic handlers */
+ − 834 /* GCPRO_STACK; */
+ − 835 specbind_magic (symbol, new_value);
+ − 836 }
428
+ − 837 break;
+ − 838 }
+ − 839
+ − 840 case Bcall:
+ − 841 case Bcall+1:
+ − 842 case Bcall+2:
+ − 843 case Bcall+3:
+ − 844 case Bcall+4:
+ − 845 case Bcall+5:
+ − 846 case Bcall+6:
+ − 847 case Bcall+7:
+ − 848 n = (opcode < Bcall+6 ? opcode - Bcall :
+ − 849 opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2);
1920
+ − 850 /* #### Shouldn't this be just before the Ffuncall?
+ − 851 Neither Fget nor Fput can GC. */
1884
+ − 852 /* GCPRO_STACK; */
428
+ − 853 DISCARD (n);
+ − 854 #ifdef BYTE_CODE_METER
+ − 855 if (byte_metering_on && SYMBOLP (TOP))
+ − 856 {
+ − 857 Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
+ − 858 if (INTP (val))
+ − 859 Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
+ − 860 }
+ − 861 #endif
+ − 862 TOP = Ffuncall (n + 1, &TOP);
+ − 863 break;
+ − 864
+ − 865 case Bunbind:
+ − 866 case Bunbind+1:
+ − 867 case Bunbind+2:
+ − 868 case Bunbind+3:
+ − 869 case Bunbind+4:
+ − 870 case Bunbind+5:
+ − 871 case Bunbind+6:
+ − 872 case Bunbind+7:
+ − 873 UNBIND_TO (specpdl_depth() -
+ − 874 (opcode < Bunbind+6 ? opcode-Bunbind :
+ − 875 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
+ − 876 break;
+ − 877
+ − 878
+ − 879 case Bgoto:
+ − 880 JUMP;
+ − 881 break;
+ − 882
+ − 883 case Bgotoifnil:
+ − 884 if (NILP (POP))
+ − 885 JUMP;
+ − 886 else
+ − 887 JUMP_NEXT;
+ − 888 break;
+ − 889
+ − 890 case Bgotoifnonnil:
+ − 891 if (!NILP (POP))
+ − 892 JUMP;
+ − 893 else
+ − 894 JUMP_NEXT;
+ − 895 break;
+ − 896
+ − 897 case Bgotoifnilelsepop:
+ − 898 if (NILP (TOP))
+ − 899 JUMP;
+ − 900 else
+ − 901 {
+ − 902 DISCARD (1);
+ − 903 JUMP_NEXT;
+ − 904 }
+ − 905 break;
+ − 906
+ − 907 case Bgotoifnonnilelsepop:
+ − 908 if (!NILP (TOP))
+ − 909 JUMP;
+ − 910 else
+ − 911 {
+ − 912 DISCARD (1);
+ − 913 JUMP_NEXT;
+ − 914 }
+ − 915 break;
+ − 916
+ − 917
+ − 918 case BRgoto:
+ − 919 JUMPR;
+ − 920 break;
+ − 921
+ − 922 case BRgotoifnil:
+ − 923 if (NILP (POP))
+ − 924 JUMPR;
+ − 925 else
+ − 926 JUMPR_NEXT;
+ − 927 break;
+ − 928
+ − 929 case BRgotoifnonnil:
+ − 930 if (!NILP (POP))
+ − 931 JUMPR;
+ − 932 else
+ − 933 JUMPR_NEXT;
+ − 934 break;
+ − 935
+ − 936 case BRgotoifnilelsepop:
+ − 937 if (NILP (TOP))
+ − 938 JUMPR;
+ − 939 else
+ − 940 {
+ − 941 DISCARD (1);
+ − 942 JUMPR_NEXT;
+ − 943 }
+ − 944 break;
+ − 945
+ − 946 case BRgotoifnonnilelsepop:
+ − 947 if (!NILP (TOP))
+ − 948 JUMPR;
+ − 949 else
+ − 950 {
+ − 951 DISCARD (1);
+ − 952 JUMPR_NEXT;
+ − 953 }
+ − 954 break;
+ − 955
+ − 956 case Breturn:
+ − 957 UNGCPRO;
+ − 958 #ifdef ERROR_CHECK_BYTE_CODE
+ − 959 /* Binds and unbinds are supposed to be compiled balanced. */
+ − 960 if (specpdl_depth() != speccount)
563
+ − 961 invalid_byte_code ("unbalanced specbinding stack", Qunbound);
428
+ − 962 #endif
+ − 963 return TOP;
+ − 964
+ − 965 case Bdiscard:
+ − 966 DISCARD (1);
+ − 967 break;
+ − 968
+ − 969 case Bdup:
+ − 970 {
+ − 971 Lisp_Object arg = TOP;
+ − 972 PUSH (arg);
+ − 973 break;
+ − 974 }
+ − 975
+ − 976 case Bconstant2:
+ − 977 PUSH (constants_data[READ_UINT_2]);
+ − 978 break;
+ − 979
+ − 980 case Bcar:
1920
+ − 981 /* Fcar can GC via wrong_type_argument. */
+ − 982 /* GCPRO_STACK; */
428
+ − 983 TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
+ − 984 break;
+ − 985
+ − 986 case Bcdr:
1920
+ − 987 /* Fcdr can GC via wrong_type_argument. */
+ − 988 /* GCPRO_STACK; */
428
+ − 989 TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
+ − 990 break;
+ − 991
+ − 992
+ − 993 case Bunbind_all:
+ − 994 /* To unbind back to the beginning of this frame. Not used yet,
+ − 995 but will be needed for tail-recursion elimination. */
771
+ − 996 unbind_to (speccount);
428
+ − 997 break;
+ − 998
+ − 999 case Bnth:
+ − 1000 {
+ − 1001 Lisp_Object arg = POP;
1920
+ − 1002 /* Fcar and Fnthcdr can GC via wrong_type_argument. */
+ − 1003 /* GCPRO_STACK; */
428
+ − 1004 TOP = Fcar (Fnthcdr (TOP, arg));
+ − 1005 break;
+ − 1006 }
+ − 1007
+ − 1008 case Bsymbolp:
+ − 1009 TOP = SYMBOLP (TOP) ? Qt : Qnil;
+ − 1010 break;
+ − 1011
+ − 1012 case Bconsp:
+ − 1013 TOP = CONSP (TOP) ? Qt : Qnil;
+ − 1014 break;
+ − 1015
+ − 1016 case Bstringp:
+ − 1017 TOP = STRINGP (TOP) ? Qt : Qnil;
+ − 1018 break;
+ − 1019
+ − 1020 case Blistp:
+ − 1021 TOP = LISTP (TOP) ? Qt : Qnil;
+ − 1022 break;
+ − 1023
+ − 1024 case Bnumberp:
1983
+ − 1025 #ifdef WITH_NUMBER_TYPES
+ − 1026 TOP = NUMBERP (TOP) ? Qt : Qnil;
+ − 1027 #else
428
+ − 1028 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
1983
+ − 1029 #endif
428
+ − 1030 break;
+ − 1031
+ − 1032 case Bintegerp:
1983
+ − 1033 #ifdef HAVE_BIGNUM
+ − 1034 TOP = INTEGERP (TOP) ? Qt : Qnil;
+ − 1035 #else
428
+ − 1036 TOP = INTP (TOP) ? Qt : Qnil;
1983
+ − 1037 #endif
428
+ − 1038 break;
+ − 1039
+ − 1040 case Beq:
+ − 1041 {
+ − 1042 Lisp_Object arg = POP;
+ − 1043 TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
+ − 1044 break;
+ − 1045 }
+ − 1046
+ − 1047 case Bnot:
+ − 1048 TOP = NILP (TOP) ? Qt : Qnil;
+ − 1049 break;
+ − 1050
+ − 1051 case Bcons:
+ − 1052 {
+ − 1053 Lisp_Object arg = POP;
+ − 1054 TOP = Fcons (TOP, arg);
+ − 1055 break;
+ − 1056 }
+ − 1057
+ − 1058 case Blist1:
+ − 1059 TOP = Fcons (TOP, Qnil);
+ − 1060 break;
+ − 1061
+ − 1062
+ − 1063 case BlistN:
+ − 1064 n = READ_UINT_1;
+ − 1065 goto do_list;
+ − 1066
+ − 1067 case Blist2:
+ − 1068 case Blist3:
+ − 1069 case Blist4:
+ − 1070 /* common case */
+ − 1071 n = opcode - (Blist1 - 1);
+ − 1072 do_list:
+ − 1073 {
+ − 1074 Lisp_Object list = Qnil;
+ − 1075 list_loop:
+ − 1076 list = Fcons (TOP, list);
+ − 1077 if (--n)
+ − 1078 {
+ − 1079 DISCARD (1);
+ − 1080 goto list_loop;
+ − 1081 }
+ − 1082 TOP = list;
+ − 1083 break;
+ − 1084 }
+ − 1085
+ − 1086
+ − 1087 case Bconcat2:
+ − 1088 case Bconcat3:
+ − 1089 case Bconcat4:
+ − 1090 n = opcode - (Bconcat2 - 2);
+ − 1091 goto do_concat;
+ − 1092
+ − 1093 case BconcatN:
+ − 1094 /* common case */
+ − 1095 n = READ_UINT_1;
+ − 1096 do_concat:
+ − 1097 DISCARD (n - 1);
1920
+ − 1098 /* Apparently `concat' can GC; Fconcat GCPROs its arguments. */
+ − 1099 /* GCPRO_STACK; */
428
+ − 1100 TOP = Fconcat (n, &TOP);
+ − 1101 break;
+ − 1102
+ − 1103
+ − 1104 case Blength:
+ − 1105 TOP = Flength (TOP);
+ − 1106 break;
+ − 1107
+ − 1108 case Baset:
+ − 1109 {
+ − 1110 Lisp_Object arg2 = POP;
+ − 1111 Lisp_Object arg1 = POP;
+ − 1112 TOP = Faset (TOP, arg1, arg2);
+ − 1113 break;
+ − 1114 }
+ − 1115
+ − 1116 case Bsymbol_value:
1920
+ − 1117 /* Why does this need GCPRO_STACK? If not, remove others, too. */
1884
+ − 1118 /* GCPRO_STACK; */
428
+ − 1119 TOP = Fsymbol_value (TOP);
+ − 1120 break;
+ − 1121
+ − 1122 case Bsymbol_function:
+ − 1123 TOP = Fsymbol_function (TOP);
+ − 1124 break;
+ − 1125
+ − 1126 case Bget:
+ − 1127 {
+ − 1128 Lisp_Object arg = POP;
+ − 1129 TOP = Fget (TOP, arg, Qnil);
+ − 1130 break;
+ − 1131 }
+ − 1132
+ − 1133 case Bsub1:
1983
+ − 1134 #ifdef HAVE_BIGNUM
+ − 1135 TOP = Fsub1 (TOP);
+ − 1136 #else
428
+ − 1137 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1983
+ − 1138 #endif
428
+ − 1139 break;
+ − 1140
+ − 1141 case Badd1:
1983
+ − 1142 #ifdef HAVE_BIGNUM
+ − 1143 TOP = Fadd1 (TOP);
+ − 1144 #else
428
+ − 1145 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1983
+ − 1146 #endif
428
+ − 1147 break;
+ − 1148
+ − 1149
+ − 1150 case Beqlsign:
+ − 1151 {
+ − 1152 Lisp_Object arg = POP;
+ − 1153 TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
+ − 1154 break;
+ − 1155 }
+ − 1156
+ − 1157 case Bgtr:
+ − 1158 {
+ − 1159 Lisp_Object arg = POP;
+ − 1160 TOP = bytecode_arithcompare (TOP, arg) > 0 ? Qt : Qnil;
+ − 1161 break;
+ − 1162 }
+ − 1163
+ − 1164 case Blss:
+ − 1165 {
+ − 1166 Lisp_Object arg = POP;
+ − 1167 TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil;
+ − 1168 break;
+ − 1169 }
+ − 1170
+ − 1171 case Bleq:
+ − 1172 {
+ − 1173 Lisp_Object arg = POP;
+ − 1174 TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil;
+ − 1175 break;
+ − 1176 }
+ − 1177
+ − 1178 case Bgeq:
+ − 1179 {
+ − 1180 Lisp_Object arg = POP;
+ − 1181 TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil;
+ − 1182 break;
+ − 1183 }
+ − 1184
+ − 1185
+ − 1186 case Bnegate:
+ − 1187 TOP = bytecode_negate (TOP);
+ − 1188 break;
+ − 1189
+ − 1190 case Bnconc:
+ − 1191 DISCARD (1);
1920
+ − 1192 /* nconc2 GCPROs before calling this. */
+ − 1193 /* GCPRO_STACK; */
428
+ − 1194 TOP = bytecode_nconc2 (&TOP);
+ − 1195 break;
+ − 1196
+ − 1197 case Bplus:
+ − 1198 {
+ − 1199 Lisp_Object arg2 = POP;
+ − 1200 Lisp_Object arg1 = TOP;
1983
+ − 1201 #ifdef HAVE_BIGNUM
+ − 1202 TOP = bytecode_arithop (arg1, arg2, opcode);
+ − 1203 #else
428
+ − 1204 TOP = INTP (arg1) && INTP (arg2) ?
+ − 1205 INT_PLUS (arg1, arg2) :
+ − 1206 bytecode_arithop (arg1, arg2, opcode);
1983
+ − 1207 #endif
428
+ − 1208 break;
+ − 1209 }
+ − 1210
+ − 1211 case Bdiff:
+ − 1212 {
+ − 1213 Lisp_Object arg2 = POP;
+ − 1214 Lisp_Object arg1 = TOP;
1983
+ − 1215 #ifdef HAVE_BIGNUM
+ − 1216 TOP = bytecode_arithop (arg1, arg2, opcode);
+ − 1217 #else
428
+ − 1218 TOP = INTP (arg1) && INTP (arg2) ?
+ − 1219 INT_MINUS (arg1, arg2) :
+ − 1220 bytecode_arithop (arg1, arg2, opcode);
1983
+ − 1221 #endif
428
+ − 1222 break;
+ − 1223 }
+ − 1224
+ − 1225 case Bmult:
+ − 1226 case Bquo:
+ − 1227 case Bmax:
+ − 1228 case Bmin:
+ − 1229 {
+ − 1230 Lisp_Object arg = POP;
+ − 1231 TOP = bytecode_arithop (TOP, arg, opcode);
+ − 1232 break;
+ − 1233 }
+ − 1234
+ − 1235 case Bpoint:
+ − 1236 PUSH (make_int (BUF_PT (current_buffer)));
+ − 1237 break;
+ − 1238
+ − 1239 case Binsert:
1920
+ − 1240 /* Says it can GC. */
+ − 1241 /* GCPRO_STACK; */
428
+ − 1242 TOP = Finsert (1, &TOP);
+ − 1243 break;
+ − 1244
+ − 1245 case BinsertN:
+ − 1246 n = READ_UINT_1;
+ − 1247 DISCARD (n - 1);
1920
+ − 1248 /* See Binsert. */
+ − 1249 /* GCPRO_STACK; */
428
+ − 1250 TOP = Finsert (n, &TOP);
+ − 1251 break;
+ − 1252
+ − 1253 case Baref:
+ − 1254 {
+ − 1255 Lisp_Object arg = POP;
+ − 1256 TOP = Faref (TOP, arg);
+ − 1257 break;
+ − 1258 }
+ − 1259
+ − 1260 case Bmemq:
+ − 1261 {
+ − 1262 Lisp_Object arg = POP;
+ − 1263 TOP = Fmemq (TOP, arg);
+ − 1264 break;
+ − 1265 }
+ − 1266
+ − 1267 case Bset:
+ − 1268 {
+ − 1269 Lisp_Object arg = POP;
1884
+ − 1270 /* Fset may call magic handlers */
+ − 1271 /* GCPRO_STACK; */
428
+ − 1272 TOP = Fset (TOP, arg);
+ − 1273 break;
+ − 1274 }
+ − 1275
+ − 1276 case Bequal:
+ − 1277 {
+ − 1278 Lisp_Object arg = POP;
1920
+ − 1279 /* Can QUIT, so can GC, right? */
+ − 1280 /* GCPRO_STACK; */
428
+ − 1281 TOP = Fequal (TOP, arg);
+ − 1282 break;
+ − 1283 }
+ − 1284
+ − 1285 case Bnthcdr:
+ − 1286 {
+ − 1287 Lisp_Object arg = POP;
+ − 1288 TOP = Fnthcdr (TOP, arg);
+ − 1289 break;
+ − 1290 }
+ − 1291
+ − 1292 case Belt:
+ − 1293 {
+ − 1294 Lisp_Object arg = POP;
+ − 1295 TOP = Felt (TOP, arg);
+ − 1296 break;
+ − 1297 }
+ − 1298
+ − 1299 case Bmember:
+ − 1300 {
+ − 1301 Lisp_Object arg = POP;
1920
+ − 1302 /* Can QUIT, so can GC, right? */
+ − 1303 /* GCPRO_STACK; */
428
+ − 1304 TOP = Fmember (TOP, arg);
+ − 1305 break;
+ − 1306 }
+ − 1307
+ − 1308 case Bgoto_char:
+ − 1309 TOP = Fgoto_char (TOP, Qnil);
+ − 1310 break;
+ − 1311
+ − 1312 case Bcurrent_buffer:
+ − 1313 {
793
+ − 1314 Lisp_Object buffer = wrap_buffer (current_buffer);
+ − 1315
428
+ − 1316 PUSH (buffer);
+ − 1317 break;
+ − 1318 }
+ − 1319
+ − 1320 case Bset_buffer:
1884
+ − 1321 /* #### WAG: set-buffer may cause Fset's of buffer locals
+ − 1322 Didn't prevent crash. :-( */
+ − 1323 /* GCPRO_STACK; */
428
+ − 1324 TOP = Fset_buffer (TOP);
+ − 1325 break;
+ − 1326
+ − 1327 case Bpoint_max:
+ − 1328 PUSH (make_int (BUF_ZV (current_buffer)));
+ − 1329 break;
+ − 1330
+ − 1331 case Bpoint_min:
+ − 1332 PUSH (make_int (BUF_BEGV (current_buffer)));
+ − 1333 break;
+ − 1334
+ − 1335 case Bskip_chars_forward:
+ − 1336 {
+ − 1337 Lisp_Object arg = POP;
1920
+ − 1338 /* Can QUIT, so can GC, right? */
+ − 1339 /* GCPRO_STACK; */
428
+ − 1340 TOP = Fskip_chars_forward (TOP, arg, Qnil);
+ − 1341 break;
+ − 1342 }
+ − 1343
+ − 1344 case Bassq:
+ − 1345 {
+ − 1346 Lisp_Object arg = POP;
+ − 1347 TOP = Fassq (TOP, arg);
+ − 1348 break;
+ − 1349 }
+ − 1350
+ − 1351 case Bsetcar:
+ − 1352 {
+ − 1353 Lisp_Object arg = POP;
+ − 1354 TOP = Fsetcar (TOP, arg);
+ − 1355 break;
+ − 1356 }
+ − 1357
+ − 1358 case Bsetcdr:
+ − 1359 {
+ − 1360 Lisp_Object arg = POP;
+ − 1361 TOP = Fsetcdr (TOP, arg);
+ − 1362 break;
+ − 1363 }
+ − 1364
+ − 1365 case Bnreverse:
+ − 1366 TOP = bytecode_nreverse (TOP);
+ − 1367 break;
+ − 1368
+ − 1369 case Bcar_safe:
+ − 1370 TOP = CONSP (TOP) ? XCAR (TOP) : Qnil;
+ − 1371 break;
+ − 1372
+ − 1373 case Bcdr_safe:
+ − 1374 TOP = CONSP (TOP) ? XCDR (TOP) : Qnil;
+ − 1375 break;
+ − 1376
+ − 1377 }
+ − 1378 }
+ − 1379 }
+ − 1380
+ − 1381 /* It makes a worthwhile performance difference (5%) to shunt
+ − 1382 lesser-used opcodes off to a subroutine, to keep the switch in
+ − 1383 execute_optimized_program small. If you REALLY care about
+ − 1384 performance, you want to keep your heavily executed code away from
+ − 1385 rarely executed code, to minimize cache misses.
+ − 1386
+ − 1387 Don't make this function static, since then the compiler might inline it. */
+ − 1388 Lisp_Object *
+ − 1389 execute_rare_opcode (Lisp_Object *stack_ptr,
2286
+ − 1390 const Opbyte *UNUSED (program_ptr),
428
+ − 1391 Opcode opcode)
+ − 1392 {
+ − 1393 switch (opcode)
+ − 1394 {
+ − 1395
+ − 1396 case Bsave_excursion:
+ − 1397 record_unwind_protect (save_excursion_restore,
+ − 1398 save_excursion_save ());
+ − 1399 break;
+ − 1400
+ − 1401 case Bsave_window_excursion:
+ − 1402 {
+ − 1403 int count = specpdl_depth ();
+ − 1404 record_unwind_protect (save_window_excursion_unwind,
1149
+ − 1405 call1 (Qcurrent_window_configuration, Qnil));
428
+ − 1406 TOP = Fprogn (TOP);
771
+ − 1407 unbind_to (count);
428
+ − 1408 break;
+ − 1409 }
+ − 1410
+ − 1411 case Bsave_restriction:
+ − 1412 record_unwind_protect (save_restriction_restore,
844
+ − 1413 save_restriction_save (current_buffer));
428
+ − 1414 break;
+ − 1415
+ − 1416 case Bcatch:
+ − 1417 {
+ − 1418 Lisp_Object arg = POP;
2532
+ − 1419 TOP = internal_catch (TOP, Feval, arg, 0, 0, 0);
428
+ − 1420 break;
+ − 1421 }
+ − 1422
+ − 1423 case Bskip_chars_backward:
+ − 1424 {
+ − 1425 Lisp_Object arg = POP;
+ − 1426 TOP = Fskip_chars_backward (TOP, arg, Qnil);
+ − 1427 break;
+ − 1428 }
+ − 1429
+ − 1430 case Bunwind_protect:
+ − 1431 record_unwind_protect (Fprogn, POP);
+ − 1432 break;
+ − 1433
+ − 1434 case Bcondition_case:
+ − 1435 {
+ − 1436 Lisp_Object arg2 = POP; /* handlers */
+ − 1437 Lisp_Object arg1 = POP; /* bodyform */
+ − 1438 TOP = condition_case_3 (arg1, TOP, arg2);
+ − 1439 break;
+ − 1440 }
+ − 1441
+ − 1442 case Bset_marker:
+ − 1443 {
+ − 1444 Lisp_Object arg2 = POP;
+ − 1445 Lisp_Object arg1 = POP;
+ − 1446 TOP = Fset_marker (TOP, arg1, arg2);
+ − 1447 break;
+ − 1448 }
+ − 1449
+ − 1450 case Brem:
+ − 1451 {
+ − 1452 Lisp_Object arg = POP;
+ − 1453 TOP = Frem (TOP, arg);
+ − 1454 break;
+ − 1455 }
+ − 1456
+ − 1457 case Bmatch_beginning:
+ − 1458 TOP = Fmatch_beginning (TOP);
+ − 1459 break;
+ − 1460
+ − 1461 case Bmatch_end:
+ − 1462 TOP = Fmatch_end (TOP);
+ − 1463 break;
+ − 1464
+ − 1465 case Bupcase:
+ − 1466 TOP = Fupcase (TOP, Qnil);
+ − 1467 break;
+ − 1468
+ − 1469 case Bdowncase:
+ − 1470 TOP = Fdowncase (TOP, Qnil);
+ − 1471 break;
+ − 1472
+ − 1473 case Bfset:
+ − 1474 {
+ − 1475 Lisp_Object arg = POP;
+ − 1476 TOP = Ffset (TOP, arg);
+ − 1477 break;
+ − 1478 }
+ − 1479
+ − 1480 case Bstring_equal:
+ − 1481 {
+ − 1482 Lisp_Object arg = POP;
+ − 1483 TOP = Fstring_equal (TOP, arg);
+ − 1484 break;
+ − 1485 }
+ − 1486
+ − 1487 case Bstring_lessp:
+ − 1488 {
+ − 1489 Lisp_Object arg = POP;
+ − 1490 TOP = Fstring_lessp (TOP, arg);
+ − 1491 break;
+ − 1492 }
+ − 1493
+ − 1494 case Bsubstring:
+ − 1495 {
+ − 1496 Lisp_Object arg2 = POP;
+ − 1497 Lisp_Object arg1 = POP;
+ − 1498 TOP = Fsubstring (TOP, arg1, arg2);
+ − 1499 break;
+ − 1500 }
+ − 1501
+ − 1502 case Bcurrent_column:
+ − 1503 PUSH (make_int (current_column (current_buffer)));
+ − 1504 break;
+ − 1505
+ − 1506 case Bchar_after:
+ − 1507 TOP = Fchar_after (TOP, Qnil);
+ − 1508 break;
+ − 1509
+ − 1510 case Bindent_to:
+ − 1511 TOP = Findent_to (TOP, Qnil, Qnil);
+ − 1512 break;
+ − 1513
+ − 1514 case Bwiden:
+ − 1515 PUSH (Fwiden (Qnil));
+ − 1516 break;
+ − 1517
+ − 1518 case Bfollowing_char:
+ − 1519 PUSH (Ffollowing_char (Qnil));
+ − 1520 break;
+ − 1521
+ − 1522 case Bpreceding_char:
+ − 1523 PUSH (Fpreceding_char (Qnil));
+ − 1524 break;
+ − 1525
+ − 1526 case Beolp:
+ − 1527 PUSH (Feolp (Qnil));
+ − 1528 break;
+ − 1529
+ − 1530 case Beobp:
+ − 1531 PUSH (Feobp (Qnil));
+ − 1532 break;
+ − 1533
+ − 1534 case Bbolp:
+ − 1535 PUSH (Fbolp (Qnil));
+ − 1536 break;
+ − 1537
+ − 1538 case Bbobp:
+ − 1539 PUSH (Fbobp (Qnil));
+ − 1540 break;
+ − 1541
+ − 1542 case Bsave_current_buffer:
+ − 1543 record_unwind_protect (save_current_buffer_restore,
+ − 1544 Fcurrent_buffer ());
+ − 1545 break;
+ − 1546
+ − 1547 case Binteractive_p:
+ − 1548 PUSH (Finteractive_p ());
+ − 1549 break;
+ − 1550
+ − 1551 case Bforward_char:
+ − 1552 TOP = Fforward_char (TOP, Qnil);
+ − 1553 break;
+ − 1554
+ − 1555 case Bforward_word:
+ − 1556 TOP = Fforward_word (TOP, Qnil);
+ − 1557 break;
+ − 1558
+ − 1559 case Bforward_line:
+ − 1560 TOP = Fforward_line (TOP, Qnil);
+ − 1561 break;
+ − 1562
+ − 1563 case Bchar_syntax:
+ − 1564 TOP = Fchar_syntax (TOP, Qnil);
+ − 1565 break;
+ − 1566
+ − 1567 case Bbuffer_substring:
+ − 1568 {
+ − 1569 Lisp_Object arg = POP;
+ − 1570 TOP = Fbuffer_substring (TOP, arg, Qnil);
+ − 1571 break;
+ − 1572 }
+ − 1573
+ − 1574 case Bdelete_region:
+ − 1575 {
+ − 1576 Lisp_Object arg = POP;
+ − 1577 TOP = Fdelete_region (TOP, arg, Qnil);
+ − 1578 break;
+ − 1579 }
+ − 1580
+ − 1581 case Bnarrow_to_region:
+ − 1582 {
+ − 1583 Lisp_Object arg = POP;
+ − 1584 TOP = Fnarrow_to_region (TOP, arg, Qnil);
+ − 1585 break;
+ − 1586 }
+ − 1587
+ − 1588 case Bend_of_line:
+ − 1589 TOP = Fend_of_line (TOP, Qnil);
+ − 1590 break;
+ − 1591
+ − 1592 case Btemp_output_buffer_setup:
+ − 1593 temp_output_buffer_setup (TOP);
+ − 1594 TOP = Vstandard_output;
+ − 1595 break;
+ − 1596
+ − 1597 case Btemp_output_buffer_show:
+ − 1598 {
+ − 1599 Lisp_Object arg = POP;
+ − 1600 temp_output_buffer_show (TOP, Qnil);
+ − 1601 TOP = arg;
+ − 1602 /* GAG ME!! */
+ − 1603 /* pop binding of standard-output */
771
+ − 1604 unbind_to (specpdl_depth() - 1);
428
+ − 1605 break;
+ − 1606 }
+ − 1607
+ − 1608 case Bold_eq:
+ − 1609 {
+ − 1610 Lisp_Object arg = POP;
+ − 1611 TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil;
+ − 1612 break;
+ − 1613 }
+ − 1614
+ − 1615 case Bold_memq:
+ − 1616 {
+ − 1617 Lisp_Object arg = POP;
+ − 1618 TOP = Fold_memq (TOP, arg);
+ − 1619 break;
+ − 1620 }
+ − 1621
+ − 1622 case Bold_equal:
+ − 1623 {
+ − 1624 Lisp_Object arg = POP;
+ − 1625 TOP = Fold_equal (TOP, arg);
+ − 1626 break;
+ − 1627 }
+ − 1628
+ − 1629 case Bold_member:
+ − 1630 {
+ − 1631 Lisp_Object arg = POP;
+ − 1632 TOP = Fold_member (TOP, arg);
+ − 1633 break;
+ − 1634 }
+ − 1635
+ − 1636 case Bold_assq:
+ − 1637 {
+ − 1638 Lisp_Object arg = POP;
+ − 1639 TOP = Fold_assq (TOP, arg);
+ − 1640 break;
+ − 1641 }
+ − 1642
+ − 1643 default:
2500
+ − 1644 ABORT();
428
+ − 1645 break;
+ − 1646 }
+ − 1647 return stack_ptr;
+ − 1648 }
+ − 1649
+ − 1650
563
+ − 1651 DOESNT_RETURN
867
+ − 1652 invalid_byte_code (const CIbyte *reason, Lisp_Object frob)
428
+ − 1653 {
563
+ − 1654 signal_error (Qinvalid_byte_code, reason, frob);
428
+ − 1655 }
+ − 1656
+ − 1657 /* Check for valid opcodes. Change this when adding new opcodes. */
+ − 1658 static void
+ − 1659 check_opcode (Opcode opcode)
+ − 1660 {
+ − 1661 if ((opcode < Bvarref) ||
+ − 1662 (opcode == 0251) ||
+ − 1663 (opcode > Bassq && opcode < Bconstant))
563
+ − 1664 invalid_byte_code ("invalid opcode in instruction stream",
+ − 1665 make_int (opcode));
428
+ − 1666 }
+ − 1667
+ − 1668 /* Check that IDX is a valid offset into the `constants' vector */
+ − 1669 static void
+ − 1670 check_constants_index (int idx, Lisp_Object constants)
+ − 1671 {
+ − 1672 if (idx < 0 || idx >= XVECTOR_LENGTH (constants))
563
+ − 1673 signal_ferror
+ − 1674 (Qinvalid_byte_code,
+ − 1675 "reference %d to constants array out of range 0, %ld",
428
+ − 1676 idx, XVECTOR_LENGTH (constants) - 1);
+ − 1677 }
+ − 1678
+ − 1679 /* Get next character from Lisp instructions string. */
563
+ − 1680 #define READ_INSTRUCTION_CHAR(lvalue) do { \
867
+ − 1681 (lvalue) = itext_ichar (ptr); \
+ − 1682 INC_IBYTEPTR (ptr); \
563
+ − 1683 *icounts_ptr++ = program_ptr - program; \
+ − 1684 if (lvalue > UCHAR_MAX) \
+ − 1685 invalid_byte_code \
+ − 1686 ("Invalid character in byte code string", make_char (lvalue)); \
428
+ − 1687 } while (0)
+ − 1688
+ − 1689 /* Get opcode from Lisp instructions string. */
+ − 1690 #define READ_OPCODE do { \
+ − 1691 unsigned int c; \
+ − 1692 READ_INSTRUCTION_CHAR (c); \
+ − 1693 opcode = (Opcode) c; \
+ − 1694 } while (0)
+ − 1695
+ − 1696 /* Get next operand, a uint8, from Lisp instructions string. */
+ − 1697 #define READ_OPERAND_1 do { \
+ − 1698 READ_INSTRUCTION_CHAR (arg); \
+ − 1699 argsize = 1; \
+ − 1700 } while (0)
+ − 1701
+ − 1702 /* Get next operand, a uint16, from Lisp instructions string. */
+ − 1703 #define READ_OPERAND_2 do { \
+ − 1704 unsigned int arg1, arg2; \
+ − 1705 READ_INSTRUCTION_CHAR (arg1); \
+ − 1706 READ_INSTRUCTION_CHAR (arg2); \
+ − 1707 arg = arg1 + (arg2 << 8); \
+ − 1708 argsize = 2; \
+ − 1709 } while (0)
+ − 1710
+ − 1711 /* Write 1 byte to PTR, incrementing PTR */
+ − 1712 #define WRITE_INT8(value, ptr) do { \
+ − 1713 *((ptr)++) = (value); \
+ − 1714 } while (0)
+ − 1715
+ − 1716 /* Write 2 bytes to PTR, incrementing PTR */
+ − 1717 #define WRITE_INT16(value, ptr) do { \
+ − 1718 WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \
+ − 1719 WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \
+ − 1720 } while (0)
+ − 1721
+ − 1722 /* We've changed our minds about the opcode we've already written. */
+ − 1723 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
+ − 1724
+ − 1725 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
+ − 1726 #define WRITE_NARGS(base_opcode) do { \
+ − 1727 if (arg <= 5) \
+ − 1728 { \
+ − 1729 REWRITE_OPCODE (base_opcode + arg); \
+ − 1730 } \
+ − 1731 else if (arg <= UCHAR_MAX) \
+ − 1732 { \
+ − 1733 REWRITE_OPCODE (base_opcode + 6); \
+ − 1734 WRITE_INT8 (arg, program_ptr); \
+ − 1735 } \
+ − 1736 else \
+ − 1737 { \
+ − 1738 REWRITE_OPCODE (base_opcode + 7); \
+ − 1739 WRITE_INT16 (arg, program_ptr); \
+ − 1740 } \
+ − 1741 } while (0)
+ − 1742
+ − 1743 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
+ − 1744 #define WRITE_CONSTANT do { \
+ − 1745 check_constants_index(arg, constants); \
+ − 1746 if (arg <= UCHAR_MAX - Bconstant) \
+ − 1747 { \
+ − 1748 REWRITE_OPCODE (Bconstant + arg); \
+ − 1749 } \
+ − 1750 else \
+ − 1751 { \
+ − 1752 REWRITE_OPCODE (Bconstant2); \
+ − 1753 WRITE_INT16 (arg, program_ptr); \
+ − 1754 } \
+ − 1755 } while (0)
+ − 1756
+ − 1757 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
+ − 1758
+ − 1759 /* Compile byte code instructions into free space provided by caller, with
+ − 1760 size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
+ − 1761 Returns length of compiled code. */
+ − 1762 static void
+ − 1763 optimize_byte_code (/* in */
+ − 1764 Lisp_Object instructions,
+ − 1765 Lisp_Object constants,
+ − 1766 /* out */
442
+ − 1767 Opbyte * const program,
+ − 1768 int * const program_length,
+ − 1769 int * const varbind_count)
428
+ − 1770 {
647
+ − 1771 Bytecount instructions_length = XSTRING_LENGTH (instructions);
665
+ − 1772 Elemcount comfy_size = (Elemcount) (2 * instructions_length);
428
+ − 1773
442
+ − 1774 int * const icounts = alloca_array (int, comfy_size);
428
+ − 1775 int * icounts_ptr = icounts;
+ − 1776
+ − 1777 /* We maintain a table of jumps in the source code. */
+ − 1778 struct jump
+ − 1779 {
+ − 1780 int from;
+ − 1781 int to;
+ − 1782 };
442
+ − 1783 struct jump * const jumps = alloca_array (struct jump, comfy_size);
428
+ − 1784 struct jump *jumps_ptr = jumps;
+ − 1785
+ − 1786 Opbyte *program_ptr = program;
+ − 1787
867
+ − 1788 const Ibyte *ptr = XSTRING_DATA (instructions);
+ − 1789 const Ibyte * const end = ptr + instructions_length;
428
+ − 1790
+ − 1791 *varbind_count = 0;
+ − 1792
+ − 1793 while (ptr < end)
+ − 1794 {
+ − 1795 Opcode opcode;
+ − 1796 int arg;
+ − 1797 int argsize = 0;
+ − 1798 READ_OPCODE;
+ − 1799 WRITE_OPCODE;
+ − 1800
+ − 1801 switch (opcode)
+ − 1802 {
+ − 1803 Lisp_Object val;
+ − 1804
+ − 1805 case Bvarref+7: READ_OPERAND_2; goto do_varref;
+ − 1806 case Bvarref+6: READ_OPERAND_1; goto do_varref;
+ − 1807 case Bvarref: case Bvarref+1: case Bvarref+2:
+ − 1808 case Bvarref+3: case Bvarref+4: case Bvarref+5:
+ − 1809 arg = opcode - Bvarref;
+ − 1810 do_varref:
+ − 1811 check_constants_index (arg, constants);
+ − 1812 val = XVECTOR_DATA (constants) [arg];
+ − 1813 if (!SYMBOLP (val))
563
+ − 1814 invalid_byte_code ("variable reference to non-symbol", val);
428
+ − 1815 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
563
+ − 1816 invalid_byte_code ("variable reference to constant symbol", val);
428
+ − 1817 WRITE_NARGS (Bvarref);
+ − 1818 break;
+ − 1819
+ − 1820 case Bvarset+7: READ_OPERAND_2; goto do_varset;
+ − 1821 case Bvarset+6: READ_OPERAND_1; goto do_varset;
+ − 1822 case Bvarset: case Bvarset+1: case Bvarset+2:
+ − 1823 case Bvarset+3: case Bvarset+4: case Bvarset+5:
+ − 1824 arg = opcode - Bvarset;
+ − 1825 do_varset:
+ − 1826 check_constants_index (arg, constants);
+ − 1827 val = XVECTOR_DATA (constants) [arg];
+ − 1828 if (!SYMBOLP (val))
563
+ − 1829 wtaerror ("attempt to set non-symbol", val);
428
+ − 1830 if (EQ (val, Qnil) || EQ (val, Qt))
563
+ − 1831 signal_error (Qsetting_constant, 0, val);
428
+ − 1832 /* Ignore assignments to keywords by converting to Bdiscard.
+ − 1833 For backward compatibility only - we'd like to make this an error. */
+ − 1834 if (SYMBOL_IS_KEYWORD (val))
+ − 1835 REWRITE_OPCODE (Bdiscard);
+ − 1836 else
+ − 1837 WRITE_NARGS (Bvarset);
+ − 1838 break;
+ − 1839
+ − 1840 case Bvarbind+7: READ_OPERAND_2; goto do_varbind;
+ − 1841 case Bvarbind+6: READ_OPERAND_1; goto do_varbind;
+ − 1842 case Bvarbind: case Bvarbind+1: case Bvarbind+2:
+ − 1843 case Bvarbind+3: case Bvarbind+4: case Bvarbind+5:
+ − 1844 arg = opcode - Bvarbind;
+ − 1845 do_varbind:
+ − 1846 (*varbind_count)++;
+ − 1847 check_constants_index (arg, constants);
+ − 1848 val = XVECTOR_DATA (constants) [arg];
+ − 1849 if (!SYMBOLP (val))
563
+ − 1850 wtaerror ("attempt to let-bind non-symbol", val);
428
+ − 1851 if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val)))
563
+ − 1852 signal_error (Qsetting_constant,
+ − 1853 "attempt to let-bind constant symbol", val);
428
+ − 1854 WRITE_NARGS (Bvarbind);
+ − 1855 break;
+ − 1856
+ − 1857 case Bcall+7: READ_OPERAND_2; goto do_call;
+ − 1858 case Bcall+6: READ_OPERAND_1; goto do_call;
+ − 1859 case Bcall: case Bcall+1: case Bcall+2:
+ − 1860 case Bcall+3: case Bcall+4: case Bcall+5:
+ − 1861 arg = opcode - Bcall;
+ − 1862 do_call:
+ − 1863 WRITE_NARGS (Bcall);
+ − 1864 break;
+ − 1865
+ − 1866 case Bunbind+7: READ_OPERAND_2; goto do_unbind;
+ − 1867 case Bunbind+6: READ_OPERAND_1; goto do_unbind;
+ − 1868 case Bunbind: case Bunbind+1: case Bunbind+2:
+ − 1869 case Bunbind+3: case Bunbind+4: case Bunbind+5:
+ − 1870 arg = opcode - Bunbind;
+ − 1871 do_unbind:
+ − 1872 WRITE_NARGS (Bunbind);
+ − 1873 break;
+ − 1874
+ − 1875 case Bgoto:
+ − 1876 case Bgotoifnil:
+ − 1877 case Bgotoifnonnil:
+ − 1878 case Bgotoifnilelsepop:
+ − 1879 case Bgotoifnonnilelsepop:
+ − 1880 READ_OPERAND_2;
+ − 1881 /* Make program_ptr-relative */
+ − 1882 arg += icounts - (icounts_ptr - argsize);
+ − 1883 goto do_jump;
+ − 1884
+ − 1885 case BRgoto:
+ − 1886 case BRgotoifnil:
+ − 1887 case BRgotoifnonnil:
+ − 1888 case BRgotoifnilelsepop:
+ − 1889 case BRgotoifnonnilelsepop:
+ − 1890 READ_OPERAND_1;
+ − 1891 /* Make program_ptr-relative */
+ − 1892 arg -= 127;
+ − 1893 do_jump:
+ − 1894 /* Record program-relative goto addresses in `jumps' table */
+ − 1895 jumps_ptr->from = icounts_ptr - icounts - argsize;
+ − 1896 jumps_ptr->to = jumps_ptr->from + arg;
+ − 1897 jumps_ptr++;
+ − 1898 if (arg >= -1 && arg <= argsize)
563
+ − 1899 invalid_byte_code ("goto instruction is its own target", Qunbound);
428
+ − 1900 if (arg <= SCHAR_MIN ||
+ − 1901 arg > SCHAR_MAX)
+ − 1902 {
+ − 1903 if (argsize == 1)
+ − 1904 REWRITE_OPCODE (opcode + Bgoto - BRgoto);
+ − 1905 WRITE_INT16 (arg, program_ptr);
+ − 1906 }
+ − 1907 else
+ − 1908 {
+ − 1909 if (argsize == 2)
+ − 1910 REWRITE_OPCODE (opcode + BRgoto - Bgoto);
+ − 1911 WRITE_INT8 (arg, program_ptr);
+ − 1912 }
+ − 1913 break;
+ − 1914
+ − 1915 case Bconstant2:
+ − 1916 READ_OPERAND_2;
+ − 1917 WRITE_CONSTANT;
+ − 1918 break;
+ − 1919
+ − 1920 case BlistN:
+ − 1921 case BconcatN:
+ − 1922 case BinsertN:
+ − 1923 READ_OPERAND_1;
+ − 1924 WRITE_INT8 (arg, program_ptr);
+ − 1925 break;
+ − 1926
+ − 1927 default:
+ − 1928 if (opcode < Bconstant)
+ − 1929 check_opcode (opcode);
+ − 1930 else
+ − 1931 {
+ − 1932 arg = opcode - Bconstant;
+ − 1933 WRITE_CONSTANT;
+ − 1934 }
+ − 1935 break;
+ − 1936 }
+ − 1937 }
+ − 1938
+ − 1939 /* Fix up jumps table to refer to NEW offsets. */
+ − 1940 {
+ − 1941 struct jump *j;
+ − 1942 for (j = jumps; j < jumps_ptr; j++)
+ − 1943 {
+ − 1944 #ifdef ERROR_CHECK_BYTE_CODE
+ − 1945 assert (j->from < icounts_ptr - icounts);
+ − 1946 assert (j->to < icounts_ptr - icounts);
+ − 1947 #endif
+ − 1948 j->from = icounts[j->from];
+ − 1949 j->to = icounts[j->to];
+ − 1950 #ifdef ERROR_CHECK_BYTE_CODE
+ − 1951 assert (j->from < program_ptr - program);
+ − 1952 assert (j->to < program_ptr - program);
+ − 1953 check_opcode ((Opcode) (program[j->from-1]));
+ − 1954 #endif
+ − 1955 check_opcode ((Opcode) (program[j->to]));
+ − 1956 }
+ − 1957 }
+ − 1958
+ − 1959 /* Fixup jumps in byte-code until no more fixups needed */
+ − 1960 {
+ − 1961 int more_fixups_needed = 1;
+ − 1962
+ − 1963 while (more_fixups_needed)
+ − 1964 {
+ − 1965 struct jump *j;
+ − 1966 more_fixups_needed = 0;
+ − 1967 for (j = jumps; j < jumps_ptr; j++)
+ − 1968 {
+ − 1969 int from = j->from;
+ − 1970 int to = j->to;
+ − 1971 int jump = to - from;
+ − 1972 Opbyte *p = program + from;
+ − 1973 Opcode opcode = (Opcode) p[-1];
+ − 1974 if (!more_fixups_needed)
+ − 1975 check_opcode ((Opcode) p[jump]);
+ − 1976 assert (to >= 0 && program + to < program_ptr);
+ − 1977 switch (opcode)
+ − 1978 {
+ − 1979 case Bgoto:
+ − 1980 case Bgotoifnil:
+ − 1981 case Bgotoifnonnil:
+ − 1982 case Bgotoifnilelsepop:
+ − 1983 case Bgotoifnonnilelsepop:
+ − 1984 WRITE_INT16 (jump, p);
+ − 1985 break;
+ − 1986
+ − 1987 case BRgoto:
+ − 1988 case BRgotoifnil:
+ − 1989 case BRgotoifnonnil:
+ − 1990 case BRgotoifnilelsepop:
+ − 1991 case BRgotoifnonnilelsepop:
+ − 1992 if (jump > SCHAR_MIN &&
+ − 1993 jump <= SCHAR_MAX)
+ − 1994 {
+ − 1995 WRITE_INT8 (jump, p);
+ − 1996 }
+ − 1997 else /* barf */
+ − 1998 {
+ − 1999 struct jump *jj;
+ − 2000 for (jj = jumps; jj < jumps_ptr; jj++)
+ − 2001 {
+ − 2002 assert (jj->from < program_ptr - program);
+ − 2003 assert (jj->to < program_ptr - program);
+ − 2004 if (jj->from > from) jj->from++;
+ − 2005 if (jj->to > from) jj->to++;
+ − 2006 }
+ − 2007 p[-1] += Bgoto - BRgoto;
+ − 2008 more_fixups_needed = 1;
+ − 2009 memmove (p+1, p, program_ptr++ - p);
+ − 2010 WRITE_INT16 (jump, p);
+ − 2011 }
+ − 2012 break;
+ − 2013
+ − 2014 default:
2500
+ − 2015 ABORT();
428
+ − 2016 break;
+ − 2017 }
+ − 2018 }
+ − 2019 }
+ − 2020 }
+ − 2021
+ − 2022 /* *program_ptr++ = 0; */
+ − 2023 *program_length = program_ptr - program;
+ − 2024 }
+ − 2025
+ − 2026 /* Optimize the byte code and store the optimized program, only
+ − 2027 understood by bytecode.c, in an opaque object in the
+ − 2028 instructions slot of the Compiled_Function object. */
+ − 2029 void
+ − 2030 optimize_compiled_function (Lisp_Object compiled_function)
+ − 2031 {
+ − 2032 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function);
+ − 2033 int program_length;
+ − 2034 int varbind_count;
+ − 2035 Opbyte *program;
+ − 2036
1737
+ − 2037 {
+ − 2038 int minargs = 0, maxargs = 0, totalargs = 0;
+ − 2039 int optional_p = 0, rest_p = 0, i = 0;
+ − 2040 {
+ − 2041 LIST_LOOP_2 (arg, f->arglist)
+ − 2042 {
+ − 2043 if (EQ (arg, Qand_optional))
+ − 2044 optional_p = 1;
+ − 2045 else if (EQ (arg, Qand_rest))
+ − 2046 rest_p = 1;
+ − 2047 else
+ − 2048 {
+ − 2049 if (rest_p)
+ − 2050 {
+ − 2051 maxargs = MANY;
+ − 2052 totalargs++;
+ − 2053 break;
+ − 2054 }
+ − 2055 if (!optional_p)
+ − 2056 minargs++;
+ − 2057 maxargs++;
+ − 2058 totalargs++;
+ − 2059 }
+ − 2060 }
+ − 2061 }
+ − 2062
+ − 2063 if (totalargs)
3092
+ − 2064 #ifdef NEW_GC
+ − 2065 f->arguments = make_compiled_function_args (totalargs);
+ − 2066 #else /* not NEW_GC */
1737
+ − 2067 f->args = xnew_array (Lisp_Object, totalargs);
3092
+ − 2068 #endif /* not NEW_GC */
1737
+ − 2069
+ − 2070 {
+ − 2071 LIST_LOOP_2 (arg, f->arglist)
+ − 2072 {
+ − 2073 if (!EQ (arg, Qand_optional) && !EQ (arg, Qand_rest))
3092
+ − 2074 #ifdef NEW_GC
+ − 2075 XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i++] = arg;
+ − 2076 #else /* not NEW_GC */
1737
+ − 2077 f->args[i++] = arg;
3092
+ − 2078 #endif /* not NEW_GC */
1737
+ − 2079 }
+ − 2080 }
+ − 2081
+ − 2082 f->max_args = maxargs;
+ − 2083 f->min_args = minargs;
+ − 2084 f->args_in_array = totalargs;
+ − 2085 }
+ − 2086
428
+ − 2087 /* If we have not actually read the bytecode string
+ − 2088 and constants vector yet, fetch them from the file. */
+ − 2089 if (CONSP (f->instructions))
+ − 2090 Ffetch_bytecode (compiled_function);
+ − 2091
+ − 2092 if (STRINGP (f->instructions))
+ − 2093 {
826
+ − 2094 /* XSTRING_LENGTH() is more efficient than string_char_length(),
428
+ − 2095 which would be slightly more `proper' */
+ − 2096 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
+ − 2097 optimize_byte_code (f->instructions, f->constants,
+ − 2098 program, &program_length, &varbind_count);
2500
+ − 2099 f->specpdl_depth = (unsigned short) (XINT (Flength (f->arglist)) +
+ − 2100 varbind_count);
428
+ − 2101 f->instructions =
440
+ − 2102 make_opaque (program, program_length * sizeof (Opbyte));
428
+ − 2103 }
+ − 2104
+ − 2105 assert (OPAQUEP (f->instructions));
+ − 2106 }
+ − 2107
+ − 2108 /************************************************************************/
+ − 2109 /* The compiled-function object type */
+ − 2110 /************************************************************************/
3092
+ − 2111
428
+ − 2112 static void
+ − 2113 print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun,
+ − 2114 int escapeflag)
+ − 2115 {
+ − 2116 /* This function can GC */
+ − 2117 Lisp_Compiled_Function *f =
+ − 2118 XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */
+ − 2119 int docp = f->flags.documentationp;
+ − 2120 int intp = f->flags.interactivep;
+ − 2121 struct gcpro gcpro1, gcpro2;
+ − 2122 GCPRO2 (obj, printcharfun);
+ − 2123
826
+ − 2124 write_c_string (printcharfun, print_readably ? "#[" : "#<compiled-function ");
428
+ − 2125 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ − 2126 if (!print_readably)
+ − 2127 {
+ − 2128 Lisp_Object ann = compiled_function_annotation (f);
+ − 2129 if (!NILP (ann))
800
+ − 2130 write_fmt_string_lisp (printcharfun, "(from %S) ", 1, ann);
428
+ − 2131 }
+ − 2132 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
+ − 2133 /* COMPILED_ARGLIST = 0 */
+ − 2134 print_internal (compiled_function_arglist (f), printcharfun, escapeflag);
+ − 2135
+ − 2136 /* COMPILED_INSTRUCTIONS = 1 */
826
+ − 2137 write_c_string (printcharfun, " ");
428
+ − 2138 {
+ − 2139 struct gcpro ngcpro1;
+ − 2140 Lisp_Object instructions = compiled_function_instructions (f);
+ − 2141 NGCPRO1 (instructions);
+ − 2142 if (STRINGP (instructions) && !print_readably)
+ − 2143 {
+ − 2144 /* We don't usually want to see that junk in the bytecode. */
800
+ − 2145 write_fmt_string (printcharfun, "\"...(%ld)\"",
826
+ − 2146 (long) string_char_length (instructions));
428
+ − 2147 }
+ − 2148 else
+ − 2149 print_internal (instructions, printcharfun, escapeflag);
+ − 2150 NUNGCPRO;
+ − 2151 }
+ − 2152
+ − 2153 /* COMPILED_CONSTANTS = 2 */
826
+ − 2154 write_c_string (printcharfun, " ");
428
+ − 2155 print_internal (compiled_function_constants (f), printcharfun, escapeflag);
+ − 2156
+ − 2157 /* COMPILED_STACK_DEPTH = 3 */
800
+ − 2158 write_fmt_string (printcharfun, " %d", compiled_function_stack_depth (f));
428
+ − 2159
+ − 2160 /* COMPILED_DOC_STRING = 4 */
+ − 2161 if (docp || intp)
+ − 2162 {
826
+ − 2163 write_c_string (printcharfun, " ");
428
+ − 2164 print_internal (compiled_function_documentation (f), printcharfun,
+ − 2165 escapeflag);
+ − 2166 }
+ − 2167
+ − 2168 /* COMPILED_INTERACTIVE = 5 */
+ − 2169 if (intp)
+ − 2170 {
826
+ − 2171 write_c_string (printcharfun, " ");
428
+ − 2172 print_internal (compiled_function_interactive (f), printcharfun,
+ − 2173 escapeflag);
+ − 2174 }
+ − 2175
+ − 2176 UNGCPRO;
826
+ − 2177 write_c_string (printcharfun, print_readably ? "]" : ">");
428
+ − 2178 }
+ − 2179
+ − 2180
+ − 2181 static Lisp_Object
+ − 2182 mark_compiled_function (Lisp_Object obj)
+ − 2183 {
+ − 2184 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
814
+ − 2185 int i;
428
+ − 2186
+ − 2187 mark_object (f->instructions);
+ − 2188 mark_object (f->arglist);
+ − 2189 mark_object (f->doc_and_interactive);
+ − 2190 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ − 2191 mark_object (f->annotated);
+ − 2192 #endif
814
+ − 2193 for (i = 0; i < f->args_in_array; i++)
3092
+ − 2194 #ifdef NEW_GC
+ − 2195 mark_object (XCOMPILED_FUNCTION_ARGS_DATA (f->arguments)[i]);
+ − 2196 #else /* not NEW_GC */
814
+ − 2197 mark_object (f->args[i]);
3092
+ − 2198 #endif /* not NEW_GC */
814
+ − 2199
428
+ − 2200 /* tail-recurse on constants */
+ − 2201 return f->constants;
+ − 2202 }
+ − 2203
+ − 2204 static int
+ − 2205 compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+ − 2206 {
+ − 2207 Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1);
+ − 2208 Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2);
+ − 2209 return
+ − 2210 (f1->flags.documentationp == f2->flags.documentationp &&
+ − 2211 f1->flags.interactivep == f2->flags.interactivep &&
+ − 2212 f1->flags.domainp == f2->flags.domainp && /* I18N3 */
+ − 2213 internal_equal (compiled_function_instructions (f1),
+ − 2214 compiled_function_instructions (f2), depth + 1) &&
+ − 2215 internal_equal (f1->constants, f2->constants, depth + 1) &&
+ − 2216 internal_equal (f1->arglist, f2->arglist, depth + 1) &&
+ − 2217 internal_equal (f1->doc_and_interactive,
+ − 2218 f2->doc_and_interactive, depth + 1));
+ − 2219 }
+ − 2220
665
+ − 2221 static Hashcode
428
+ − 2222 compiled_function_hash (Lisp_Object obj, int depth)
+ − 2223 {
+ − 2224 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
+ − 2225 return HASH3 ((f->flags.documentationp << 2) +
+ − 2226 (f->flags.interactivep << 1) +
+ − 2227 f->flags.domainp,
+ − 2228 internal_hash (f->instructions, depth + 1),
+ − 2229 internal_hash (f->constants, depth + 1));
+ − 2230 }
+ − 2231
1204
+ − 2232 static const struct memory_description compiled_function_description[] = {
814
+ − 2233 { XD_INT, offsetof (Lisp_Compiled_Function, args_in_array) },
3092
+ − 2234 #ifdef NEW_GC
+ − 2235 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arguments) },
+ − 2236 #else /* not NEW_GC */
+ − 2237 { XD_BLOCK_PTR, offsetof (Lisp_Compiled_Function, args),
2551
+ − 2238 XD_INDIRECT (0, 0), { &lisp_object_description } },
3092
+ − 2239 #endif /* not NEW_GC */
440
+ − 2240 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, instructions) },
+ − 2241 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, constants) },
+ − 2242 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, arglist) },
+ − 2243 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, doc_and_interactive) },
428
+ − 2244 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
440
+ − 2245 { XD_LISP_OBJECT, offsetof (Lisp_Compiled_Function, annotated) },
428
+ − 2246 #endif
+ − 2247 { XD_END }
+ − 2248 };
+ − 2249
934
+ − 2250 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function,
+ − 2251 1, /*dumpable_flag*/
+ − 2252 mark_compiled_function,
+ − 2253 print_compiled_function, 0,
+ − 2254 compiled_function_equal,
+ − 2255 compiled_function_hash,
+ − 2256 compiled_function_description,
+ − 2257 Lisp_Compiled_Function);
3092
+ − 2258
428
+ − 2259
+ − 2260 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
+ − 2261 Return t if OBJECT is a byte-compiled function object.
+ − 2262 */
+ − 2263 (object))
+ − 2264 {
+ − 2265 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
+ − 2266 }
+ − 2267
+ − 2268 /************************************************************************/
+ − 2269 /* compiled-function object accessor functions */
+ − 2270 /************************************************************************/
+ − 2271
+ − 2272 Lisp_Object
+ − 2273 compiled_function_arglist (Lisp_Compiled_Function *f)
+ − 2274 {
+ − 2275 return f->arglist;
+ − 2276 }
+ − 2277
+ − 2278 Lisp_Object
+ − 2279 compiled_function_instructions (Lisp_Compiled_Function *f)
+ − 2280 {
+ − 2281 if (! OPAQUEP (f->instructions))
+ − 2282 return f->instructions;
+ − 2283
+ − 2284 {
+ − 2285 /* Invert action performed by optimize_byte_code() */
+ − 2286 Lisp_Opaque *opaque = XOPAQUE (f->instructions);
+ − 2287
867
+ − 2288 Ibyte * const buffer =
2367
+ − 2289 alloca_ibytes (OPAQUE_SIZE (opaque) * MAX_ICHAR_LEN);
867
+ − 2290 Ibyte *bp = buffer;
428
+ − 2291
442
+ − 2292 const Opbyte * const program = (const Opbyte *) OPAQUE_DATA (opaque);
+ − 2293 const Opbyte *program_ptr = program;
+ − 2294 const Opbyte * const program_end = program_ptr + OPAQUE_SIZE (opaque);
428
+ − 2295
+ − 2296 while (program_ptr < program_end)
+ − 2297 {
+ − 2298 Opcode opcode = (Opcode) READ_UINT_1;
867
+ − 2299 bp += set_itext_ichar (bp, opcode);
428
+ − 2300 switch (opcode)
+ − 2301 {
+ − 2302 case Bvarref+7:
+ − 2303 case Bvarset+7:
+ − 2304 case Bvarbind+7:
+ − 2305 case Bcall+7:
+ − 2306 case Bunbind+7:
+ − 2307 case Bconstant2:
867
+ − 2308 bp += set_itext_ichar (bp, READ_UINT_1);
+ − 2309 bp += set_itext_ichar (bp, READ_UINT_1);
428
+ − 2310 break;
+ − 2311
+ − 2312 case Bvarref+6:
+ − 2313 case Bvarset+6:
+ − 2314 case Bvarbind+6:
+ − 2315 case Bcall+6:
+ − 2316 case Bunbind+6:
+ − 2317 case BlistN:
+ − 2318 case BconcatN:
+ − 2319 case BinsertN:
867
+ − 2320 bp += set_itext_ichar (bp, READ_UINT_1);
428
+ − 2321 break;
+ − 2322
+ − 2323 case Bgoto:
+ − 2324 case Bgotoifnil:
+ − 2325 case Bgotoifnonnil:
+ − 2326 case Bgotoifnilelsepop:
+ − 2327 case Bgotoifnonnilelsepop:
+ − 2328 {
+ − 2329 int jump = READ_INT_2;
+ − 2330 Opbyte buf2[2];
+ − 2331 Opbyte *buf2p = buf2;
+ − 2332 /* Convert back to program-relative address */
+ − 2333 WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p);
867
+ − 2334 bp += set_itext_ichar (bp, buf2[0]);
+ − 2335 bp += set_itext_ichar (bp, buf2[1]);
428
+ − 2336 break;
+ − 2337 }
+ − 2338
+ − 2339 case BRgoto:
+ − 2340 case BRgotoifnil:
+ − 2341 case BRgotoifnonnil:
+ − 2342 case BRgotoifnilelsepop:
+ − 2343 case BRgotoifnonnilelsepop:
867
+ − 2344 bp += set_itext_ichar (bp, READ_INT_1 + 127);
428
+ − 2345 break;
+ − 2346
+ − 2347 default:
+ − 2348 break;
+ − 2349 }
+ − 2350 }
+ − 2351 return make_string (buffer, bp - buffer);
+ − 2352 }
+ − 2353 }
+ − 2354
+ − 2355 Lisp_Object
+ − 2356 compiled_function_constants (Lisp_Compiled_Function *f)
+ − 2357 {
+ − 2358 return f->constants;
+ − 2359 }
+ − 2360
+ − 2361 int
+ − 2362 compiled_function_stack_depth (Lisp_Compiled_Function *f)
+ − 2363 {
+ − 2364 return f->stack_depth;
+ − 2365 }
+ − 2366
+ − 2367 /* The compiled_function->doc_and_interactive slot uses the minimal
+ − 2368 number of conses, based on compiled_function->flags; it may take
+ − 2369 any of the following forms:
+ − 2370
+ − 2371 doc
+ − 2372 interactive
+ − 2373 domain
+ − 2374 (doc . interactive)
+ − 2375 (doc . domain)
+ − 2376 (interactive . domain)
+ − 2377 (doc . (interactive . domain))
+ − 2378 */
+ − 2379
+ − 2380 /* Caller must check flags.interactivep first */
+ − 2381 Lisp_Object
+ − 2382 compiled_function_interactive (Lisp_Compiled_Function *f)
+ − 2383 {
+ − 2384 assert (f->flags.interactivep);
+ − 2385 if (f->flags.documentationp && f->flags.domainp)
+ − 2386 return XCAR (XCDR (f->doc_and_interactive));
+ − 2387 else if (f->flags.documentationp)
+ − 2388 return XCDR (f->doc_and_interactive);
+ − 2389 else if (f->flags.domainp)
+ − 2390 return XCAR (f->doc_and_interactive);
+ − 2391 else
+ − 2392 return f->doc_and_interactive;
+ − 2393 }
+ − 2394
+ − 2395 /* Caller need not check flags.documentationp first */
+ − 2396 Lisp_Object
+ − 2397 compiled_function_documentation (Lisp_Compiled_Function *f)
+ − 2398 {
+ − 2399 if (! f->flags.documentationp)
+ − 2400 return Qnil;
+ − 2401 else if (f->flags.interactivep && f->flags.domainp)
+ − 2402 return XCAR (f->doc_and_interactive);
+ − 2403 else if (f->flags.interactivep)
+ − 2404 return XCAR (f->doc_and_interactive);
+ − 2405 else if (f->flags.domainp)
+ − 2406 return XCAR (f->doc_and_interactive);
+ − 2407 else
+ − 2408 return f->doc_and_interactive;
+ − 2409 }
+ − 2410
+ − 2411 /* Caller need not check flags.domainp first */
+ − 2412 Lisp_Object
+ − 2413 compiled_function_domain (Lisp_Compiled_Function *f)
+ − 2414 {
+ − 2415 if (! f->flags.domainp)
+ − 2416 return Qnil;
+ − 2417 else if (f->flags.documentationp && f->flags.interactivep)
+ − 2418 return XCDR (XCDR (f->doc_and_interactive));
+ − 2419 else if (f->flags.documentationp)
+ − 2420 return XCDR (f->doc_and_interactive);
+ − 2421 else if (f->flags.interactivep)
+ − 2422 return XCDR (f->doc_and_interactive);
+ − 2423 else
+ − 2424 return f->doc_and_interactive;
+ − 2425 }
+ − 2426
+ − 2427 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ − 2428
+ − 2429 Lisp_Object
+ − 2430 compiled_function_annotation (Lisp_Compiled_Function *f)
+ − 2431 {
+ − 2432 return f->annotated;
+ − 2433 }
+ − 2434
+ − 2435 #endif
+ − 2436
+ − 2437 /* used only by Snarf-documentation; there must be doc already. */
+ − 2438 void
+ − 2439 set_compiled_function_documentation (Lisp_Compiled_Function *f,
+ − 2440 Lisp_Object new_doc)
+ − 2441 {
+ − 2442 assert (f->flags.documentationp);
+ − 2443 assert (INTP (new_doc) || STRINGP (new_doc));
+ − 2444
+ − 2445 if (f->flags.interactivep && f->flags.domainp)
+ − 2446 XCAR (f->doc_and_interactive) = new_doc;
+ − 2447 else if (f->flags.interactivep)
+ − 2448 XCAR (f->doc_and_interactive) = new_doc;
+ − 2449 else if (f->flags.domainp)
+ − 2450 XCAR (f->doc_and_interactive) = new_doc;
+ − 2451 else
+ − 2452 f->doc_and_interactive = new_doc;
+ − 2453 }
+ − 2454
+ − 2455
+ − 2456 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
+ − 2457 Return the argument list of the compiled-function object FUNCTION.
+ − 2458 */
+ − 2459 (function))
+ − 2460 {
+ − 2461 CHECK_COMPILED_FUNCTION (function);
+ − 2462 return compiled_function_arglist (XCOMPILED_FUNCTION (function));
+ − 2463 }
+ − 2464
+ − 2465 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
+ − 2466 Return the byte-opcode string of the compiled-function object FUNCTION.
+ − 2467 */
+ − 2468 (function))
+ − 2469 {
+ − 2470 CHECK_COMPILED_FUNCTION (function);
+ − 2471 return compiled_function_instructions (XCOMPILED_FUNCTION (function));
+ − 2472 }
+ − 2473
+ − 2474 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
+ − 2475 Return the constants vector of the compiled-function object FUNCTION.
+ − 2476 */
+ − 2477 (function))
+ − 2478 {
+ − 2479 CHECK_COMPILED_FUNCTION (function);
+ − 2480 return compiled_function_constants (XCOMPILED_FUNCTION (function));
+ − 2481 }
+ − 2482
+ − 2483 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
444
+ − 2484 Return the maximum stack depth of the compiled-function object FUNCTION.
428
+ − 2485 */
+ − 2486 (function))
+ − 2487 {
+ − 2488 CHECK_COMPILED_FUNCTION (function);
+ − 2489 return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function)));
+ − 2490 }
+ − 2491
+ − 2492 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
+ − 2493 Return the doc string of the compiled-function object FUNCTION, if available.
+ − 2494 Functions that had their doc strings snarfed into the DOC file will have
+ − 2495 an integer returned instead of a string.
+ − 2496 */
+ − 2497 (function))
+ − 2498 {
+ − 2499 CHECK_COMPILED_FUNCTION (function);
+ − 2500 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
+ − 2501 }
+ − 2502
+ − 2503 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
+ − 2504 Return the interactive spec of the compiled-function object FUNCTION, or nil.
+ − 2505 If non-nil, the return value will be a list whose first element is
+ − 2506 `interactive' and whose second element is the interactive spec.
+ − 2507 */
+ − 2508 (function))
+ − 2509 {
+ − 2510 CHECK_COMPILED_FUNCTION (function);
+ − 2511 return XCOMPILED_FUNCTION (function)->flags.interactivep
+ − 2512 ? list2 (Qinteractive,
+ − 2513 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
+ − 2514 : Qnil;
+ − 2515 }
+ − 2516
+ − 2517 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ − 2518
826
+ − 2519 DEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
428
+ − 2520 Return the annotation of the compiled-function object FUNCTION, or nil.
+ − 2521 The annotation is a piece of information indicating where this
+ − 2522 compiled-function object came from. Generally this will be
+ − 2523 a symbol naming a function; or a string naming a file, if the
+ − 2524 compiled-function object was not defined in a function; or nil,
+ − 2525 if the compiled-function object was not created as a result of
+ − 2526 a `load'.
+ − 2527 */
+ − 2528 (function))
+ − 2529 {
+ − 2530 CHECK_COMPILED_FUNCTION (function);
+ − 2531 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
+ − 2532 }
+ − 2533
+ − 2534 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
+ − 2535
+ − 2536 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
+ − 2537 Return the domain of the compiled-function object FUNCTION, or nil.
+ − 2538 This is only meaningful if I18N3 was enabled when emacs was compiled.
+ − 2539 */
+ − 2540 (function))
+ − 2541 {
+ − 2542 CHECK_COMPILED_FUNCTION (function);
+ − 2543 return XCOMPILED_FUNCTION (function)->flags.domainp
+ − 2544 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
+ − 2545 : Qnil;
+ − 2546 }
+ − 2547
+ − 2548
+ − 2549
+ − 2550 DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /*
+ − 2551 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
+ − 2552 */
+ − 2553 (function))
+ − 2554 {
+ − 2555 Lisp_Compiled_Function *f;
+ − 2556 CHECK_COMPILED_FUNCTION (function);
+ − 2557 f = XCOMPILED_FUNCTION (function);
+ − 2558
+ − 2559 if (OPAQUEP (f->instructions) || STRINGP (f->instructions))
+ − 2560 return function;
+ − 2561
+ − 2562 if (CONSP (f->instructions))
+ − 2563 {
+ − 2564 Lisp_Object tem = read_doc_string (f->instructions);
+ − 2565 if (!CONSP (tem))
563
+ − 2566 signal_error (Qinvalid_byte_code,
+ − 2567 "Invalid lazy-loaded byte code", tem);
428
+ − 2568 /* v18 or v19 bytecode file. Need to Ebolify. */
+ − 2569 if (f->flags.ebolified && VECTORP (XCDR (tem)))
+ − 2570 ebolify_bytecode_constants (XCDR (tem));
+ − 2571 f->instructions = XCAR (tem);
+ − 2572 f->constants = XCDR (tem);
+ − 2573 return function;
+ − 2574 }
2500
+ − 2575 ABORT ();
801
+ − 2576 return Qnil; /* not (usually) reached */
428
+ − 2577 }
+ − 2578
+ − 2579 DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /*
+ − 2580 Convert compiled function FUNCTION into an optimized internal form.
+ − 2581 */
+ − 2582 (function))
+ − 2583 {
+ − 2584 Lisp_Compiled_Function *f;
+ − 2585 CHECK_COMPILED_FUNCTION (function);
+ − 2586 f = XCOMPILED_FUNCTION (function);
+ − 2587
+ − 2588 if (OPAQUEP (f->instructions)) /* Already optimized? */
+ − 2589 return Qnil;
+ − 2590
+ − 2591 optimize_compiled_function (function);
+ − 2592 return Qnil;
+ − 2593 }
+ − 2594
+ − 2595 DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /*
+ − 2596 Function used internally in byte-compiled code.
+ − 2597 First argument INSTRUCTIONS is a string of byte code.
+ − 2598 Second argument CONSTANTS is a vector of constants.
+ − 2599 Third argument STACK-DEPTH is the maximum stack depth used in this function.
+ − 2600 If STACK-DEPTH is incorrect, Emacs may crash.
+ − 2601 */
+ − 2602 (instructions, constants, stack_depth))
+ − 2603 {
+ − 2604 /* This function can GC */
+ − 2605 int varbind_count;
+ − 2606 int program_length;
+ − 2607 Opbyte *program;
+ − 2608
+ − 2609 CHECK_STRING (instructions);
+ − 2610 CHECK_VECTOR (constants);
+ − 2611 CHECK_NATNUM (stack_depth);
+ − 2612
+ − 2613 /* Optimize the `instructions' string, just like when executing a
+ − 2614 regular compiled function, but don't save it for later since this is
+ − 2615 likely to only be executed once. */
+ − 2616 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions));
+ − 2617 optimize_byte_code (instructions, constants, program,
+ − 2618 &program_length, &varbind_count);
+ − 2619 SPECPDL_RESERVE (varbind_count);
+ − 2620 return execute_optimized_program (program,
+ − 2621 XINT (stack_depth),
+ − 2622 XVECTOR_DATA (constants));
+ − 2623 }
+ − 2624
+ − 2625
+ − 2626 void
+ − 2627 syms_of_bytecode (void)
+ − 2628 {
442
+ − 2629 INIT_LRECORD_IMPLEMENTATION (compiled_function);
3092
+ − 2630 #ifdef NEW_GC
+ − 2631 INIT_LRECORD_IMPLEMENTATION (compiled_function_args);
+ − 2632 #endif /* NEW_GC */
442
+ − 2633
+ − 2634 DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state);
563
+ − 2635 DEFSYMBOL (Qbyte_code);
+ − 2636 DEFSYMBOL_MULTIWORD_PREDICATE (Qcompiled_functionp);
428
+ − 2637
+ − 2638 DEFSUBR (Fbyte_code);
+ − 2639 DEFSUBR (Ffetch_bytecode);
+ − 2640 DEFSUBR (Foptimize_compiled_function);
+ − 2641
+ − 2642 DEFSUBR (Fcompiled_function_p);
+ − 2643 DEFSUBR (Fcompiled_function_instructions);
+ − 2644 DEFSUBR (Fcompiled_function_constants);
+ − 2645 DEFSUBR (Fcompiled_function_stack_depth);
+ − 2646 DEFSUBR (Fcompiled_function_arglist);
+ − 2647 DEFSUBR (Fcompiled_function_interactive);
+ − 2648 DEFSUBR (Fcompiled_function_doc_string);
+ − 2649 DEFSUBR (Fcompiled_function_domain);
+ − 2650 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ − 2651 DEFSUBR (Fcompiled_function_annotation);
+ − 2652 #endif
+ − 2653
+ − 2654 #ifdef BYTE_CODE_METER
563
+ − 2655 DEFSYMBOL (Qbyte_code_meter);
428
+ − 2656 #endif
+ − 2657 }
+ − 2658
+ − 2659 void
+ − 2660 vars_of_bytecode (void)
+ − 2661 {
+ − 2662 #ifdef BYTE_CODE_METER
+ − 2663
+ − 2664 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /*
+ − 2665 A vector of vectors which holds a histogram of byte code usage.
+ − 2666 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
+ − 2667 opcode CODE has been executed.
+ − 2668 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
+ − 2669 indicates how many times the byte opcodes CODE1 and CODE2 have been
+ − 2670 executed in succession.
+ − 2671 */ );
+ − 2672 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /*
+ − 2673 If non-nil, keep profiling information on byte code usage.
+ − 2674 The variable `byte-code-meter' indicates how often each byte opcode is used.
+ − 2675 If a symbol has a property named `byte-code-meter' whose value is an
+ − 2676 integer, it is incremented each time that symbol's function is called.
+ − 2677 */ );
+ − 2678
+ − 2679 byte_metering_on = 0;
+ − 2680 Vbyte_code_meter = make_vector (256, Qzero);
+ − 2681 {
+ − 2682 int i = 256;
+ − 2683 while (i--)
+ − 2684 XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero);
+ − 2685 }
+ − 2686 #endif /* BYTE_CODE_METER */
+ − 2687 }