Changeset 12040

Timestamp:

07/12/09 18:36:47 (14 years ago)

Author:

ehuelsmann

Message:

Add synchronization like in Java through the special operator SYNCHRONIZED-ON.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• IllegalMonitorState.java (added)
• LispThread.java (modified) (10 diffs)
• compiler-pass1.lisp (modified) (2 diffs)
• compiler-pass2.lisp (modified) (3 diffs)
• jvm.lisp (modified) (1 diff)
• precompiler.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/LispThread.java

@@ -1013 +1013 @@
     // ### 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
@@ -1039 +1039 @@
     // ### 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.")
     {
@@ -1051 +1051 @@
     // ### 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.")
     {
@@ -1070 +1070 @@
     // ### 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.")
     {
@@ -1114 +1114 @@
     // ### 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.")
     {
@@ -1135 +1135 @@
     // ### 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.")
     {
@@ -1159 +1159 @@
     // 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.")
@@ -1186 +1186 @@
     // ### 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.")
     {
@@ -1212 +1212 @@
     };
 
+    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 =
@@ -1223 +1239 @@
         }
     };
+
+    // ### 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;
+        }
+    };
+
+
 }

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -303 +303 @@
     (push 'CATCH result)
     (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))
 
@@ -1041 +1057 @@
                   (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))))
 

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -1132 +1132 @@
                  190 ; arraylength
                  191 ; athrow
+                 194 ; monitorenter
+                 195 ; monitorexit
                  198 ; ifnull
                  202 ; label
@@ -7681 +7683 @@
         (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)
@@ -7886 +7919 @@
                ((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))))

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -421 +421 @@
   (let ((name (block-name object)))
     (or (equal name '(CATCH))
-        (equal name '(UNWIND-PROTECT)))))
+        (equal name '(UNWIND-PROTECT))
+        (equal name '(THREADS:SYNCHRONIZED-ON)))))
 
 

trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

@@ -489 +489 @@
         (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)
@@ -994 +997 @@
                   (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))))