001: /*
002: * LispThread.java
003: *
004: * Copyright (C) 2003-2004 Peter Graves
005: * $Id: LispThread.java,v 1.58 2004/09/09 12:43:23 piso Exp $
006: *
007: * This program is free software; you can redistribute it and/or
008: * modify it under the terms of the GNU General Public License
009: * as published by the Free Software Foundation; either version 2
010: * of the License, or (at your option) any later version.
011: *
012: * This program is distributed in the hope that it will be useful,
013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
015: * GNU General Public License for more details.
016: *
017: * You should have received a copy of the GNU General Public License
018: * along with this program; if not, write to the Free Software
019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
020: */
021:
022: package org.armedbear.lisp;
023:
024: import java.util.HashMap;
025: import java.util.Iterator;
026: import java.util.Stack;
027:
028: public final class LispThread extends LispObject {
029: private static final Object lock = new Object();
030:
031: private static HashMap map = new HashMap();
032:
033: public static final LispThread currentThread() {
034: Thread currentJavaThread = Thread.currentThread();
035: LispThread lispThread = get(currentJavaThread);
036: if (lispThread == null) {
037: lispThread = new LispThread(currentJavaThread);
038: put(currentJavaThread, lispThread);
039: }
040: return lispThread;
041: }
042:
043: private static void put(Thread javaThread, LispThread lispThread) {
044: synchronized (lock) {
045: HashMap m = (HashMap) map.clone();
046: m.put(javaThread, lispThread);
047: map = m;
048: }
049: }
050:
051: private static LispThread get(Thread javaThread) {
052: return (LispThread) map.get(javaThread);
053: }
054:
055: private static void remove(Thread javaThread) {
056: synchronized (lock) {
057: HashMap m = (HashMap) map.clone();
058: m.remove(javaThread);
059: map = m;
060: }
061: }
062:
063: private final Thread javaThread;
064: private boolean destroyed;
065: private final LispObject name;
066: public Environment dynEnv;
067: public LispObject[] _values;
068: private boolean threadInterrupted;
069: private LispObject pending = NIL;
070:
071: private LispThread(Thread javaThread) {
072: this .javaThread = javaThread;
073: name = new SimpleString(javaThread.getName());
074: }
075:
076: private LispThread(final Function fun, LispObject name) {
077: Runnable r = new Runnable() {
078: public void run() {
079: try {
080: funcall(fun, new LispObject[0], LispThread.this );
081: } catch (ThreadDestroyed ignored) {
082: ; // Might happen.
083: } catch (Throwable t) {
084: if (isInterrupted()) {
085: try {
086: processThreadInterrupts();
087: } catch (ConditionThrowable c) {
088: Debug.trace(c);
089: }
090: }
091: } finally {
092: remove(javaThread);
093: }
094: }
095: };
096: javaThread = new Thread(r);
097: put(javaThread, this );
098: this .name = name;
099: javaThread.start();
100: }
101:
102: public final synchronized boolean isDestroyed() {
103: return destroyed;
104: }
105:
106: private final synchronized boolean isInterrupted() {
107: return threadInterrupted;
108: }
109:
110: private final synchronized void setDestroyed(boolean b) {
111: destroyed = b;
112: }
113:
114: private final synchronized void interrupt(LispObject function,
115: LispObject args) {
116: pending = new Cons(args, pending);
117: pending = new Cons(function, pending);
118: threadInterrupted = true;
119: javaThread.interrupt();
120: }
121:
122: private final synchronized void processThreadInterrupts()
123: throws ConditionThrowable {
124: while (pending != NIL) {
125: LispObject function = pending.car();
126: LispObject args = pending.cadr();
127: pending = pending.cddr();
128: Primitives.APPLY.execute(function, args);
129: }
130: threadInterrupted = false;
131: }
132:
133: public final LispObject[] getValues() {
134: return _values;
135: }
136:
137: public final LispObject[] getValues(LispObject result, int count) {
138: if (_values == null) {
139: LispObject[] values = new LispObject[count];
140: if (count > 0)
141: values[0] = result;
142: for (int i = 1; i < count; i++)
143: values[i] = NIL;
144: return values;
145: }
146: // If the caller doesn't want any extra values, just return the ones
147: // we've got.
148: if (count <= _values.length)
149: return _values;
150: // The caller wants more values than we have. Pad with NILs.
151: LispObject[] values = new LispObject[count];
152: for (int i = _values.length; i-- > 0;)
153: values[i] = _values[i];
154: for (int i = _values.length; i < count; i++)
155: values[i] = NIL;
156: return values;
157: }
158:
159: // Used by the JVM compiler for MULTIPLE-VALUE-CALL.
160: public final LispObject[] accumulateValues(LispObject result,
161: LispObject[] oldValues) {
162: if (oldValues == null) {
163: if (_values != null)
164: return _values;
165: LispObject[] values = new LispObject[1];
166: values[0] = result;
167: return values;
168: }
169: if (_values != null) {
170: if (_values.length == 0)
171: return oldValues;
172: final int totalLength = oldValues.length + _values.length;
173: LispObject[] values = new LispObject[totalLength];
174: System.arraycopy(oldValues, 0, values, 0, oldValues.length);
175: System.arraycopy(_values, 0, values, oldValues.length,
176: _values.length);
177: return values;
178: }
179: // _values is null.
180: final int totalLength = oldValues.length + 1;
181: LispObject[] values = new LispObject[totalLength];
182: System.arraycopy(oldValues, 0, values, 0, oldValues.length);
183: values[totalLength - 1] = result;
184: return values;
185: }
186:
187: public final LispObject setValues() {
188: _values = new LispObject[0];
189: return NIL;
190: }
191:
192: public final LispObject setValues(LispObject value1) {
193: _values = null;
194: return value1;
195: }
196:
197: public final LispObject setValues(LispObject value1,
198: LispObject value2) {
199: _values = new LispObject[2];
200: _values[0] = value1;
201: _values[1] = value2;
202: return value1;
203: }
204:
205: public final LispObject setValues(LispObject value1,
206: LispObject value2, LispObject value3) {
207: _values = new LispObject[3];
208: _values[0] = value1;
209: _values[1] = value2;
210: _values[2] = value3;
211: return value1;
212: }
213:
214: public final LispObject setValues(LispObject[] values) {
215: if (values == null) {
216: Debug.assertTrue(false);
217: _values = null;
218: } else
219: _values = values;
220: return values.length > 0 ? values[0] : NIL;
221: }
222:
223: public final void clearValues() {
224: _values = null;
225: }
226:
227: public final LispObject nothing() {
228: _values = new LispObject[0];
229: return NIL;
230: }
231:
232: // Forces a single value, for situations where multiple values should be
233: // ignored.
234: public final LispObject value(LispObject obj) {
235: _values = null;
236: return obj;
237: }
238:
239: public final Environment getDynamicEnvironment() {
240: return dynEnv;
241: }
242:
243: public final void setDynamicEnvironment(Environment env) {
244: dynEnv = env;
245: }
246:
247: public final void bindSpecial(Symbol symbol, LispObject value) {
248: dynEnv = new Environment(dynEnv, symbol, value);
249: }
250:
251: public final LispObject lookupSpecial(LispObject symbol) {
252: return dynEnv != null ? dynEnv.lookup(symbol) : null;
253: }
254:
255: private LispObject catchTags = NIL;
256:
257: public void pushCatchTag(LispObject tag) throws ConditionThrowable {
258: catchTags = new Cons(tag, catchTags);
259: }
260:
261: public void popCatchTag() throws ConditionThrowable {
262: if (catchTags != NIL)
263: catchTags = catchTags.cdr();
264: else
265: Debug.assertTrue(false);
266: }
267:
268: public void throwToTag(LispObject tag, LispObject result)
269: throws ConditionThrowable {
270: LispObject rest = catchTags;
271: while (rest != NIL) {
272: if (rest.car() == tag)
273: throw new Throw(tag, result, this );
274: rest = rest.cdr();
275: }
276: signal(new ControlError(
277: "Attempt to throw to the nonexistent tag "
278: + tag.writeToString() + "."));
279: }
280:
281: private static class StackFrame extends LispObject {
282: private final LispObject functional;
283: private final LispObject[] argv;
284:
285: public StackFrame(LispObject functional, LispObject[] argv) {
286: this .functional = functional;
287: this .argv = argv;
288: }
289:
290: public LispObject getFunctional() {
291: return functional;
292: }
293:
294: public LispObject[] getArgumentVector() {
295: return argv;
296: }
297: }
298:
299: private LispObject stack = NIL;
300:
301: public LispObject getStack() {
302: return stack;
303: }
304:
305: public void setStack(LispObject stack) {
306: this .stack = stack;
307: }
308:
309: public void pushStackFrame(LispObject fun, LispObject[] args)
310: throws ConditionThrowable {
311: if (profiling && sampling) {
312: if (sampleNow)
313: Profiler.sample(this );
314: }
315: stack = new Cons((new StackFrame(fun, args)), stack);
316: }
317:
318: public void resetStack() {
319: stack = NIL;
320: }
321:
322: public LispObject execute(LispObject function)
323: throws ConditionThrowable {
324: LispObject oldStack = stack;
325: pushStackFrame(function, new LispObject[0]);
326: try {
327: return function.execute();
328: } finally {
329: if (profiling && sampling) {
330: if (sampleNow)
331: Profiler.sample(this );
332: }
333: stack = oldStack;
334: }
335: }
336:
337: public LispObject execute(LispObject function, LispObject arg)
338: throws ConditionThrowable {
339: LispObject oldStack = stack;
340: LispObject[] args = new LispObject[1];
341: args[0] = arg;
342: pushStackFrame(function, args);
343: try {
344: return function.execute(arg);
345: } finally {
346: if (profiling && sampling) {
347: if (sampleNow)
348: Profiler.sample(this );
349: }
350: stack = oldStack;
351: }
352: }
353:
354: public LispObject execute(LispObject function, LispObject first,
355: LispObject second) throws ConditionThrowable {
356: LispObject oldStack = stack;
357: LispObject[] args = new LispObject[2];
358: args[0] = first;
359: args[1] = second;
360: pushStackFrame(function, args);
361: try {
362: return function.execute(first, second);
363: } finally {
364: if (profiling && sampling) {
365: if (sampleNow)
366: Profiler.sample(this );
367: }
368: stack = oldStack;
369: }
370: }
371:
372: public LispObject execute(LispObject function, LispObject first,
373: LispObject second, LispObject third)
374: throws ConditionThrowable {
375: LispObject oldStack = stack;
376: LispObject[] args = new LispObject[3];
377: args[0] = first;
378: args[1] = second;
379: args[2] = third;
380: pushStackFrame(function, args);
381: try {
382: return function.execute(first, second, third);
383: } finally {
384: if (profiling && sampling) {
385: if (sampleNow)
386: Profiler.sample(this );
387: }
388: stack = oldStack;
389: }
390: }
391:
392: public LispObject execute(LispObject function, LispObject first,
393: LispObject second, LispObject third, LispObject fourth)
394: throws ConditionThrowable {
395: LispObject oldStack = stack;
396: LispObject[] args = new LispObject[4];
397: args[0] = first;
398: args[1] = second;
399: args[2] = third;
400: args[3] = fourth;
401: pushStackFrame(function, args);
402: try {
403: return function.execute(first, second, third, fourth);
404: } finally {
405: if (profiling && sampling) {
406: if (sampleNow)
407: Profiler.sample(this );
408: }
409: stack = oldStack;
410: }
411: }
412:
413: public LispObject execute(LispObject function, LispObject[] args)
414: throws ConditionThrowable {
415: LispObject oldStack = stack;
416: pushStackFrame(function, args);
417: try {
418: return function.execute(args);
419: } finally {
420: if (profiling && sampling) {
421: if (sampleNow)
422: Profiler.sample(this );
423: }
424: stack = oldStack;
425: }
426: }
427:
428: public void backtrace() {
429: backtrace(0);
430: }
431:
432: public void backtrace(int limit) {
433: if (stack != NIL) {
434: try {
435: int count = 0;
436: Stream out = checkCharacterOutputStream(_TRACE_OUTPUT_
437: .symbolValue());
438: out._writeLine("Evaluation stack:");
439: out._finishOutput();
440: while (stack != NIL) {
441: out._writeString(" ");
442: out._writeString(String.valueOf(count));
443: out._writeString(": ");
444: StackFrame frame = (StackFrame) stack.car();
445: stack = stack.cdr();
446: LispObject obj = NIL;
447: LispObject[] argv = frame.getArgumentVector();
448: for (int j = argv.length; j-- > 0;)
449: obj = new Cons(argv[j], obj);
450: LispObject functional = frame.getFunctional();
451: if (functional instanceof Functional
452: && ((Functional) functional)
453: .getLambdaName() != null)
454: obj = new Cons(((Functional) functional)
455: .getLambdaName(), obj);
456: else
457: obj = new Cons(functional, obj);
458: pprint(obj, out.getCharPos(), out);
459: out.terpri();
460: out._finishOutput();
461: if (limit > 0 && ++count == limit)
462: break;
463: }
464: } catch (Throwable t) {
465: t.printStackTrace();
466: }
467: }
468: }
469:
470: public LispObject backtraceAsList(int limit)
471: throws ConditionThrowable {
472: LispObject result = NIL;
473: if (stack != NIL) {
474: int count = 0;
475: try {
476: LispObject s = stack;
477: while (s != NIL) {
478: StackFrame frame = (StackFrame) s.car();
479: if (frame != null) {
480: LispObject obj = NIL;
481: LispObject[] argv = frame.getArgumentVector();
482: for (int j = argv.length; j-- > 0;) {
483: if (argv[j] != null)
484: obj = new Cons(argv[j], obj);
485: }
486: LispObject functional = frame.getFunctional();
487: if (functional instanceof Functional
488: && ((Functional) functional)
489: .getLambdaName() != null)
490: obj = new Cons(((Functional) functional)
491: .getLambdaName(), obj);
492: else
493: obj = new Cons(functional, obj);
494: result = new Cons(obj, result);
495: if (limit > 0 && ++count == limit)
496: break;
497: }
498: s = s.cdr();
499: }
500: } catch (Throwable t) {
501: t.printStackTrace();
502: }
503: }
504: return result.nreverse();
505: }
506:
507: public void incrementCallCounts() throws ConditionThrowable {
508: LispObject s = stack;
509: while (s != NIL) {
510: StackFrame frame = (StackFrame) s.car();
511: if (frame != null) {
512: LispObject functional = frame.getFunctional();
513: if (functional != null)
514: functional.incrementCallCount();
515: }
516: s = s.cdr();
517: }
518: }
519:
520: private static void pprint(LispObject obj, int indentBy,
521: Stream stream) throws ConditionThrowable {
522: if (stream.getCharPos() == 0) {
523: StringBuffer sb = new StringBuffer();
524: for (int i = 0; i < indentBy; i++)
525: sb.append(' ');
526: stream._writeString(sb.toString());
527: }
528: String raw = obj.writeToString();
529: if (stream.getCharPos() + raw.length() < 80) {
530: // It fits.
531: stream._writeString(raw);
532: return;
533: }
534: // Object doesn't fit.
535: if (obj instanceof Cons) {
536: try {
537: boolean newlineBefore = false;
538: LispObject[] array = obj.copyToArray();
539: if (array.length > 0) {
540: LispObject first = array[0];
541: if (first == Symbol.LET) {
542: newlineBefore = true;
543: }
544: }
545: int charPos = stream.getCharPos();
546: if (newlineBefore && charPos != indentBy) {
547: stream.terpri();
548: charPos = stream.getCharPos();
549: }
550: if (charPos < indentBy) {
551: StringBuffer sb = new StringBuffer();
552: for (int i = charPos; i < indentBy; i++)
553: sb.append(' ');
554: stream._writeString(sb.toString());
555: }
556: stream.print('(');
557: for (int i = 0; i < array.length; i++) {
558: pprint(array[i], indentBy + 2, stream);
559: if (i < array.length - 1)
560: stream.print(' ');
561: }
562: stream.print(')');
563: } catch (ConditionThrowable t) {
564: Debug.trace(t);
565: }
566: } else {
567: stream.terpri();
568: StringBuffer sb = new StringBuffer();
569: for (int i = 0; i < indentBy; i++)
570: sb.append(' ');
571: stream._writeString(sb.toString());
572: stream._writeString(raw);
573: return;
574: }
575: }
576:
577: public String writeToString() throws ConditionThrowable {
578: StringBuffer sb = new StringBuffer("#<THREAD ");
579: if (name != NIL) {
580: sb.append('"');
581: sb.append(name.getStringValue());
582: sb.append("\" ");
583: }
584: sb.append("@ #x");
585: sb.append(Integer.toHexString(System.identityHashCode(this )));
586: sb.append(">");
587: return sb.toString();
588: }
589:
590: // ### make-thread
591: private static final Primitive MAKE_THREAD = new Primitive(
592: "make-thread", PACKAGE_EXT, true, "function &key name") {
593: public LispObject execute(LispObject[] args)
594: throws ConditionThrowable {
595: final int length = args.length;
596: if (length == 0)
597: signal(new WrongNumberOfArgumentsException(this ));
598: LispObject name = NIL;
599: if (length > 1) {
600: if ((length - 1) % 2 != 0)
601: signal(new ProgramError(
602: "Odd number of keyword arguments."));
603: if (length > 3)
604: signal(new WrongNumberOfArgumentsException(this ));
605: if (args[1] == Keyword.NAME)
606: name = args[2].STRING();
607: else
608: signal(new ProgramError(
609: "Unrecognized keyword argument "
610: + args[1].writeToString() + "."));
611: }
612: return new LispThread(checkFunction(args[0]), name);
613: }
614: };
615:
616: // ### thread-alive-p
617: private static final Primitive1 THREAD_ALIVE_P = new Primitive1(
618: "thread-alive-p", PACKAGE_EXT, true, "thread") {
619: public LispObject execute(LispObject arg)
620: throws ConditionThrowable {
621: try {
622: return ((LispThread) arg).javaThread.isAlive() ? T
623: : NIL;
624: } catch (ClassCastException e) {
625: return signal(new TypeError(arg, "Lisp thread"));
626: }
627: }
628: };
629:
630: // ### thread-name
631: private static final Primitive1 THREAD_NAME = new Primitive1(
632: "thread-name", PACKAGE_EXT, true, "thread") {
633: public LispObject execute(LispObject arg)
634: throws ConditionThrowable {
635: try {
636: return ((LispThread) arg).name;
637: } catch (ClassCastException e) {
638: return signal(new TypeError(arg, "Lisp thread"));
639: }
640: }
641: };
642:
643: // ### sleep
644: private static final Primitive1 SLEEP = new Primitive1("sleep",
645: "seconds") {
646: public LispObject execute(LispObject arg)
647: throws ConditionThrowable {
648: double d = ((LispFloat) arg.multiplyBy(new LispFloat(1000)))
649: .getValue();
650: if (d < 0)
651: return signal(new TypeError(arg, "non-negative real"));
652: long millis = d < Long.MAX_VALUE ? (long) d
653: : Long.MAX_VALUE;
654: try {
655: Thread.currentThread().sleep(millis);
656: } catch (InterruptedException e) {
657: currentThread().processThreadInterrupts();
658: }
659: return NIL;
660: }
661: };
662:
663: // ### mapcar-threads
664: private static final Primitive1 MAPCAR_THREADS = new Primitive1(
665: "mapcar-threads", PACKAGE_EXT, true) {
666: public LispObject execute(LispObject arg)
667: throws ConditionThrowable {
668: Function fun = checkFunction(arg);
669: final LispThread thread = LispThread.currentThread();
670: LispObject result = NIL;
671: Iterator it = map.values().iterator();
672: while (it.hasNext()) {
673: LispObject[] args = new LispObject[1];
674: args[0] = (LispThread) it.next();
675: result = new Cons(funcall(fun, args, thread), result);
676: }
677: return result;
678: }
679: };
680:
681: // ### destroy-thread
682: private static final Primitive1 DESTROY_THREAD = new Primitive1(
683: "destroy-thread", PACKAGE_EXT, true) {
684: public LispObject execute(LispObject arg)
685: throws ConditionThrowable {
686: if (arg instanceof LispThread) {
687: LispThread thread = (LispThread) arg;
688: thread.setDestroyed(true);
689: return T;
690: } else
691: return signal(new TypeError(arg, "Lisp thread"));
692: }
693: };
694:
695: // ### interrupt-thread thread function &rest args => T
696: // Interrupts thread and forces it to apply function to args. When the
697: // function returns, the thread's original computation continues. If
698: // multiple interrupts are queued for a thread, they are all run, but the
699: // order is not guaranteed.
700: private static final Primitive INTERRUPT_THREAD = new Primitive(
701: "interrupt-thread", PACKAGE_EXT, true) {
702: public LispObject execute(LispObject[] args)
703: throws ConditionThrowable {
704: if (args.length < 2)
705: return signal(new WrongNumberOfArgumentsException(this ));
706: if (args[0] instanceof LispThread) {
707: LispThread thread = (LispThread) args[0];
708: LispObject fun = args[1];
709: LispObject funArgs = NIL;
710: for (int i = args.length; i-- > 2;)
711: funArgs = new Cons(args[i], funArgs);
712: thread.interrupt(fun, funArgs);
713: return T;
714: } else
715: return signal(new TypeError(args[0], "Lisp thread"));
716: }
717: };
718:
719: // ### current-thread
720: private static final Primitive0 CURRENT_THREAD = new Primitive0(
721: "current-thread", PACKAGE_EXT, true) {
722: public LispObject execute() throws ConditionThrowable {
723: return currentThread();
724: }
725: };
726:
727: // ### backtrace
728: private static final Primitive BACKTRACE = new Primitive(
729: "backtrace", PACKAGE_EXT, true) {
730: public LispObject execute(LispObject[] args)
731: throws ConditionThrowable {
732: if (args.length > 1)
733: return signal(new WrongNumberOfArgumentsException(this ));
734: int count = args.length > 0 ? Fixnum.getValue(args[0]) : 0;
735: LispThread thread = currentThread();
736: thread.backtrace(count);
737: return thread.nothing();
738: }
739: };
740:
741: // ### backtrace-as-list
742: private static final Primitive BACKTRACE_AS_LIST = new Primitive(
743: "backtrace-as-list", PACKAGE_EXT, true) {
744: public LispObject execute(LispObject[] args)
745: throws ConditionThrowable {
746: if (args.length > 1)
747: return signal(new WrongNumberOfArgumentsException(this ));
748: int limit = args.length > 0 ? Fixnum.getValue(args[0]) : 0;
749: return currentThread().backtraceAsList(limit);
750: }
751: };
752: }
|