[armedbear-cvs] r12040 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Jul 12 18:36:50 UTC 2009
Author: ehuelsmann
Date: Sun Jul 12 14:36:47 2009
New Revision: 12040
Log:
Add synchronization like in Java through the special operator SYNCHRONIZED-ON.
Added:
trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java (contents, props changed)
Modified:
trunk/abcl/src/org/armedbear/lisp/LispThread.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
Added: trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/IllegalMonitorState.java Sun Jul 12 14:36:47 2009
@@ -0,0 +1,53 @@
+/*
+ * IllegalMonitorState.java
+ *
+ * Copyright (C) 2002-2005 Peter Graves
+ * $Id$
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+public final class IllegalMonitorState extends ProgramError
+{
+ public IllegalMonitorState()
+ throws ConditionThrowable
+ {
+ // This is really just an ordinary PROGRAM-ERROR, broken out into its
+ // own Java class as a convenience for the implementation.
+ super(StandardClass.PROGRAM_ERROR);
+ setFormatControl(getMessage());
+ setFormatArguments(NIL);
+ }
+
+ @Override
+ public String getMessage()
+ {
+ return "Illegal monitor state.";
+ }
+}
Modified: trunk/abcl/src/org/armedbear/lisp/LispThread.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/LispThread.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/LispThread.java Sun Jul 12 14:36:47 2009
@@ -1012,7 +1012,7 @@
// ### make-thread
private static final Primitive MAKE_THREAD =
- new Primitive("make-thread", PACKAGE_EXT, true, "function &key name")
+ new Primitive("make-thread", PACKAGE_THREADS, true, "function &key name")
{
@Override
public LispObject execute(LispObject[] args) throws ConditionThrowable
@@ -1038,7 +1038,7 @@
// ### threadp
private static final Primitive THREADP =
- new Primitive("threadp", PACKAGE_EXT, true, "object",
+ new Primitive("threadp", PACKAGE_THREADS, true, "object",
"Boolean predicate as whether OBJECT is a thread.")
{
@Override
@@ -1050,7 +1050,7 @@
// ### thread-alive-p
private static final Primitive THREAD_ALIVE_P =
- new Primitive("thread-alive-p", PACKAGE_EXT, true, "thread",
+ new Primitive("thread-alive-p", PACKAGE_THREADS, true, "thread",
"Boolean predicate whether THREAD is alive.")
{
@Override
@@ -1069,7 +1069,7 @@
// ### thread-name
private static final Primitive THREAD_NAME =
- new Primitive("thread-name", PACKAGE_EXT, true, "thread",
+ new Primitive("thread-name", PACKAGE_THREADS, true, "thread",
"Return the name of THREAD if it has one.")
{
@Override
@@ -1113,7 +1113,7 @@
// ### mapcar-threads
private static final Primitive MAPCAR_THREADS =
- new Primitive("mapcar-threads", PACKAGE_EXT, true, "function",
+ new Primitive("mapcar-threads", PACKAGE_THREADS, true, "function",
"Applies FUNCTION to all existing threads.")
{
@Override
@@ -1134,7 +1134,7 @@
// ### destroy-thread
private static final Primitive DESTROY_THREAD =
- new Primitive("destroy-thread", PACKAGE_EXT, true, "thread",
+ new Primitive("destroy-thread", PACKAGE_THREADS, true, "thread",
"Mark THREAD as destroyed.")
{
@Override
@@ -1158,7 +1158,7 @@
// multiple interrupts are queued for a thread, they are all run, but the
// order is not guaranteed.
private static final Primitive INTERRUPT_THREAD =
- new Primitive("interrupt-thread", PACKAGE_EXT, true,
+ new Primitive("interrupt-thread", PACKAGE_THREADS, true,
"thread function &rest args",
"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.")
{
@@ -1185,7 +1185,7 @@
// ### current-thread
private static final Primitive CURRENT_THREAD =
- new Primitive("current-thread", PACKAGE_EXT, true, "",
+ new Primitive("current-thread", PACKAGE_THREADS, true, "",
"Returns a reference to invoking thread.")
{
@Override
@@ -1211,6 +1211,22 @@
}
};
+ static {
+ //FIXME: this block has been added for pre-0.16 compatibility
+ // and can be removed the latest at release 0.22
+ try {
+ PACKAGE_EXT.export(Symbol.intern("MAKE-THREAD", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("THREADP", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("THREAD-ALIVE-P", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("THREAD-NAME", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("MAPCAR-THREADS", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("DESTROY-THREAD", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("INTERRUPT-THREAD", PACKAGE_THREADS));
+ PACKAGE_EXT.export(Symbol.intern("CURRENT-THREAD", PACKAGE_THREADS));
+ }
+ catch (ConditionThrowable ct) { }
+ }
+
// ### use-fast-calls
private static final Primitive USE_FAST_CALLS =
new Primitive("use-fast-calls", PACKAGE_SYS, true)
@@ -1222,4 +1238,101 @@
return use_fast_calls ? T : NIL;
}
};
+
+ // ### synchronized-on
+ private static final SpecialOperator SYNCHRONIZED_ON =
+ new SpecialOperator("synchronized-on", PACKAGE_THREADS, true,
+ "form &body body")
+ {
+ @Override
+ public LispObject execute(LispObject args, Environment env)
+ throws ConditionThrowable
+ {
+ if (args == NIL)
+ return error(new WrongNumberOfArgumentsException(this));
+
+ LispThread thread = LispThread.currentThread();
+ synchronized (eval(args.car(), env, thread).lockableInstance()) {
+ return progn(args.cdr(), env, thread);
+ }
+ }
+ };
+
+ // ### object-wait
+ private static final Primitive OBJECT_WAIT =
+ new Primitive("object-wait", PACKAGE_THREADS, true,
+ "object &optional timeout")
+ {
+ @Override
+ public LispObject execute(LispObject object)
+ throws ConditionThrowable
+ {
+ try {
+ object.lockableInstance().wait();
+ }
+ catch (InterruptedException e) {
+ currentThread().processThreadInterrupts();
+ }
+ catch (IllegalMonitorStateException e) {
+ return error(new IllegalMonitorState());
+ }
+ return NIL;
+ }
+
+ @Override
+ public LispObject execute(LispObject object, LispObject timeout)
+ throws ConditionThrowable
+ {
+ try {
+ object.lockableInstance().wait(javaSleepInterval(timeout));
+ }
+ catch (InterruptedException e) {
+ currentThread().processThreadInterrupts();
+ }
+ catch (IllegalMonitorStateException e) {
+ return error(new IllegalMonitorState());
+ }
+ return NIL;
+ }
+ };
+
+ // ### object-notify
+ private static final Primitive OBJECT_NOTIFY =
+ new Primitive("object-notify", PACKAGE_THREADS, true,
+ "object")
+ {
+ @Override
+ public LispObject execute(LispObject object)
+ throws ConditionThrowable
+ {
+ try {
+ object.lockableInstance().notify();
+ }
+ catch (IllegalMonitorStateException e) {
+ return error(new IllegalMonitorState());
+ }
+ return NIL;
+ }
+ };
+
+ // ### object-notify-all
+ private static final Primitive OBJECT_NOTIFY_ALL =
+ new Primitive("object-notify-all", PACKAGE_THREADS, true,
+ "object")
+ {
+ @Override
+ public LispObject execute(LispObject object)
+ throws ConditionThrowable
+ {
+ try {
+ object.lockableInstance().notifyAll();
+ }
+ catch (IllegalMonitorStateException e) {
+ return error(new IllegalMonitorState());
+ }
+ return NIL;
+ }
+ };
+
+
}
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Jul 12 14:36:47 2009
@@ -304,6 +304,22 @@
(setf (block-form block) result)
block))
+(defun p1-threads-synchronized-on (form)
+ (let* ((synchronized-object (p1 (cadr form)))
+ (body (cddr form))
+ (block (make-block-node '(THREADS:SYNCHRONIZED-ON)))
+ (*blocks* (cons block *blocks*))
+ result)
+ (dolist (subform body)
+ (let ((op (and (consp subform) (%car subform))))
+ (push (p1 subform) result)
+ (when (memq op '(GO RETURN-FROM THROW))
+ (return))))
+ (setf (block-form block)
+ (list* 'threads:synchronized-on synchronized-object
+ (nreverse result)))
+ block))
+
(defun p1-unwind-protect (form)
(if (= (length form) 2)
(p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
@@ -1040,7 +1056,9 @@
(THE p1-the)
(THROW p1-throw)
(TRULY-THE p1-truly-the)
- (UNWIND-PROTECT p1-unwind-protect)))
+ (UNWIND-PROTECT p1-unwind-protect)
+ (THREADS:SYNCHRONIZED-ON
+ p1-threads-synchronized-on)))
(install-p1-handler (%car pair) (%cadr pair))))
(initialize-p1-handlers)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun Jul 12 14:36:47 2009
@@ -1131,6 +1131,8 @@
177 ; return
190 ; arraylength
191 ; athrow
+ 194 ; monitorenter
+ 195 ; monitorexit
198 ; ifnull
202 ; label
))
@@ -7680,6 +7682,37 @@
(label LABEL2)
(emit-move-from-stack target representation)))))
+(defknown p2-threads-synchronized-on (t t) t)
+(defun p2-threads-synchronized-on (block target)
+ (let* ((form (block-form block))
+ (*register* *register*)
+ (object-register (allocate-register))
+ (BEGIN-PROTECTED-RANGE (gensym))
+ (END-PROTECTED-RANGE (gensym))
+ (EXIT (gensym)))
+ (compile-form (cadr form) 'stack nil)
+ (emit-invokevirtual +lisp-object-class+ "lockableInstance" nil
+ +java-object+) ; value to synchronize
+ (emit 'dup)
+ (astore object-register)
+ (emit 'monitorenter)
+ (label BEGIN-PROTECTED-RANGE)
+ (compile-progn-body (cddr form) target)
+ (emit 'goto EXIT)
+ (label END-PROTECTED-RANGE)
+ (aload object-register)
+ (emit 'monitorexit)
+ (emit 'athrow)
+
+ (label EXIT)
+ (aload object-register)
+ (emit 'monitorexit)
+ (push (make-handler :from BEGIN-PROTECTED-RANGE
+ :to END-PROTECTED-RANGE
+ :code END-PROTECTED-RANGE
+ :catch-type 0) *handlers*)))
+
+
(defknown p2-catch-node (t t) t)
(defun p2-catch-node (block target)
(let ((form (block-form block)))
@@ -7885,6 +7918,9 @@
(fix-boxing representation nil))
((equal (block-name form) '(PROGV))
(p2-progv-node form target representation))
+ ((equal (block-name form) '(THREADS:SYNCHRONIZED-ON))
+ (p2-threads-synchronized-on form target)
+ (fix-boxing representation nil))
(t
(p2-block-node form target representation))))
((constantp form)
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun Jul 12 14:36:47 2009
@@ -420,7 +420,8 @@
"
(let ((name (block-name object)))
(or (equal name '(CATCH))
- (equal name '(UNWIND-PROTECT)))))
+ (equal name '(UNWIND-PROTECT))
+ (equal name '(THREADS:SYNCHRONIZED-ON)))))
(defknown enclosed-by-protected-block-p (&optional t) boolean)
Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp Sun Jul 12 14:36:47 2009
@@ -488,6 +488,9 @@
res))
(cons 'PROGN (mapcar #'precompile1 body)))))
+(defun precompile-threads-synchronized-on (form)
+ (cons 'threads:synchronized-on (mapcar #'precompile1 (cdr form))))
+
(defun precompile-progv (form)
(if (< (length form) 3)
(compiler-error "Not enough arguments for ~S." 'progv)
@@ -993,7 +996,10 @@
(QUOTE precompile-identity)
(THE precompile-the)
(THROW precompile-cons)
- (TRULY-THE precompile-truly-the)))
+ (TRULY-THE precompile-truly-the)
+
+ (THREADS:SYNCHRONIZED-ON
+ precompile-threads-synchronized-on)))
(install-handler (first pair) (second pair))))
(install-handlers)
More information about the armedbear-cvs
mailing list