impl-allegro.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
 (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) Tags
 (DIR) README
 (DIR) LICENSE
       ---
       impl-allegro.lisp (3752B)
       ---
            1 ;;;; -*- indent-tabs-mode: nil -*-
            2 
            3 #|
            4 Copyright 2006, 2007 Greg Pfeil
            5 
            6 Distributed under the MIT license (see LICENSE file)
            7 |#
            8 
            9 (in-package #:bordeaux-threads)
           10 
           11 ;;; documentation on the Allegro Multiprocessing interface can be found at
           12 ;;; http://www.franz.com/support/documentation/8.1/doc/multiprocessing.htm
           13 
           14 ;;; Resource contention: locks and recursive locks
           15 
           16 (deftype lock () 'mp:process-lock)
           17 
           18 (deftype recursive-lock () 'mp:process-lock)
           19 
           20 (defun lock-p (object)
           21   (typep object 'mp:process-lock))
           22 
           23 (defun recursive-lock-p (object)
           24   (typep object 'mp:process-lock))
           25 
           26 (defun make-lock (&optional name)
           27   (mp:make-process-lock :name (or name "Anonymous lock")))
           28 
           29 (defun make-recursive-lock (&optional name)
           30   (mp:make-process-lock :name (or name "Anonymous recursive lock")))
           31 
           32 (defun acquire-lock (lock &optional (wait-p t))
           33   (mp:process-lock lock mp:*current-process* "Lock" (if wait-p nil 0)))
           34 
           35 (defun release-lock (lock)
           36   (mp:process-unlock lock))
           37 
           38 (defmacro with-lock-held ((place) &body body)
           39   `(mp:with-process-lock (,place :norecursive t)
           40      ,@body))
           41 
           42 (defmacro with-recursive-lock-held ((place &key timeout) &body body)
           43   `(mp:with-process-lock (,place :timeout ,timeout)
           44      ,@body))
           45 
           46 ;;; Resource contention: condition variables
           47 
           48 (defun make-condition-variable (&key name)
           49   (declare (ignorable name))
           50   #-(version>= 9)
           51   (mp:make-gate nil)
           52   #+(version>= 9)
           53   (mp:make-condition-variable :name name))
           54 
           55 (defun condition-wait (condition-variable lock &key timeout)
           56   #-(version>= 9)
           57   (progn
           58     (release-lock lock)
           59     (if timeout
           60         (mp:process-wait-with-timeout "wait for message" timeout
           61                                       #'mp:gate-open-p condition-variable)
           62         (mp:process-wait "wait for message" #'mp:gate-open-p condition-variable))
           63     (acquire-lock lock)
           64     (mp:close-gate condition-variable))
           65   #+(version>= 9)
           66   (mp:condition-variable-wait condition-variable lock :timeout timeout)
           67   t)
           68 
           69 (defun condition-notify (condition-variable)
           70   #-(version>= 9)
           71   (mp:open-gate condition-variable)
           72   #+(version>= 9)
           73   (mp:condition-variable-signal condition-variable))
           74 
           75 (defun thread-yield ()
           76   (mp:process-allow-schedule))
           77 
           78 (deftype thread ()
           79   'mp:process)
           80 
           81 ;;; Thread Creation
           82 
           83 (defun start-multiprocessing ()
           84   (mp:start-scheduler))
           85 
           86 (defun %make-thread (function name)
           87   #+smp
           88   (mp:process-run-function name function)
           89   #-smp
           90   (mp:process-run-function
           91    name
           92    (lambda ()
           93      (let ((return-values
           94              (multiple-value-list (funcall function))))
           95        (setf (getf (mp:process-property-list mp:*current-process*)
           96                    'return-values)
           97              return-values)
           98        (values-list return-values)))))
           99 
          100 (defun current-thread ()
          101   mp:*current-process*)
          102 
          103 (defun threadp (object)
          104   (typep object 'mp:process))
          105 
          106 (defun thread-name (thread)
          107   (mp:process-name thread))
          108 
          109 ;;; Timeouts
          110 
          111 (defmacro with-timeout ((timeout) &body body)
          112   (once-only (timeout)
          113     `(mp:with-timeout (,timeout (error 'timeout :length ,timeout))
          114        ,@body)))
          115 
          116 ;;; Introspection/debugging
          117 
          118 (defun all-threads ()
          119   mp:*all-processes*)
          120 
          121 (defun interrupt-thread (thread function &rest args)
          122   (apply #'mp:process-interrupt thread function args))
          123 
          124 (defun destroy-thread (thread)
          125   (signal-error-if-current-thread thread)
          126   (mp:process-kill thread))
          127 
          128 (defun thread-alive-p (thread)
          129   (mp:process-alive-p thread))
          130 
          131 (defun join-thread (thread)
          132   #+smp
          133   (values-list (mp:process-join thread))
          134   #-smp
          135   (progn
          136     (mp:process-wait (format nil "Waiting for thread ~A to complete" thread)
          137                      (complement #'mp:process-alive-p)
          138                      thread)
          139     (let ((return-values
          140             (getf (mp:process-property-list thread) 'return-values)))
          141       (values-list return-values))))
          142 
          143 (mark-supported)