Changeset 11744


Ignore:
Timestamp:
Feb 16, 2009, 1:55:29 PM (11 years ago)
Author:
gb
Message:

Mostly experimental changes: try to make some operations on PROCESSes
generic. Work-in-progress.

Location:
trunk/source/level-1
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-lisp-threads.lisp

    r11659 r11744  
    163163            nil
    164164            :reset
    165             (make-lock)
    166             nil))
     165            (make-lock)))
    167166
    168167(defvar *current-lisp-thread*
     
    404403
    405404       
    406 (defun thread-preset (thread function &rest args)
     405(defun  thread-preset (thread function &rest args)
    407406  (setf (lisp-thread.initial-function.args thread)
    408407        (cons function args)))
     
    437436        (%kill-tcr tcr)))))
    438437
    439 ;;; This returns the underlying pthread, whatever that is.
     438;;; This returns the underlying pthread, whatever that is, as an
     439;;; unsigned integer.
    440440(defun lisp-thread-os-thread (thread)
    441441  (with-macptrs (tcrp)
    442442    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
    443443    (unless (%null-ptr-p tcrp)
    444       #+linux-target
    445       (let* ((pthread (#+32-bit-target %get-unsigned-long
    446                        #+64-bit-target %%get-unsigned-longlong
    447                        tcrp target::tcr.osid)))
    448         (unless (zerop pthread) pthread))
    449       #+darwin-target
    450       (let* ((pthread (%get-ptr tcrp target::tcr.osid)))
    451         (unless (%null-ptr-p pthread) pthread)))))
     444      (let* ((natural (%get-natural tcrp target::tcr.osid)))
     445        (unless (zerop natural) natural)))))
     446
     447
    452448                         
    453449;;; This returns something lower-level than the pthread, if that
     
    487483          (bitset arch::tcr-flag-bit-awaiting-preset flags)))) 
    488484
     485;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE.
    489486(defun %activate-tcr (tcr termination-semaphore allocation-quantum)
    490487  (if (and tcr (not (eql 0 tcr)))
    491     (with-macptrs (tcrp s)
     488    (with-macptrs (tcrp)
    492489      (%setf-macptr-to-object tcrp tcr)
    493       (%setf-macptr s (%get-ptr tcrp target::tcr.activate))
    494       (unless (%null-ptr-p s)
    495         (setf (#+64-bit-target %%get-unsigned-longlong
    496                #+32-bit-target %get-unsigned-long
    497                                tcrp target::tcr.log2-allocation-quantum)
    498               (or allocation-quantum (default-allocation-quantum)))
    499         (setf (%get-ptr tcrp target::tcr.termination-semaphore)
    500               (if termination-semaphore
    501                 (semaphore-value termination-semaphore)
    502                 (%null-ptr)))
    503         (%signal-semaphore-ptr s)
    504         t))))
     490      (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
     491            (or allocation-quantum (default-allocation-quantum)))
     492      (setf (%get-ptr tcrp target::tcr.termination-semaphore)
     493            (if termination-semaphore
     494              (semaphore-value termination-semaphore)
     495              (%null-ptr)))
     496      t)))
    505497                         
    506498(defvar *canonical-error-value*
  • trunk/source/level-1/l1-processes.lisp

    r11281 r11744  
    295295
    296296
    297 (defun process-enable (p &optional (wait (* 60 60 24) wait-p))
     297(defmethod process-enable ((p process) &optional (wait (* 60 60 24) wait-p))
    298298  "Begin executing the initial function of a specified process."
    299   (setq p (require-type p 'process))
    300299  (not-in-current-process p 'process-enable)
    301300  (when wait-p
     
    306305    (do* ((total-wait wait (+ total-wait wait)))
    307306         ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p)))  wait)
     307          (process-tcr-enable p (lisp-thread.tcr thread))
    308308          p)
    309309      (cerror "Keep trying."
     
    311311              p total-wait))))
    312312
     313(defmethod process-tcr-enable ((process process) tcr)
     314  (when (and tcr (not (eql 0 tcr)))
     315    (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate))
     316    ))
    313317
    314318(defmethod (setf process-termination-semaphore) :after (new (p process))
     
    351355 
    352356;;; Used by process-run-function
    353 (defun process-preset (process function &rest args)
     357(defmethod process-preset ((p process) function &rest args)
    354358  "Set the initial function and arguments of a specified process."
    355   (let* ((p (require-type process 'process))
    356          (f (require-type function 'function))
     359  (let* ((f (require-type function 'function))
    357360         (initial-form (process-initial-form p)))
    358361    (declare (type cons initial-form))
     
    361364    (rplaca initial-form f)
    362365    (rplacd initial-form args)
    363     (%process-preset-internal process)))
    364 
    365 (defun %process-preset-internal (process)
     366    (%process-preset-internal p)))
     367
     368(defmethod %process-preset-internal ((process process))
    366369   (let* ((initial-form (process-initial-form process))
    367370         (thread (process-thread process)))
     
    567570(defun process-allow-schedule ()
    568571  "Used for cooperative multitasking; probably never necessary."
    569   (yield))
     572  (process-yield *current-process*))
    570573
    571574
     
    621624        (process-interrupt process '%process-reset kill)))))
    622625
     626(defmethod process-yield ((p process))
     627  #+windows-target (#_Sleep 0)
     628  #-windows-target (#_sched_yield))
     629
    623630
    624631(defun %process-reset (kill)
  • trunk/source/level-1/linux-files.lisp

    r11516 r11744  
    19681968
    19691969(defun yield ()
    1970   #+windows-target
    1971   (#_Sleep 0)
    1972   #-windows-target 
    1973   (#_sched_yield))
     1970  (process-allow-schedule))
    19741971
    19751972(defloadvar *host-page-size*
Note: See TracChangeset for help on using the changeset viewer.