1 /* 2 * LispThread.java 3 * 4 * Copyright (C) 2003-2007 Peter Graves 5 * $Id: LispThread.java 14465 2013-04-24 12:50:37Z rschlatte $ 6 * 7 * This program is free software; you can redistribute it and/or 8 * modify it under the terms of the GNU General Public License 9 * as published by the Free Software Foundation; either version 2 10 * of the License, or (at your option) any later version. 11 * 12 * This program is distributed in the hope that it will be useful, 13 * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 * GNU General Public License for more details. 16 * 17 * You should have received a copy of the GNU General Public License 18 * along with this program; if not, write to the Free Software 19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 20 * 21 * As a special exception, the copyright holders of this library give you 22 * permission to link this library with independent modules to produce an 23 * executable, regardless of the license terms of these independent 24 * modules, and to copy and distribute the resulting executable under 25 * terms of your choice, provided that you also meet, for each linked 26 * independent module, the terms and conditions of the license of that 27 * module. An independent module is a module which is not derived from 28 * or based on this library. If you modify this library, you may extend 29 * this exception to your version of the library, but you are not 30 * obligated to do so. If you do not wish to do so, delete this 31 * exception statement from your version. 32 */ 33 34 package org.armedbear.lisp; 35 36 import java.lang.ref.WeakReference; 37 import static org.armedbear.lisp.Lisp.*; 38 39 import java.util.Iterator; 40 import java.util.concurrent.ConcurrentHashMap; 41 import java.util.concurrent.ConcurrentLinkedQueue; 42 import java.util.concurrent.atomic.AtomicInteger; 43 44 import java.text.MessageFormat; 45 46 public final class LispThread extends LispObject 47 { 48 // use a concurrent hashmap: we may want to add threads 49 // while at the same time iterating the hash 50 final static ConcurrentHashMap<Thread,LispThread> map = 51 new ConcurrentHashMap<Thread,LispThread>(); 52 53 LispObject threadValue = NIL; 54 55 private static ThreadLocal<LispThread> threads = new ThreadLocal<LispThread>(){ 56 @Override 57 public LispThread initialValue() { 58 Thread thisThread = Thread.currentThread(); 59 LispThread thread = LispThread.map.get(thisThread); 60 if (thread == null) { 61 thread = new LispThread(thisThread); 62 LispThread.map.put(thisThread,thread); 63 } 64 return thread; 65 } 66 }; 67 currentThread()68 public static final LispThread currentThread() 69 { 70 return threads.get(); 71 } 72 73 final Thread javaThread; 74 private boolean destroyed; 75 final LispObject name; 76 public LispObject[] _values; 77 private boolean threadInterrupted; 78 private LispObject pending = NIL; 79 private Symbol wrapper = 80 PACKAGE_THREADS.intern("THREAD-FUNCTION-WRAPPER"); 81 LispThread(Thread javaThread)82 LispThread(Thread javaThread) 83 { 84 this.javaThread = javaThread; 85 name = new SimpleString(javaThread.getName()); 86 } 87 LispThread(final Function fun, LispObject name)88 LispThread(final Function fun, LispObject name) 89 { 90 Runnable r = new Runnable() { 91 public void run() 92 { 93 try { 94 threadValue = funcall(wrapper, 95 new LispObject[] { fun }, 96 LispThread.this); 97 } 98 catch (ThreadDestroyed ignored) { 99 // Might happen. 100 } 101 catch (ProcessingTerminated e) { 102 System.exit(e.getStatus()); 103 } 104 catch (Throwable t) { // any error: process thread interrupts 105 if (isInterrupted()) { 106 processThreadInterrupts(); 107 } 108 String msg 109 = MessageFormat.format("Ignoring uncaught exception {0}.", 110 t.toString()); 111 Debug.warn(msg); 112 } 113 finally { 114 // make sure the thread is *always* removed from the hash again 115 map.remove(Thread.currentThread()); 116 } 117 } 118 }; 119 javaThread = new Thread(r); 120 this.name = name; 121 map.put(javaThread, this); 122 if (name != NIL) 123 javaThread.setName(name.getStringValue()); 124 javaThread.setDaemon(true); 125 javaThread.start(); 126 } 127 getJavaStackTrace()128 public StackTraceElement[] getJavaStackTrace() { 129 return javaThread.getStackTrace(); 130 } 131 132 @Override typeOf()133 public LispObject typeOf() 134 { 135 return Symbol.THREAD; 136 } 137 138 @Override classOf()139 public LispObject classOf() 140 { 141 return BuiltInClass.THREAD; 142 } 143 144 @Override typep(LispObject typeSpecifier)145 public LispObject typep(LispObject typeSpecifier) 146 { 147 if (typeSpecifier == Symbol.THREAD) 148 return T; 149 if (typeSpecifier == BuiltInClass.THREAD) 150 return T; 151 return super.typep(typeSpecifier); 152 } 153 isDestroyed()154 public final synchronized boolean isDestroyed() 155 { 156 return destroyed; 157 } 158 isInterrupted()159 final synchronized boolean isInterrupted() 160 { 161 return threadInterrupted; 162 } 163 setDestroyed(boolean b)164 final synchronized void setDestroyed(boolean b) 165 { 166 destroyed = b; 167 } 168 interrupt(LispObject function, LispObject args)169 final synchronized void interrupt(LispObject function, LispObject args) 170 { 171 pending = new Cons(args, pending); 172 pending = new Cons(function, pending); 173 threadInterrupted = true; 174 javaThread.interrupt(); 175 } 176 processThreadInterrupts()177 final synchronized void processThreadInterrupts() 178 179 { 180 while (pending != NIL) { 181 LispObject function = pending.car(); 182 LispObject args = pending.cadr(); 183 pending = pending.cddr(); 184 Primitives.APPLY.execute(function, args); 185 } 186 threadInterrupted = false; 187 } 188 getValues()189 public final LispObject[] getValues() 190 { 191 return _values; 192 } 193 getValues(LispObject result, int count)194 public final LispObject[] getValues(LispObject result, int count) 195 { 196 if (_values == null) { 197 LispObject[] values = new LispObject[count]; 198 if (count > 0) 199 values[0] = result; 200 for (int i = 1; i < count; i++) 201 values[i] = NIL; 202 return values; 203 } 204 // If the caller doesn't want any extra values, just return the ones 205 // we've got. 206 if (count <= _values.length) 207 return _values; 208 // The caller wants more values than we have. Pad with NILs. 209 LispObject[] values = new LispObject[count]; 210 for (int i = _values.length; i-- > 0;) 211 values[i] = _values[i]; 212 for (int i = _values.length; i < count; i++) 213 values[i] = NIL; 214 return values; 215 } 216 217 /** Used by the JVM compiler for MULTIPLE-VALUE-CALL. */ accumulateValues(LispObject result, LispObject[] oldValues)218 public final LispObject[] accumulateValues(LispObject result, 219 LispObject[] oldValues) 220 { 221 if (oldValues == null) { 222 if (_values != null) 223 return _values; 224 LispObject[] values = new LispObject[1]; 225 values[0] = result; 226 return values; 227 } 228 if (_values != null) { 229 if (_values.length == 0) 230 return oldValues; 231 final int totalLength = oldValues.length + _values.length; 232 LispObject[] values = new LispObject[totalLength]; 233 System.arraycopy(oldValues, 0, 234 values, 0, 235 oldValues.length); 236 System.arraycopy(_values, 0, 237 values, oldValues.length, 238 _values.length); 239 return values; 240 } 241 // _values is null. 242 final int totalLength = oldValues.length + 1; 243 LispObject[] values = new LispObject[totalLength]; 244 System.arraycopy(oldValues, 0, 245 values, 0, 246 oldValues.length); 247 values[totalLength - 1] = result; 248 return values; 249 } 250 setValues()251 public final LispObject setValues() 252 { 253 _values = new LispObject[0]; 254 return NIL; 255 } 256 setValues(LispObject value1)257 public final LispObject setValues(LispObject value1) 258 { 259 _values = null; 260 return value1; 261 } 262 setValues(LispObject value1, LispObject value2)263 public final LispObject setValues(LispObject value1, LispObject value2) 264 { 265 _values = new LispObject[2]; 266 _values[0] = value1; 267 _values[1] = value2; 268 return value1; 269 } 270 setValues(LispObject value1, LispObject value2, LispObject value3)271 public final LispObject setValues(LispObject value1, LispObject value2, 272 LispObject value3) 273 { 274 _values = new LispObject[3]; 275 _values[0] = value1; 276 _values[1] = value2; 277 _values[2] = value3; 278 return value1; 279 } 280 setValues(LispObject value1, LispObject value2, LispObject value3, LispObject value4)281 public final LispObject setValues(LispObject value1, LispObject value2, 282 LispObject value3, LispObject value4) 283 { 284 _values = new LispObject[4]; 285 _values[0] = value1; 286 _values[1] = value2; 287 _values[2] = value3; 288 _values[3] = value4; 289 return value1; 290 } 291 setValues(LispObject[] values)292 public final LispObject setValues(LispObject[] values) 293 { 294 switch (values.length) { 295 case 0: 296 _values = values; 297 return NIL; 298 case 1: 299 _values = null; 300 return values[0]; 301 default: 302 _values = values; 303 return values[0]; 304 } 305 } 306 clearValues()307 public final void clearValues() 308 { 309 _values = null; 310 } 311 nothing()312 public final LispObject nothing() 313 { 314 _values = new LispObject[0]; 315 return NIL; 316 } 317 318 /** 319 * Force a single value, for situations where multiple values should be 320 * ignored. 321 */ value(LispObject obj)322 public final LispObject value(LispObject obj) 323 { 324 _values = null; 325 return obj; 326 } 327 328 329 330 final static int UNASSIGNED_SPECIAL_INDEX = 0; 331 332 /** Indicates the last special slot which has been assigned. 333 * Symbols which don't have a special slot assigned use a slot 334 * index of 0 for efficiency reasons: it eliminates the need to 335 * check for index validity before accessing the specials array. 336 * 337 */ 338 final static AtomicInteger lastSpecial 339 = new AtomicInteger(UNASSIGNED_SPECIAL_INDEX); 340 341 /** A list of indices which can be (re)used for symbols to 342 * be assigned a special slot index. 343 */ 344 final static ConcurrentLinkedQueue<Integer> freeSpecialIndices 345 = new ConcurrentLinkedQueue<Integer>(); 346 347 final static int specialsInitialSize 348 = Integer.valueOf(System.getProperty("abcl.specials.initialSize","4096")); 349 350 /** This array stores the current special binding for every symbol 351 * which has been globally or locally declared special. 352 * 353 * If the array element has a null value, this means there currently 354 * is no active binding. If the array element contains a valid 355 * SpecialBinding object, but the value field of it is null, that 356 * indicates an "UNBOUND VARIABLE" situation. 357 */ 358 SpecialBinding[] specials 359 = new SpecialBinding[specialsInitialSize + 1]; 360 361 final static ConcurrentHashMap<Integer, WeakReference<Symbol>> specialNames 362 = new ConcurrentHashMap<Integer, WeakReference<Symbol>>(); 363 364 /** The number of slots to grow the specials table in 365 * case of insufficient storage. 366 */ 367 final static int specialsDelta 368 = Integer.valueOf(System.getProperty("abcl.specials.grow.delta","1024")); 369 370 /** This variable points to the head of a linked list of saved 371 * special bindings. Its main purpose is to allow a mark/reset 372 * interface to special binding and unbinding. 373 */ 374 private SpecialBindingsMark savedSpecials = null; 375 376 /** Marks the state of the special bindings, 377 * for later rewinding by resetSpecialBindings(). 378 */ markSpecialBindings()379 public final SpecialBindingsMark markSpecialBindings() { 380 return savedSpecials; 381 } 382 383 /** Restores the state of the special bindings to what 384 * was captured in the marker 'mark' by a call to markSpecialBindings(). 385 */ resetSpecialBindings(SpecialBindingsMark mark)386 public final void resetSpecialBindings(SpecialBindingsMark mark) { 387 SpecialBindingsMark c = savedSpecials; 388 while (mark != c) { 389 specials[c.idx] = c.binding; 390 c = c.next; 391 } 392 savedSpecials = c; 393 } 394 395 /** Clears out all active special bindings including any marks 396 * previously set. Invoking resetSpecialBindings() with marks 397 * set before this call results in undefined behaviour. 398 */ 399 // Package level access: only for Interpreter.run() clearSpecialBindings()400 final void clearSpecialBindings() { 401 resetSpecialBindings(null); 402 } 403 404 /** Assigns a specials array index number to the symbol, 405 * if it doesn't already have one. 406 */ assignSpecialIndex(Symbol sym)407 private void assignSpecialIndex(Symbol sym) 408 { 409 if (sym.specialIndex != 0) 410 return; 411 412 synchronized (sym) { 413 // Don't use an atomic access: we'll be swapping values only once. 414 if (sym.specialIndex == 0) { 415 Integer next = freeSpecialIndices.poll(); 416 if (next == null 417 && specials.length < lastSpecial.get() 418 && null == System.getProperty("abcl.specials.grow.slowly")) { 419 // free slots are exhausted; in the middle and at the end. 420 System.gc(); 421 next = freeSpecialIndices.poll(); 422 } 423 if (next == null) 424 sym.specialIndex = lastSpecial.incrementAndGet(); 425 else 426 sym.specialIndex = next.intValue(); 427 } 428 } 429 } 430 431 /** Frees up an index previously assigned to a symbol for re-assignment 432 * to another symbol. Returns without effect if the symbol has the 433 * default UNASSIGNED_SPECIAL_INDEX special index. 434 */ releaseSpecialIndex(Symbol sym)435 protected static void releaseSpecialIndex(Symbol sym) 436 { 437 int index = sym.specialIndex; 438 if (index != UNASSIGNED_SPECIAL_INDEX) { 439 // clear out the values in the 440 Iterator<LispThread> it = map.values().iterator(); 441 while (it.hasNext()) { 442 LispThread thread = it.next(); 443 444 // clear out the values in the saved specials list 445 SpecialBindingsMark savedSpecial = thread.savedSpecials; 446 while (savedSpecial != null) { 447 if (savedSpecial.idx == index) { 448 savedSpecial.idx = 0; 449 savedSpecial.binding = null; 450 } 451 savedSpecial = savedSpecial.next; 452 } 453 454 thread.specials[index] = null; 455 } 456 457 freeSpecialIndices.add(new Integer(index)); 458 } 459 } 460 growSpecials()461 private void growSpecials() { 462 SpecialBinding[] newSpecials 463 = new SpecialBinding[specials.length + specialsDelta]; 464 System.arraycopy(specials, 0, newSpecials, 0, specials.length); 465 specials = newSpecials; 466 } 467 ensureSpecialBinding(int idx)468 private SpecialBinding ensureSpecialBinding(int idx) { 469 SpecialBinding binding; 470 boolean assigned; 471 do { 472 try { 473 binding = specials[idx]; 474 assigned = true; 475 } 476 catch (ArrayIndexOutOfBoundsException e) { 477 assigned = false; 478 binding = null; // suppresses 'unassigned' error 479 growSpecials(); 480 } 481 } while (! assigned); 482 return binding; 483 } 484 bindSpecial(Symbol name, LispObject value)485 public final SpecialBinding bindSpecial(Symbol name, LispObject value) 486 { 487 int idx; 488 489 assignSpecialIndex(name); 490 SpecialBinding binding = ensureSpecialBinding(idx = name.specialIndex); 491 savedSpecials = new SpecialBindingsMark(idx, binding, savedSpecials); 492 return specials[idx] = new SpecialBinding(idx, value); 493 } 494 bindSpecialToCurrentValue(Symbol name)495 public final SpecialBinding bindSpecialToCurrentValue(Symbol name) 496 { 497 int idx; 498 499 assignSpecialIndex(name); 500 SpecialBinding binding = ensureSpecialBinding(idx = name.specialIndex); 501 savedSpecials = new SpecialBindingsMark(idx, binding, savedSpecials); 502 return specials[idx] 503 = new SpecialBinding(idx, 504 (binding == null) ? 505 name.getSymbolValue() : binding.value); 506 } 507 508 /** Looks up the value of a special binding in the context of the 509 * given thread. 510 * 511 * In order to find the value of a special variable (in general), 512 * use {@link Symbol#symbolValue}. 513 * 514 * @param name The name of the special variable, normally a symbol 515 * @return The inner most binding of the special, or null if unbound 516 * 517 * @see Symbol#symbolValue 518 */ lookupSpecial(Symbol name)519 public final LispObject lookupSpecial(Symbol name) 520 { 521 SpecialBinding binding = ensureSpecialBinding(name.specialIndex); 522 return (binding == null) ? null : binding.value; 523 } 524 getSpecialBinding(Symbol name)525 public final SpecialBinding getSpecialBinding(Symbol name) 526 { 527 return ensureSpecialBinding(name.specialIndex); 528 } 529 setSpecialVariable(Symbol name, LispObject value)530 public final LispObject setSpecialVariable(Symbol name, LispObject value) 531 { 532 SpecialBinding binding = ensureSpecialBinding(name.specialIndex); 533 if (binding != null) 534 return binding.value = value; 535 536 name.setSymbolValue(value); 537 return value; 538 } 539 pushSpecial(Symbol name, LispObject thing)540 public final LispObject pushSpecial(Symbol name, LispObject thing) 541 542 { 543 SpecialBinding binding = ensureSpecialBinding(name.specialIndex); 544 if (binding != null) 545 return binding.value = new Cons(thing, binding.value); 546 547 LispObject value = name.getSymbolValue(); 548 if (value != null) { 549 LispObject newValue = new Cons(thing, value); 550 name.setSymbolValue(newValue); 551 return newValue; 552 } else 553 return error(new UnboundVariable(name)); 554 } 555 556 // Returns symbol value or NIL if unbound. safeSymbolValue(Symbol name)557 public final LispObject safeSymbolValue(Symbol name) 558 { 559 SpecialBinding binding = ensureSpecialBinding(name.specialIndex); 560 if (binding != null) 561 return binding.value; 562 563 LispObject value = name.getSymbolValue(); 564 return value != null ? value : NIL; 565 } 566 rebindSpecial(Symbol name, LispObject value)567 public final void rebindSpecial(Symbol name, LispObject value) 568 { 569 SpecialBinding binding = getSpecialBinding(name); 570 binding.value = value; 571 } 572 573 private LispObject catchTags = NIL; 574 pushCatchTag(LispObject tag)575 public void pushCatchTag(LispObject tag) 576 { 577 catchTags = new Cons(tag, catchTags); 578 } 579 popCatchTag()580 public void popCatchTag() 581 { 582 if (catchTags != NIL) 583 catchTags = catchTags.cdr(); 584 else 585 Debug.assertTrue(false); 586 } 587 throwToTag(LispObject tag, LispObject result)588 public void throwToTag(LispObject tag, LispObject result) 589 590 { 591 LispObject rest = catchTags; 592 while (rest != NIL) { 593 if (rest.car() == tag) 594 throw new Throw(tag, result, this); 595 rest = rest.cdr(); 596 } 597 error(new ControlError("Attempt to throw to the nonexistent tag " + 598 tag.princToString() + ".")); 599 } 600 601 602 private static class StackMarker { 603 604 final int numArgs; 605 StackMarker(int numArgs)606 StackMarker(int numArgs) { 607 this.numArgs = numArgs; 608 } 609 getNumArgs()610 int getNumArgs() { 611 return numArgs; 612 } 613 } 614 615 // markers for args 616 private final static StackMarker STACK_MARKER_0 = new StackMarker(0); 617 private final static StackMarker STACK_MARKER_1 = new StackMarker(1); 618 private final static StackMarker STACK_MARKER_2 = new StackMarker(2); 619 private final static StackMarker STACK_MARKER_3 = new StackMarker(3); 620 private final static StackMarker STACK_MARKER_4 = new StackMarker(4); 621 private final static StackMarker STACK_MARKER_5 = new StackMarker(5); 622 private final static StackMarker STACK_MARKER_6 = new StackMarker(6); 623 private final static StackMarker STACK_MARKER_7 = new StackMarker(7); 624 private final static StackMarker STACK_MARKER_8 = new StackMarker(8); 625 626 private final int STACK_FRAME_EXTRA = 2; 627 // a LispStackFrame with n arguments occupies n + STACK_FRAME_EXTRA elements 628 // in {@code stack} array. 629 // stack[framePos] == operation 630 // stack[framePos + 1 + i] == arg[i] 631 // stack[framePos + 1 + n] == initially SrackMarker(n) 632 // LispStackFrame object may be lazily allocated later. 633 // In this case it is stored in stack framePos + 1 + n] 634 // 635 // Java stack frame occupies 1 element 636 // stack[framePos] == JavaStackFrame 637 // 638 // Stack consists of a list of StackSegments. 639 // Top StackSegment is cached in variables stack and stackPtr. 640 private StackSegment topStackSegment = new StackSegment(INITIAL_SEGMENT_SIZE, null); 641 private Object[] stack = topStackSegment.stack; 642 private int stackPtr = 0; 643 private StackSegment spareStackSegment; 644 645 private static class StackSegment 646 implements org.armedbear.lisp.protocol.Inspectable 647 { 648 final Object[] stack; 649 final StackSegment next; 650 int stackPtr; 651 StackSegment(int size, StackSegment next)652 StackSegment(int size, StackSegment next) { 653 stack = new Object[size]; 654 this.next = next; 655 } getParts()656 public LispObject getParts() { 657 Cons result = new Cons(NIL); 658 return result 659 .push(new Symbol("INITIAL-SEGMENT-SIZE")) 660 .push(LispInteger.getInstance(LispThread.INITIAL_SEGMENT_SIZE)) 661 .push(new Symbol("SEGMENT-SIZE")) 662 .push(LispInteger.getInstance(LispThread.SEGMENT_SIZE)).nreverse(); 663 } 664 } 665 ensureStackCapacity(int itemsToPush)666 private void ensureStackCapacity(int itemsToPush) { 667 if (stackPtr + (itemsToPush - 1) >= stack.length) 668 grow(itemsToPush); 669 } 670 671 private static final int INITIAL_SEGMENT_SIZE = 1 << 10; 672 private static final int SEGMENT_SIZE = (1 << 19) - 4; // 4 MiB page on x86_64 673 grow(int numEntries)674 private void grow(int numEntries) { 675 topStackSegment.stackPtr = stackPtr; 676 if (spareStackSegment != null) { 677 // Use spare segement if available 678 if (stackPtr > 0 && spareStackSegment.stack.length >= numEntries) { 679 topStackSegment = spareStackSegment; 680 stack = topStackSegment.stack; 681 spareStackSegment = null; 682 stackPtr = 0; 683 return; 684 } 685 spareStackSegment = null; 686 } 687 int newSize = stackPtr + numEntries; 688 if (topStackSegment.stack.length < SEGMENT_SIZE || stackPtr == 0) { 689 // grow initial segment from initial size to standard size 690 int newLength = Math.max(newSize, Math.min(SEGMENT_SIZE, stack.length * 2)); 691 StackSegment newSegment = new StackSegment(newLength, topStackSegment.next); 692 System.arraycopy(stack, 0, newSegment.stack, 0, stackPtr); 693 topStackSegment = newSegment; 694 stack = topStackSegment.stack; 695 return; 696 } 697 // Allocate new segment 698 topStackSegment = new StackSegment(Math.max(SEGMENT_SIZE, numEntries), topStackSegment); 699 stack = topStackSegment.stack; 700 stackPtr = 0; 701 } 702 getStackTop()703 private StackFrame getStackTop() { 704 topStackSegment.stackPtr = stackPtr; 705 if (stackPtr == 0) { 706 assert topStackSegment.next == null; 707 return null; 708 } 709 StackFrame prev = null; 710 for (StackSegment segment = topStackSegment; segment != null; segment = segment.next) { 711 Object[] stk = segment.stack; 712 int framePos = segment.stackPtr; 713 while (framePos > 0) { 714 Object stackObj = stk[framePos - 1]; 715 if (stackObj instanceof StackFrame) { 716 if (prev != null) { 717 prev.setNext((StackFrame) stackObj); 718 } 719 return (StackFrame) stack[stackPtr - 1]; 720 } 721 StackMarker marker = (StackMarker) stackObj; 722 int numArgs = marker.getNumArgs(); 723 LispStackFrame frame = new LispStackFrame(stk, framePos - numArgs - STACK_FRAME_EXTRA, numArgs); 724 stk[framePos - 1] = frame; 725 if (prev != null) { 726 prev.setNext(frame); 727 } 728 prev = frame; 729 framePos -= numArgs + STACK_FRAME_EXTRA; 730 } 731 } 732 return (StackFrame) stack[stackPtr - 1]; 733 } 734 pushStackFrame(JavaStackFrame frame)735 public final void pushStackFrame(JavaStackFrame frame) { 736 frame.setNext(getStackTop()); 737 ensureStackCapacity(1); 738 stack[stackPtr] = frame; 739 stackPtr += 1; 740 } 741 popStackFrame(int numArgs)742 private void popStackFrame(int numArgs) { 743 // Pop off intervening JavaFrames until we get back to a LispFrame 744 Object stackObj = stack[stackPtr - 1]; 745 if (stackObj instanceof StackMarker) { 746 assert numArgs == ((StackMarker) stackObj).getNumArgs(); 747 } else { 748 while (stackObj instanceof JavaStackFrame) { 749 stack[--stackPtr] = null; 750 stackObj = stack[stackPtr - 1]; 751 } 752 if (stackObj instanceof StackMarker) { 753 assert numArgs == ((StackMarker) stackObj).getNumArgs(); 754 } else { 755 assert numArgs == ((LispStackFrame) stackObj).getNumArgs(); 756 } 757 } 758 stackPtr -= numArgs + STACK_FRAME_EXTRA; 759 for (int i = 0; i < numArgs + STACK_FRAME_EXTRA; i++) { 760 stack[stackPtr + i] = null; 761 } 762 if (stackPtr == 0) { 763 popStackSegment(); 764 } 765 } 766 popStackSegment()767 private void popStackSegment() { 768 topStackSegment.stackPtr = 0; 769 if (topStackSegment.next != null) { 770 spareStackSegment = topStackSegment; 771 topStackSegment = topStackSegment.next; 772 stack = topStackSegment.stack; 773 } 774 stackPtr = topStackSegment.stackPtr; 775 } 776 setEnv(Environment env)777 public final Environment setEnv(Environment env) { 778 StackFrame stackTop = getStackTop(); 779 return (stackTop != null) ? stackTop.setEnv(env) : null; 780 } 781 resetStack()782 public void resetStack() 783 { 784 topStackSegment = new StackSegment(INITIAL_SEGMENT_SIZE, null); 785 stack = topStackSegment.stack; 786 spareStackSegment = null; 787 stackPtr = 0; 788 } 789 790 @Override execute(LispObject function)791 public LispObject execute(LispObject function) 792 { 793 ensureStackCapacity(STACK_FRAME_EXTRA); 794 stack[stackPtr] = function; 795 stack[stackPtr + 1] = STACK_MARKER_0; 796 stackPtr += STACK_FRAME_EXTRA; 797 try { 798 return function.execute(); 799 } 800 finally { 801 popStackFrame(0); 802 } 803 } 804 805 @Override execute(LispObject function, LispObject arg)806 public LispObject execute(LispObject function, LispObject arg) 807 { 808 ensureStackCapacity(1 + STACK_FRAME_EXTRA); 809 stack[stackPtr] = function; 810 stack[stackPtr + 1] = arg; 811 stack[stackPtr + 2] = STACK_MARKER_1; 812 stackPtr += 1 + STACK_FRAME_EXTRA; 813 try { 814 return function.execute(arg); 815 } 816 finally { 817 popStackFrame(1); 818 } 819 } 820 821 @Override execute(LispObject function, LispObject first, LispObject second)822 public LispObject execute(LispObject function, LispObject first, 823 LispObject second) 824 { 825 ensureStackCapacity(2 + STACK_FRAME_EXTRA); 826 stack[stackPtr] = function; 827 stack[stackPtr + 1] = first; 828 stack[stackPtr + 2] = second; 829 stack[stackPtr + 3] = STACK_MARKER_2; 830 stackPtr += 2 + STACK_FRAME_EXTRA; 831 try { 832 return function.execute(first, second); 833 } 834 finally { 835 popStackFrame(2); 836 } 837 } 838 839 @Override execute(LispObject function, LispObject first, LispObject second, LispObject third)840 public LispObject execute(LispObject function, LispObject first, 841 LispObject second, LispObject third) 842 { 843 ensureStackCapacity(3 + STACK_FRAME_EXTRA); 844 stack[stackPtr] = function; 845 stack[stackPtr + 1] = first; 846 stack[stackPtr + 2] = second; 847 stack[stackPtr + 3] = third; 848 stack[stackPtr + 4] = STACK_MARKER_3; 849 stackPtr += 3 + STACK_FRAME_EXTRA; 850 try { 851 return function.execute(first, second, third); 852 } 853 finally { 854 popStackFrame(3); 855 } 856 } 857 858 @Override execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth)859 public LispObject execute(LispObject function, LispObject first, 860 LispObject second, LispObject third, 861 LispObject fourth) 862 { 863 ensureStackCapacity(4 + STACK_FRAME_EXTRA); 864 stack[stackPtr] = function; 865 stack[stackPtr + 1] = first; 866 stack[stackPtr + 2] = second; 867 stack[stackPtr + 3] = third; 868 stack[stackPtr + 4] = fourth; 869 stack[stackPtr + 5] = STACK_MARKER_4; 870 stackPtr += 4 + STACK_FRAME_EXTRA; 871 try { 872 return function.execute(first, second, third, fourth); 873 } 874 finally { 875 popStackFrame(4); 876 } 877 } 878 879 @Override execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth)880 public LispObject execute(LispObject function, LispObject first, 881 LispObject second, LispObject third, 882 LispObject fourth, LispObject fifth) 883 { 884 ensureStackCapacity(5 + STACK_FRAME_EXTRA); 885 stack[stackPtr] = function; 886 stack[stackPtr + 1] = first; 887 stack[stackPtr + 2] = second; 888 stack[stackPtr + 3] = third; 889 stack[stackPtr + 4] = fourth; 890 stack[stackPtr + 5] = fifth; 891 stack[stackPtr + 6] = STACK_MARKER_5; 892 stackPtr += 5 + STACK_FRAME_EXTRA; 893 try { 894 return function.execute(first, second, third, fourth, fifth); 895 } 896 finally { 897 popStackFrame(5); 898 } 899 } 900 901 @Override execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth)902 public LispObject execute(LispObject function, LispObject first, 903 LispObject second, LispObject third, 904 LispObject fourth, LispObject fifth, 905 LispObject sixth) 906 { 907 ensureStackCapacity(6 + STACK_FRAME_EXTRA); 908 stack[stackPtr] = function; 909 stack[stackPtr + 1] = first; 910 stack[stackPtr + 2] = second; 911 stack[stackPtr + 3] = third; 912 stack[stackPtr + 4] = fourth; 913 stack[stackPtr + 5] = fifth; 914 stack[stackPtr + 6] = sixth; 915 stack[stackPtr + 7] = STACK_MARKER_6; 916 stackPtr += 6 + STACK_FRAME_EXTRA; 917 try { 918 return function.execute(first, second, third, fourth, fifth, sixth); 919 } 920 finally { 921 popStackFrame(6); 922 } 923 } 924 925 @Override execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh)926 public LispObject execute(LispObject function, LispObject first, 927 LispObject second, LispObject third, 928 LispObject fourth, LispObject fifth, 929 LispObject sixth, LispObject seventh) 930 { 931 ensureStackCapacity(7 + STACK_FRAME_EXTRA); 932 stack[stackPtr] = function; 933 stack[stackPtr + 1] = first; 934 stack[stackPtr + 2] = second; 935 stack[stackPtr + 3] = third; 936 stack[stackPtr + 4] = fourth; 937 stack[stackPtr + 5] = fifth; 938 stack[stackPtr + 6] = sixth; 939 stack[stackPtr + 7] = seventh; 940 stack[stackPtr + 8] = STACK_MARKER_7; 941 stackPtr += 7 + STACK_FRAME_EXTRA; 942 try { 943 return function.execute(first, second, third, fourth, fifth, sixth, 944 seventh); 945 } 946 finally { 947 popStackFrame(7); 948 } 949 } 950 execute(LispObject function, LispObject first, LispObject second, LispObject third, LispObject fourth, LispObject fifth, LispObject sixth, LispObject seventh, LispObject eighth)951 public LispObject execute(LispObject function, LispObject first, 952 LispObject second, LispObject third, 953 LispObject fourth, LispObject fifth, 954 LispObject sixth, LispObject seventh, 955 LispObject eighth) 956 { 957 ensureStackCapacity(8 + STACK_FRAME_EXTRA); 958 stack[stackPtr] = function; 959 stack[stackPtr + 1] = first; 960 stack[stackPtr + 2] = second; 961 stack[stackPtr + 3] = third; 962 stack[stackPtr + 4] = fourth; 963 stack[stackPtr + 5] = fifth; 964 stack[stackPtr + 6] = sixth; 965 stack[stackPtr + 7] = seventh; 966 stack[stackPtr + 8] = eighth; 967 stack[stackPtr + 9] = STACK_MARKER_8; 968 stackPtr += 8 + STACK_FRAME_EXTRA; 969 try { 970 return function.execute(first, second, third, fourth, fifth, sixth, 971 seventh, eighth); 972 } 973 finally { 974 popStackFrame(8); 975 } 976 } 977 execute(LispObject function, LispObject[] args)978 public LispObject execute(LispObject function, LispObject[] args) 979 { 980 ensureStackCapacity(args.length + STACK_FRAME_EXTRA); 981 stack[stackPtr] = function; 982 System.arraycopy(args, 0, stack, stackPtr + 1, args.length); 983 stack[stackPtr + args.length + 1] = new StackMarker(args.length); 984 stackPtr += args.length + STACK_FRAME_EXTRA; 985 try { 986 return function.execute(args); 987 } 988 finally { 989 popStackFrame(args.length); 990 } 991 } 992 printBacktrace()993 public void printBacktrace() 994 { 995 printBacktrace(0); 996 } 997 printBacktrace(int limit)998 public void printBacktrace(int limit) 999 { 1000 StackFrame stackTop = getStackTop(); 1001 if (stackTop != null) { 1002 int count = 0; 1003 Stream out = 1004 checkCharacterOutputStream(Symbol.TRACE_OUTPUT.symbolValue()); 1005 out._writeLine("Evaluation stack:"); 1006 out._finishOutput(); 1007 1008 StackFrame s = stackTop; 1009 while (s != null) { 1010 out._writeString(" "); 1011 out._writeString(String.valueOf(count)); 1012 out._writeString(": "); 1013 1014 pprint(s.toLispList(), out.getCharPos(), out); 1015 out.terpri(); 1016 out._finishOutput(); 1017 if (limit > 0 && ++count == limit) 1018 break; 1019 s = s.next; 1020 } 1021 } 1022 } 1023 backtrace(int limit)1024 public LispObject backtrace(int limit) 1025 { 1026 StackFrame stackTop = getStackTop(); 1027 LispObject result = NIL; 1028 if (stackTop != null) { 1029 int count = 0; 1030 StackFrame s = stackTop; 1031 while (s != null) { 1032 result = result.push(s); 1033 if (limit > 0 && ++count == limit) 1034 break; 1035 s = s.getNext(); 1036 } 1037 } 1038 return result.nreverse(); 1039 } 1040 incrementCallCounts()1041 public void incrementCallCounts() 1042 { 1043 topStackSegment.stackPtr = stackPtr; 1044 int depth = 0; 1045 for (StackSegment segment = topStackSegment; segment != null; segment = segment.next) { 1046 Object[] stk = segment.stack; 1047 int framePos = segment.stackPtr; 1048 while (framePos > 0) { 1049 depth++; 1050 Object stackObj = stk[framePos - 1]; 1051 int numArgs; 1052 if (stackObj instanceof StackMarker) { 1053 numArgs = ((StackMarker) stackObj).getNumArgs(); 1054 } else if (stackObj instanceof LispStackFrame) { 1055 numArgs = ((LispStackFrame) stackObj).getNumArgs(); 1056 } else { 1057 assert stackObj instanceof JavaStackFrame; 1058 framePos--; 1059 continue; 1060 } 1061 // lisp stack frame 1062 framePos -= numArgs + STACK_FRAME_EXTRA; 1063 LispObject operator = (LispObject) stack[framePos]; 1064 if (operator != null) { 1065 if (depth <= 8) { 1066 operator.incrementHotCount(); 1067 } 1068 operator.incrementCallCount(); 1069 } 1070 } 1071 } 1072 } 1073 pprint(LispObject obj, int indentBy, Stream stream)1074 private static void pprint(LispObject obj, int indentBy, Stream stream) 1075 1076 { 1077 if (stream.getCharPos() == 0) { 1078 StringBuffer sb = new StringBuffer(); 1079 for (int i = 0; i < indentBy; i++) 1080 sb.append(' '); 1081 stream._writeString(sb.toString()); 1082 } 1083 String raw = obj.printObject(); 1084 if (stream.getCharPos() + raw.length() < 80) { 1085 // It fits. 1086 stream._writeString(raw); 1087 return; 1088 } 1089 // Object doesn't fit. 1090 if (obj instanceof Cons) { 1091 boolean newlineBefore = false; 1092 LispObject[] array = obj.copyToArray(); 1093 if (array.length > 0) { 1094 LispObject first = array[0]; 1095 if (first == Symbol.LET) { 1096 newlineBefore = true; 1097 } 1098 } 1099 int charPos = stream.getCharPos(); 1100 if (newlineBefore && charPos != indentBy) { 1101 stream.terpri(); 1102 charPos = stream.getCharPos(); 1103 } 1104 if (charPos < indentBy) { 1105 StringBuffer sb = new StringBuffer(); 1106 for (int i = charPos; i < indentBy; i++) 1107 sb.append(' '); 1108 stream._writeString(sb.toString()); 1109 } 1110 stream.print('('); 1111 for (int i = 0; i < array.length; i++) { 1112 pprint(array[i], indentBy + 2, stream); 1113 if (i < array.length - 1) 1114 stream.print(' '); 1115 } 1116 stream.print(')'); 1117 } else { 1118 stream.terpri(); 1119 StringBuffer sb = new StringBuffer(); 1120 for (int i = 0; i < indentBy; i++) 1121 sb.append(' '); 1122 stream._writeString(sb.toString()); 1123 stream._writeString(raw); 1124 return; 1125 } 1126 } 1127 1128 @Override printObject()1129 public String printObject() 1130 { 1131 StringBuffer sb = new StringBuffer("THREAD"); 1132 if (name != NIL) { 1133 sb.append(" \""); 1134 sb.append(name.getStringValue()); 1135 sb.append("\""); 1136 } 1137 return unreadableString(sb.toString()); 1138 } 1139 1140 @DocString(name="make-thread", 1141 args="function &key name", 1142 doc="Create a thread of execution running FUNCTION possibly named NAME") 1143 private static final Primitive MAKE_THREAD = 1144 new Primitive("make-thread", PACKAGE_THREADS, true, "function &key name") 1145 { 1146 @Override 1147 public LispObject execute(LispObject[] args) 1148 { 1149 final int length = args.length; 1150 if (length == 0) 1151 error(new WrongNumberOfArgumentsException(this, 1, -1)); 1152 LispObject name = NIL; 1153 if (length > 1) { 1154 if ((length - 1) % 2 != 0) 1155 program_error("Odd number of keyword arguments."); 1156 if (length > 3) 1157 error(new WrongNumberOfArgumentsException(this, -1, 2)); // don't count the keyword itself as an argument 1158 if (args[1] == Keyword.NAME) 1159 name = args[2].STRING(); 1160 else 1161 program_error("Unrecognized keyword argument " 1162 + args[1].princToString() + "."); 1163 } 1164 return new LispThread(checkFunction(args[0]), name); 1165 } 1166 }; 1167 1168 @DocString(name="threadp", 1169 args="object", 1170 doc="Boolean predicate returning non-nil if OBJECT is a lisp thread") 1171 private static final Primitive THREADP = 1172 new Primitive("threadp", PACKAGE_THREADS, true) 1173 { 1174 @Override 1175 public LispObject execute(LispObject arg) 1176 { 1177 return arg instanceof LispThread ? T : NIL; 1178 } 1179 }; 1180 1181 @DocString(name="thread-alive-p", 1182 args="thread", 1183 doc="Returns T if THREAD is alive.") 1184 private static final Primitive THREAD_ALIVE_P = 1185 new Primitive("thread-alive-p", PACKAGE_THREADS, true, "thread", 1186 "Boolean predicate whether THREAD is alive.") 1187 { 1188 @Override 1189 public LispObject execute(LispObject arg) 1190 { 1191 final LispThread lispThread; 1192 if (arg instanceof LispThread) { 1193 lispThread = (LispThread) arg; 1194 } 1195 else { 1196 return type_error(arg, Symbol.THREAD); 1197 } 1198 return lispThread.javaThread.isAlive() ? T : NIL; 1199 } 1200 }; 1201 1202 @DocString(name="thread-name", 1203 args="thread", 1204 doc="Return the name of THREAD, if it has one.") 1205 private static final Primitive THREAD_NAME = 1206 new Primitive("thread-name", PACKAGE_THREADS, true) 1207 { 1208 @Override 1209 public LispObject execute(LispObject arg) 1210 { 1211 if (arg instanceof LispThread) { 1212 return ((LispThread)arg).name; 1213 } 1214 return type_error(arg, Symbol.THREAD); 1215 } 1216 }; 1217 1218 private static final Primitive THREAD_JOIN = 1219 new Primitive("thread-join", PACKAGE_THREADS, true, "thread", 1220 "Waits for THREAD to die before resuming execution\n" 1221 + "Returns the result of the joined thread as its primary value.\n" 1222 + "Returns T if the joined thread finishes normally or NIL if it was interrupted.") 1223 { 1224 @Override 1225 public LispObject execute(LispObject arg) 1226 { 1227 // join the thread, and returns its value. The second return 1228 // value is T if the thread finishes normally, NIL if its 1229 // interrupted. 1230 if (arg instanceof LispThread) { 1231 final LispThread joinedThread = (LispThread) arg; 1232 final LispThread waitingThread = currentThread(); 1233 try { 1234 joinedThread.javaThread.join(); 1235 return 1236 waitingThread.setValues(joinedThread.threadValue, T); 1237 } catch (InterruptedException e) { 1238 waitingThread.processThreadInterrupts(); 1239 return 1240 waitingThread.setValues(joinedThread.threadValue, NIL); 1241 } 1242 } else { 1243 return type_error(arg, Symbol.THREAD); 1244 } 1245 } 1246 }; 1247 1248 final static DoubleFloat THOUSAND = new DoubleFloat(1000); 1249 sleepMillisPart(LispObject seconds)1250 static final long sleepMillisPart(LispObject seconds) { 1251 double d 1252 = checkDoubleFloat(seconds.multiplyBy(THOUSAND)).getValue(); 1253 if (d < 0) { 1254 type_error(seconds, list(Symbol.REAL, Fixnum.ZERO)); 1255 } 1256 return (d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE); 1257 } 1258 sleepNanosPart(LispObject seconds)1259 static final int sleepNanosPart(LispObject seconds) { 1260 double d // d contains millis 1261 = checkDoubleFloat(seconds.multiplyBy(THOUSAND)).getValue(); 1262 double n = d * 1000000; // sleep interval in nanoseconds 1263 d = 1.0e6 * ((long)d); // sleep interval to millisecond precision 1264 n = n - d; 1265 1266 return (n < Integer.MAX_VALUE ? (int) n : Integer.MAX_VALUE); 1267 } 1268 1269 1270 @DocString(name="sleep", args="seconds", 1271 doc="Causes the invoking thread to sleep for an interveral expressed in SECONDS.\n" 1272 + "SECONDS may be specified as a fraction of a second, with intervals\n" 1273 + "less than or equal to a nanosecond resulting in a yield of execution\n" 1274 + "to other waiting threads rather than an actual sleep.\n" 1275 + "A zero value of SECONDS *may* result in the JVM sleeping indefinitely,\n" 1276 + "depending on the implementation.") 1277 private static final Primitive SLEEP = new Primitive("sleep", PACKAGE_CL, true) 1278 { 1279 @Override 1280 public LispObject execute(LispObject arg) 1281 { 1282 long millis = sleepMillisPart(arg); 1283 int nanos = sleepNanosPart(arg); 1284 boolean zeroArgP = arg.ZEROP() != NIL; 1285 1286 try { 1287 if (millis == 0 && nanos == 0) { 1288 if (zeroArgP) { 1289 Thread.sleep(0, 0); 1290 } else { 1291 Thread.sleep(0, 1); 1292 } 1293 } else { 1294 Thread.sleep(millis, nanos); 1295 } 1296 } catch (InterruptedException e) { 1297 currentThread().processThreadInterrupts(); 1298 } 1299 return NIL; 1300 } 1301 }; 1302 1303 @DocString(name="mapcar-threads", args= "function", 1304 doc="Applies FUNCTION to all existing threads.") 1305 private static final Primitive MAPCAR_THREADS = 1306 new Primitive("mapcar-threads", PACKAGE_THREADS, true) 1307 { 1308 @Override 1309 public LispObject execute(LispObject arg) 1310 { 1311 Function fun = checkFunction(arg); 1312 final LispThread thread = LispThread.currentThread(); 1313 LispObject result = NIL; 1314 Iterator it = map.values().iterator(); 1315 while (it.hasNext()) { 1316 LispObject[] args = new LispObject[1]; 1317 args[0] = (LispThread) it.next(); 1318 result = new Cons(funcall(fun, args, thread), result); 1319 } 1320 return result; 1321 } 1322 }; 1323 1324 @DocString(name="destroy-thread", args="thread", doc="Mark THREAD as destroyed") 1325 private static final Primitive DESTROY_THREAD = 1326 new Primitive("destroy-thread", PACKAGE_THREADS, true) 1327 { 1328 @Override 1329 public LispObject execute(LispObject arg) 1330 { 1331 final LispThread thread; 1332 if (arg instanceof LispThread) { 1333 thread = (LispThread) arg; 1334 } 1335 else { 1336 return type_error(arg, Symbol.THREAD); 1337 } 1338 thread.setDestroyed(true); 1339 return T; 1340 } 1341 }; 1342 1343 // => T 1344 @DocString(name="interrupt-thread", args="thread function &rest args", 1345 doc="Interrupts thread and forces it to apply function to args. When the\n"+ 1346 "function returns, the thread's original computation continues. If\n"+ 1347 "multiple interrupts are queued for a thread, they are all run, but the\n"+ 1348 "order is not guaranteed.") 1349 private static final Primitive INTERRUPT_THREAD = 1350 new Primitive("interrupt-thread", PACKAGE_THREADS, true, 1351 "thread function &rest args", 1352 "Interrupts THREAD and forces it to apply FUNCTION to ARGS.\nWhen the function returns, the thread's original computation continues. If multiple interrupts are queued for a thread, they are all run, but the order is not guaranteed.") 1353 { 1354 @Override 1355 public LispObject execute(LispObject[] args) 1356 { 1357 if (args.length < 2) 1358 return error(new WrongNumberOfArgumentsException(this, 2, -1)); 1359 final LispThread thread; 1360 if (args[0] instanceof LispThread) { 1361 thread = (LispThread) args[0]; 1362 } 1363 else { 1364 return type_error(args[0], Symbol.THREAD); 1365 } 1366 LispObject fun = args[1]; 1367 LispObject funArgs = NIL; 1368 for (int i = args.length; i-- > 2;) 1369 funArgs = new Cons(args[i], funArgs); 1370 thread.interrupt(fun, funArgs); 1371 return T; 1372 } 1373 }; 1374 1375 public static final Primitive CURRENT_THREAD 1376 = new pf_current_thread(); 1377 @DocString(name="current-thread", 1378 doc="Returns a reference to invoking thread.") 1379 private static final class pf_current_thread extends Primitive { pf_current_thread()1380 pf_current_thread() { 1381 super("current-thread", PACKAGE_THREADS, true); 1382 } 1383 @Override execute()1384 public LispObject execute() { 1385 return currentThread(); 1386 } 1387 }; 1388 1389 public static final Primitive BACKTRACE 1390 = new pf_backtrace(); 1391 @DocString(name="backtrace", 1392 doc="Returns a Java backtrace of the invoking thread.") 1393 private static final class pf_backtrace extends Primitive { pf_backtrace()1394 pf_backtrace() { 1395 super("backtrace", PACKAGE_SYS, true); 1396 } 1397 @Override execute(LispObject[] args)1398 public LispObject execute(LispObject[] args) { 1399 if (args.length > 1) 1400 return error(new WrongNumberOfArgumentsException(this, -1, 1)); 1401 int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0; 1402 return currentThread().backtrace(limit); 1403 } 1404 }; 1405 1406 public static final Primitive FRAME_TO_STRING 1407 = new pf_frame_to_string(); 1408 @DocString(name="frame-to-string", 1409 args="frame", 1410 doc="Convert stack FRAME to a (potentially) readable string.") 1411 private static final class pf_frame_to_string extends Primitive { pf_frame_to_string()1412 pf_frame_to_string() { 1413 super("frame-to-string", PACKAGE_SYS, true); 1414 } 1415 @Override execute(LispObject[] args)1416 public LispObject execute(LispObject[] args) { 1417 if (args.length != 1) 1418 return error(new WrongNumberOfArgumentsException(this, 1)); 1419 return checkStackFrame(args[0]).toLispString(); 1420 } 1421 }; 1422 1423 public static final Primitive FRAME_TO_LIST 1424 = new pf_frame_to_list(); 1425 @DocString(name="frame-to-list", args="frame") 1426 private static final class pf_frame_to_list extends Primitive { pf_frame_to_list()1427 pf_frame_to_list() { 1428 super("frame-to-list", PACKAGE_SYS, true); 1429 } 1430 @Override execute(LispObject[] args)1431 public LispObject execute(LispObject[] args) { 1432 if (args.length != 1) 1433 return error(new WrongNumberOfArgumentsException(this, 1)); 1434 1435 return checkStackFrame(args[0]).toLispList(); 1436 } 1437 }; 1438 1439 1440 public static final SpecialOperator SYNCHRONIZED_ON 1441 = new so_synchronized_on(); 1442 @DocString(name="synchronized-on", args="form &body body") 1443 private static final class so_synchronized_on extends SpecialOperator { so_synchronized_on()1444 so_synchronized_on() { 1445 super("synchronized-on", PACKAGE_THREADS, true, "form &body body"); 1446 } 1447 @Override execute(LispObject args, Environment env)1448 public LispObject execute(LispObject args, Environment env) { 1449 if (args == NIL) 1450 return error(new WrongNumberOfArgumentsException(this, 1)); 1451 1452 LispThread thread = LispThread.currentThread(); 1453 synchronized (eval(args.car(), env, thread).lockableInstance()) { 1454 return progn(args.cdr(), env, thread); 1455 } 1456 } 1457 }; 1458 1459 1460 public static final Primitive OBJECT_WAIT 1461 = new pf_object_wait(); 1462 @DocString( 1463 name="object-wait", args="object &optional timeout", 1464 doc="Causes the current thread to block until object-notify or object-notify-all is called on OBJECT.\n" 1465 + "Optionally unblock execution after TIMEOUT seconds. A TIMEOUT of zero\n" 1466 + "means to wait indefinitely.\n" 1467 + "A non-zero TIMEOUT of less than a nanosecond is interpolated as a nanosecond wait." 1468 + "\n" 1469 + "See the documentation of java.lang.Object.wait() for further\n" 1470 + "information.\n" 1471 ) 1472 private static final class pf_object_wait extends Primitive { pf_object_wait()1473 pf_object_wait() { 1474 super("object-wait", PACKAGE_THREADS, true); 1475 } 1476 @Override execute(LispObject object)1477 public LispObject execute(LispObject object) { 1478 try { 1479 object.lockableInstance().wait(); 1480 } catch (InterruptedException e) { 1481 currentThread().processThreadInterrupts(); 1482 } catch (IllegalMonitorStateException e) { 1483 return error(new IllegalMonitorState(e.getMessage())); 1484 } 1485 return NIL; 1486 } 1487 1488 @Override execute(LispObject object, LispObject timeout)1489 public LispObject execute(LispObject object, LispObject timeout) { 1490 long millis = sleepMillisPart(timeout); 1491 int nanos = sleepNanosPart(timeout); 1492 boolean zeroArgP = timeout.ZEROP() != NIL; 1493 1494 try { 1495 if (millis == 0 && nanos == 0) { 1496 if (zeroArgP) { 1497 object.lockableInstance().wait(0, 0); 1498 } else { 1499 object.lockableInstance().wait(0, 1); 1500 } 1501 } else { 1502 object.lockableInstance().wait(millis, nanos); 1503 } 1504 } catch (InterruptedException e) { 1505 currentThread().processThreadInterrupts(); 1506 } catch (IllegalMonitorStateException e) { 1507 return error(new IllegalMonitorState(e.getMessage())); 1508 } 1509 return NIL; 1510 } 1511 }; 1512 1513 public static final Primitive OBJECT_NOTIFY 1514 = new pf_object_notify(); 1515 @DocString(name="object-notify", 1516 args="object", 1517 doc="Wakes up a single thread that is waiting on OBJECT's monitor." 1518 + "\nIf any threads are waiting on this object, one of them is chosen to be" 1519 + " awakened. The choice is arbitrary and occurs at the discretion of the" 1520 + " implementation. A thread waits on an object's monitor by calling one" 1521 + " of the wait methods.") 1522 private static final class pf_object_notify extends Primitive { pf_object_notify()1523 pf_object_notify() { 1524 super("object-notify", PACKAGE_THREADS, true, "object"); 1525 } 1526 @Override execute(LispObject object)1527 public LispObject execute(LispObject object) { 1528 try { 1529 object.lockableInstance().notify(); 1530 } catch (IllegalMonitorStateException e) { 1531 return error(new IllegalMonitorState(e.getMessage())); 1532 } 1533 return NIL; 1534 } 1535 }; 1536 1537 public static final Primitive OBJECT_NOTIFY_ALL 1538 = new pf_object_notify_all(); 1539 @DocString(name="object-notify-all", 1540 args="object", 1541 doc="Wakes up all threads that are waiting on this OBJECT's monitor." 1542 + "\nA thread waits on an object's monitor by calling one of the wait methods.") 1543 private static final class pf_object_notify_all extends Primitive { pf_object_notify_all()1544 pf_object_notify_all() { 1545 super("object-notify-all", PACKAGE_THREADS, true); 1546 } 1547 @Override execute(LispObject object)1548 public LispObject execute(LispObject object) { 1549 try { 1550 object.lockableInstance().notifyAll(); 1551 } catch (IllegalMonitorStateException e) { 1552 return error(new IllegalMonitorState(e.getMessage())); 1553 } 1554 return NIL; 1555 } 1556 }; 1557 } 1558