1 21 22 package org.armedbear.lisp; 23 24 import java.util.HashMap ; 25 import java.util.Iterator ; 26 import java.util.Stack ; 27 28 public final class LispThread extends LispObject 29 { 30 private static final Object lock = new Object (); 31 32 private static HashMap map = new HashMap (); 33 34 public static final LispThread currentThread() 35 { 36 Thread currentJavaThread = Thread.currentThread(); 37 LispThread lispThread = get(currentJavaThread); 38 if (lispThread == null) { 39 lispThread = new LispThread(currentJavaThread); 40 put(currentJavaThread, lispThread); 41 } 42 return lispThread; 43 } 44 45 private static void put(Thread javaThread, LispThread lispThread) 46 { 47 synchronized (lock) { 48 HashMap m = (HashMap ) map.clone(); 49 m.put(javaThread, lispThread); 50 map = m; 51 } 52 } 53 54 private static LispThread get(Thread javaThread) 55 { 56 return (LispThread) map.get(javaThread); 57 } 58 59 private static void remove(Thread javaThread) 60 { 61 synchronized (lock) { 62 HashMap m = (HashMap ) map.clone(); 63 m.remove(javaThread); 64 map = m; 65 } 66 } 67 68 private final Thread javaThread; 69 private boolean destroyed; 70 private final LispObject name; 71 public Environment dynEnv; 72 public LispObject[] _values; 73 private boolean threadInterrupted; 74 private LispObject pending = NIL; 75 76 private LispThread(Thread javaThread) 77 { 78 this.javaThread = javaThread; 79 name = new SimpleString(javaThread.getName()); 80 } 81 82 private LispThread(final Function fun, LispObject name) 83 { 84 Runnable r = new Runnable () { 85 public void run() 86 { 87 try { 88 funcall(fun, new LispObject[0], LispThread.this); 89 } 90 catch (ThreadDestroyed ignored) { 91 ; } 93 catch (Throwable t) { 94 if (isInterrupted()) { 95 try { 96 processThreadInterrupts(); 97 } 98 catch (ConditionThrowable c) { 99 Debug.trace(c); 100 } 101 } 102 } 103 finally { 104 remove(javaThread); 105 } 106 } 107 }; 108 javaThread = new Thread (r); 109 put(javaThread, this); 110 this.name = name; 111 javaThread.start(); 112 } 113 114 public final synchronized boolean isDestroyed() 115 { 116 return destroyed; 117 } 118 119 private final synchronized boolean isInterrupted() 120 { 121 return threadInterrupted; 122 } 123 124 private final synchronized void setDestroyed(boolean b) 125 { 126 destroyed = b; 127 } 128 129 private final synchronized void interrupt(LispObject function, LispObject args) 130 { 131 pending = new Cons(args, pending); 132 pending = new Cons(function, pending); 133 threadInterrupted = true; 134 javaThread.interrupt(); 135 } 136 137 private final synchronized void processThreadInterrupts() 138 throws ConditionThrowable 139 { 140 while (pending != NIL) { 141 LispObject function = pending.car(); 142 LispObject args = pending.cadr(); 143 pending = pending.cddr(); 144 Primitives.APPLY.execute(function, args); 145 } 146 threadInterrupted = false; 147 } 148 149 public final LispObject[] getValues() 150 { 151 return _values; 152 } 153 154 public final LispObject[] getValues(LispObject result, int count) 155 { 156 if (_values == null) { 157 LispObject[] values = new LispObject[count]; 158 if (count > 0) 159 values[0] = result; 160 for (int i = 1; i < count; i++) 161 values[i] = NIL; 162 return values; 163 } 164 if (count <= _values.length) 167 return _values; 168 LispObject[] values = new LispObject[count]; 170 for (int i = _values.length; i-- > 0;) 171 values[i] = _values[i]; 172 for (int i = _values.length; i < count; i++) 173 values[i] = NIL; 174 return values; 175 } 176 177 public final LispObject[] accumulateValues(LispObject result, 179 LispObject[] oldValues) 180 { 181 if (oldValues == null) { 182 if (_values != null) 183 return _values; 184 LispObject[] values = new LispObject[1]; 185 values[0] = result; 186 return values; 187 } 188 if (_values != null) { 189 if (_values.length == 0) 190 return oldValues; 191 final int totalLength = oldValues.length + _values.length; 192 LispObject[] values = new LispObject[totalLength]; 193 System.arraycopy(oldValues, 0, 194 values, 0, 195 oldValues.length); 196 System.arraycopy(_values, 0, 197 values, oldValues.length, 198 _values.length); 199 return values; 200 } 201 final int totalLength = oldValues.length + 1; 203 LispObject[] values = new LispObject[totalLength]; 204 System.arraycopy(oldValues, 0, 205 values, 0, 206 oldValues.length); 207 values[totalLength - 1] = result; 208 return values; 209 } 210 211 public final LispObject setValues() 212 { 213 _values = new LispObject[0]; 214 return NIL; 215 } 216 217 public final LispObject setValues(LispObject value1) 218 { 219 _values = null; 220 return value1; 221 } 222 223 public final LispObject setValues(LispObject value1, LispObject value2) 224 { 225 _values = new LispObject[2]; 226 _values[0] = value1; 227 _values[1] = value2; 228 return value1; 229 } 230 231 public final LispObject setValues(LispObject value1, LispObject value2, 232 LispObject value3) 233 { 234 _values = new LispObject[3]; 235 _values[0] = value1; 236 _values[1] = value2; 237 _values[2] = value3; 238 return value1; 239 } 240 241 public final LispObject setValues(LispObject[] values) 242 { 243 if (values == null) { 244 Debug.assertTrue(false); 245 _values = null; 246 } else 247 _values = values; 248 return values.length > 0 ? values[0] : NIL; 249 } 250 251 public final void clearValues() 252 { 253 _values = null; 254 } 255 256 public final LispObject nothing() 257 { 258 _values = new LispObject[0]; 259 return NIL; 260 } 261 262 public final LispObject value(LispObject obj) 265 { 266 _values = null; 267 return obj; 268 } 269 270 public final Environment getDynamicEnvironment() 271 { 272 return dynEnv; 273 } 274 275 public final void setDynamicEnvironment(Environment env) 276 { 277 dynEnv = env; 278 } 279 280 public final void bindSpecial(Symbol symbol, LispObject value) 281 { 282 dynEnv = new Environment(dynEnv, symbol, value); 283 } 284 285 public final LispObject lookupSpecial(LispObject symbol) 286 { 287 return dynEnv != null ? dynEnv.lookup(symbol) : null; 288 } 289 290 private LispObject catchTags = NIL; 291 292 public void pushCatchTag(LispObject tag) throws ConditionThrowable 293 { 294 catchTags = new Cons(tag, catchTags); 295 } 296 297 public void popCatchTag() throws ConditionThrowable 298 { 299 if (catchTags != NIL) 300 catchTags = catchTags.cdr(); 301 else 302 Debug.assertTrue(false); 303 } 304 305 public void throwToTag(LispObject tag, LispObject result) 306 throws ConditionThrowable 307 { 308 LispObject rest = catchTags; 309 while (rest != NIL) { 310 if (rest.car() == tag) 311 throw new Throw(tag, result, this); 312 rest = rest.cdr(); 313 } 314 signal(new ControlError("Attempt to throw to the nonexistent tag " + 315 tag.writeToString() + ".")); 316 } 317 318 private static class StackFrame extends LispObject 319 { 320 private final LispObject functional; 321 private final LispObject[] argv; 322 323 public StackFrame(LispObject functional, LispObject[] argv) 324 { 325 this.functional = functional; 326 this.argv = argv; 327 } 328 329 public LispObject getFunctional() 330 { 331 return functional; 332 } 333 334 public LispObject[] getArgumentVector() 335 { 336 return argv; 337 } 338 } 339 340 private LispObject stack = NIL; 341 342 public LispObject getStack() 343 { 344 return stack; 345 } 346 347 public void setStack(LispObject stack) 348 { 349 this.stack = stack; 350 } 351 352 public void pushStackFrame(LispObject fun, LispObject[] args) 353 throws ConditionThrowable 354 { 355 if (profiling && sampling) { 356 if (sampleNow) 357 Profiler.sample(this); 358 } 359 stack = new Cons((new StackFrame(fun, args)), stack); 360 } 361 362 public void resetStack() 363 { 364 stack = NIL; 365 } 366 367 public LispObject execute(LispObject function) throws ConditionThrowable 368 { 369 LispObject oldStack = stack; 370 pushStackFrame(function, new LispObject[0]); 371 try { 372 return function.execute(); 373 } 374 finally { 375 if (profiling && sampling) { 376 if (sampleNow) 377 Profiler.sample(this); 378 } 379 stack = oldStack; 380 } 381 } 382 383 public LispObject execute(LispObject function, LispObject arg) 384 throws ConditionThrowable 385 { 386 LispObject oldStack = stack; 387 LispObject[] args = new LispObject[1]; 388 args[0] = arg; 389 pushStackFrame(function, args); 390 try { 391 return function.execute(arg); 392 } 393 finally { 394 if (profiling && sampling) { 395 if (sampleNow) 396 Profiler.sample(this); 397 } 398 stack = oldStack; 399 } 400 } 401 402 public LispObject execute(LispObject function, LispObject first, 403 LispObject second) 404 throws ConditionThrowable 405 { 406 LispObject oldStack = stack; 407 LispObject[] args = new LispObject[2]; 408 args[0] = first; 409 args[1] = second; 410 pushStackFrame(function, args); 411 try { 412 return function.execute(first, second); 413 } 414 finally { 415 if (profiling && sampling) { 416 if (sampleNow) 417 Profiler.sample(this); 418 } 419 stack = oldStack; 420 } 421 } 422 423 public LispObject execute(LispObject function, LispObject first, 424 LispObject second, LispObject third) 425 throws ConditionThrowable 426 { 427 LispObject oldStack = stack; 428 LispObject[] args = new LispObject[3]; 429 args[0] = first; 430 args[1] = second; 431 args[2] = third; 432 pushStackFrame(function, args); 433 try { 434 return function.execute(first, second, third); 435 } 436 finally { 437 if (profiling && sampling) { 438 if (sampleNow) 439 Profiler.sample(this); 440 } 441 stack = oldStack; 442 } 443 } 444 445 public LispObject execute(LispObject function, LispObject first, 446 LispObject second, LispObject third, 447 LispObject fourth) 448 throws ConditionThrowable 449 { 450 LispObject oldStack = stack; 451 LispObject[] args = new LispObject[4]; 452 args[0] = first; 453 args[1] = second; 454 args[2] = third; 455 args[3] = fourth; 456 pushStackFrame(function, args); 457 try { 458 return function.execute(first, second, third, fourth); 459 } 460 finally { 461 if (profiling && sampling) { 462 if (sampleNow) 463 Profiler.sample(this); 464 } 465 stack = oldStack; 466 } 467 } 468 469 public LispObject execute(LispObject function, LispObject[] args) 470 throws ConditionThrowable 471 { 472 LispObject oldStack = stack; 473 pushStackFrame(function, args); 474 try { 475 return function.execute(args); 476 } 477 finally { 478 if (profiling && sampling) { 479 if (sampleNow) 480 Profiler.sample(this); 481 } 482 stack = oldStack; 483 } 484 } 485 486 public void backtrace() 487 { 488 backtrace(0); 489 } 490 491 public void backtrace(int limit) 492 { 493 if (stack != NIL) { 494 try { 495 int count = 0; 496 Stream out = 497 checkCharacterOutputStream(_TRACE_OUTPUT_.symbolValue()); 498 out._writeLine("Evaluation stack:"); 499 out._finishOutput(); 500 while (stack != NIL) { 501 out._writeString(" "); 502 out._writeString(String.valueOf(count)); 503 out._writeString(": "); 504 StackFrame frame = (StackFrame) stack.car(); 505 stack = stack.cdr(); 506 LispObject obj = NIL; 507 LispObject[] argv = frame.getArgumentVector(); 508 for (int j = argv.length; j-- > 0;) 509 obj = new Cons(argv[j], obj); 510 LispObject functional = frame.getFunctional(); 511 if (functional instanceof Functional && 512 ((Functional)functional).getLambdaName() != null) 513 obj = new Cons(((Functional)functional).getLambdaName(), obj); 514 else 515 obj = new Cons(functional, obj); 516 pprint(obj, out.getCharPos(), out); 517 out.terpri(); 518 out._finishOutput(); 519 if (limit > 0 && ++count == limit) 520 break; 521 } 522 } 523 catch (Throwable t) { 524 t.printStackTrace(); 525 } 526 } 527 } 528 529 public LispObject backtraceAsList(int limit) throws ConditionThrowable 530 { 531 LispObject result = NIL; 532 if (stack != NIL) { 533 int count = 0; 534 try { 535 LispObject s = stack; 536 while (s != NIL) { 537 StackFrame frame = (StackFrame) s.car(); 538 if (frame != null) { 539 LispObject obj = NIL; 540 LispObject[] argv = frame.getArgumentVector(); 541 for (int j = argv.length; j-- > 0;) { 542 if (argv[j] != null) 543 obj = new Cons(argv[j], obj); 544 } 545 LispObject functional = frame.getFunctional(); 546 if (functional instanceof Functional && 547 ((Functional)functional).getLambdaName() != null) 548 obj = new Cons(((Functional)functional).getLambdaName(), obj); 549 else 550 obj = new Cons(functional, obj); 551 result = new Cons(obj, result); 552 if (limit > 0 && ++count == limit) 553 break; 554 } 555 s = s.cdr(); 556 } 557 } 558 catch (Throwable t) { 559 t.printStackTrace(); 560 } 561 } 562 return result.nreverse(); 563 } 564 565 public void incrementCallCounts() throws ConditionThrowable 566 { 567 LispObject s = stack; 568 while (s != NIL) { 569 StackFrame frame = (StackFrame) s.car(); 570 if (frame != null) { 571 LispObject functional = frame.getFunctional(); 572 if (functional != null) 573 functional.incrementCallCount(); 574 } 575 s = s.cdr(); 576 } 577 } 578 579 private static void pprint(LispObject obj, int indentBy, Stream stream) 580 throws ConditionThrowable 581 { 582 if (stream.getCharPos() == 0) { 583 StringBuffer sb = new StringBuffer (); 584 for (int i = 0; i < indentBy; i++) 585 sb.append(' '); 586 stream._writeString(sb.toString()); 587 } 588 String raw = obj.writeToString(); 589 if (stream.getCharPos() + raw.length() < 80) { 590 stream._writeString(raw); 592 return; 593 } 594 if (obj instanceof Cons) { 596 try { 597 boolean newlineBefore = false; 598 LispObject[] array = obj.copyToArray(); 599 if (array.length > 0) { 600 LispObject first = array[0]; 601 if (first == Symbol.LET) { 602 newlineBefore = true; 603 } 604 } 605 int charPos = stream.getCharPos(); 606 if (newlineBefore && charPos != indentBy) { 607 stream.terpri(); 608 charPos = stream.getCharPos(); 609 } 610 if (charPos < indentBy) { 611 StringBuffer sb = new StringBuffer (); 612 for (int i = charPos; i < indentBy; i++) 613 sb.append(' '); 614 stream._writeString(sb.toString()); 615 } 616 stream.print('('); 617 for (int i = 0; i < array.length; i++) { 618 pprint(array[i], indentBy + 2, stream); 619 if (i < array.length - 1) 620 stream.print(' '); 621 } 622 stream.print(')'); 623 } 624 catch (ConditionThrowable t) { 625 Debug.trace(t); 626 } 627 } else { 628 stream.terpri(); 629 StringBuffer sb = new StringBuffer (); 630 for (int i = 0; i < indentBy; i++) 631 sb.append(' '); 632 stream._writeString(sb.toString()); 633 stream._writeString(raw); 634 return; 635 } 636 } 637 638 public String writeToString() throws ConditionThrowable 639 { 640 StringBuffer sb = new StringBuffer ("#<THREAD "); 641 if (name != NIL) { 642 sb.append('"'); 643 sb.append(name.getStringValue()); 644 sb.append("\" "); 645 } 646 sb.append("@ #x"); 647 sb.append(Integer.toHexString(System.identityHashCode(this))); 648 sb.append(">"); 649 return sb.toString(); 650 } 651 652 private static final Primitive MAKE_THREAD = 654 new Primitive("make-thread", PACKAGE_EXT, true, "function &key name") 655 { 656 public LispObject execute(LispObject[] args) throws ConditionThrowable 657 { 658 final int length = args.length; 659 if (length == 0) 660 signal(new WrongNumberOfArgumentsException(this)); 661 LispObject name = NIL; 662 if (length > 1) { 663 if ((length - 1) % 2 != 0) 664 signal(new ProgramError("Odd number of keyword arguments.")); 665 if (length > 3) 666 signal(new WrongNumberOfArgumentsException(this)); 667 if (args[1] == Keyword.NAME) 668 name = args[2].STRING(); 669 else 670 signal(new ProgramError("Unrecognized keyword argument " + 671 args[1].writeToString() + ".")); 672 } 673 return new LispThread(checkFunction(args[0]), name); 674 } 675 }; 676 677 private static final Primitive1 THREAD_ALIVE_P = 679 new Primitive1("thread-alive-p", PACKAGE_EXT, true, "thread") 680 { 681 public LispObject execute(LispObject arg) throws ConditionThrowable 682 { 683 try { 684 return ((LispThread)arg).javaThread.isAlive() ? T : NIL; 685 } 686 catch (ClassCastException e) { 687 return signal(new TypeError(arg, "Lisp thread")); 688 } 689 } 690 }; 691 692 private static final Primitive1 THREAD_NAME = 694 new Primitive1("thread-name", PACKAGE_EXT, true, "thread") 695 { 696 public LispObject execute(LispObject arg) throws ConditionThrowable 697 { 698 try { 699 return ((LispThread)arg).name; 700 } 701 catch (ClassCastException e) { 702 return signal(new TypeError(arg, "Lisp thread")); 703 } 704 } 705 }; 706 707 private static final Primitive1 SLEEP = new Primitive1("sleep", "seconds") 709 { 710 public LispObject execute(LispObject arg) throws ConditionThrowable 711 { 712 double d = 713 ((LispFloat)arg.multiplyBy(new LispFloat(1000))).getValue(); 714 if (d < 0) 715 return signal(new TypeError(arg, "non-negative real")); 716 long millis = d < Long.MAX_VALUE ? (long) d : Long.MAX_VALUE; 717 try { 718 Thread.currentThread().sleep(millis); 719 } 720 catch (InterruptedException e) { 721 currentThread().processThreadInterrupts(); 722 } 723 return NIL; 724 } 725 }; 726 727 private static final Primitive1 MAPCAR_THREADS = 729 new Primitive1("mapcar-threads", PACKAGE_EXT, true) 730 { 731 public LispObject execute(LispObject arg) throws ConditionThrowable 732 { 733 Function fun = checkFunction(arg); 734 final LispThread thread = LispThread.currentThread(); 735 LispObject result = NIL; 736 Iterator it = map.values().iterator(); 737 while (it.hasNext()) { 738 LispObject[] args = new LispObject[1]; 739 args[0] = (LispThread) it.next(); 740 result = new Cons(funcall(fun, args, thread), result); 741 } 742 return result; 743 } 744 }; 745 746 private static final Primitive1 DESTROY_THREAD = 748 new Primitive1("destroy-thread", PACKAGE_EXT, true) 749 { 750 public LispObject execute(LispObject arg) throws ConditionThrowable 751 { 752 if (arg instanceof LispThread) { 753 LispThread thread = (LispThread) arg; 754 thread.setDestroyed(true); 755 return T; 756 } else 757 return signal(new TypeError(arg, "Lisp thread")); 758 } 759 }; 760 761 private static final Primitive INTERRUPT_THREAD = 767 new Primitive("interrupt-thread", PACKAGE_EXT, true) 768 { 769 public LispObject execute(LispObject[] args) throws ConditionThrowable 770 { 771 if (args.length < 2) 772 return signal(new WrongNumberOfArgumentsException(this)); 773 if (args[0] instanceof LispThread) { 774 LispThread thread = (LispThread) args[0]; 775 LispObject fun = args[1]; 776 LispObject funArgs = NIL; 777 for (int i = args.length; i-- > 2;) 778 funArgs = new Cons(args[i], funArgs); 779 thread.interrupt(fun, funArgs); 780 return T; 781 } else 782 return signal(new TypeError(args[0], "Lisp thread")); 783 } 784 }; 785 786 private static final Primitive0 CURRENT_THREAD = 788 new Primitive0("current-thread", PACKAGE_EXT, true) 789 { 790 public LispObject execute() throws ConditionThrowable 791 { 792 return currentThread(); 793 } 794 }; 795 796 private static final Primitive BACKTRACE = 798 new Primitive("backtrace", PACKAGE_EXT, true) 799 { 800 public LispObject execute(LispObject[] args) 801 throws ConditionThrowable 802 { 803 if (args.length > 1) 804 return signal(new WrongNumberOfArgumentsException(this)); 805 int count = args.length > 0 ? Fixnum.getValue(args[0]) : 0; 806 LispThread thread = currentThread(); 807 thread.backtrace(count); 808 return thread.nothing(); 809 } 810 }; 811 812 private static final Primitive BACKTRACE_AS_LIST = 814 new Primitive("backtrace-as-list", PACKAGE_EXT, true) 815 { 816 public LispObject execute(LispObject[] args) 817 throws ConditionThrowable 818 { 819 if (args.length > 1) 820 return signal(new WrongNumberOfArgumentsException(this)); 821 int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0; 822 return currentThread().backtraceAsList(limit); 823 } 824 }; 825 } 826 | Popular Tags |