home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / THREAD.SCM < prev    next >
Text File  |  1992-06-17  |  12KB  |  401 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Multitasking
  5.  
  6. ; A thread has:
  7. ;   - uid - no semantic content.
  8. ;   - a primitive continuation, unless thread is current or finished
  9. ;   - dynamic environment
  10. ;   - run status (active, stopped, done) - used only for stop & start
  11. ;     operations
  12.  
  13. ; What are the invariants?
  14.  
  15. (define thread-type
  16.   (make-record-type 'thread
  17.             '(uid continuation dynamic-state status
  18.               queue name)))
  19.  
  20. (define thread-uid           (record-accessor thread-type 'uid))
  21. (define thread-continuation  (record-accessor thread-type 'continuation))
  22. (define thread-dynamic-state (record-accessor thread-type 'dynamic-state))
  23. (define thread-status         (record-accessor thread-type 'status))
  24. (define thread-queue         (record-accessor thread-type 'queue))
  25. (define thread-name         (record-accessor thread-type 'name));for debugging
  26. (define set-thread-continuation!  (record-modifier thread-type 'continuation))
  27. (define set-thread-dynamic-state! (record-modifier thread-type 'dynamic-state))
  28. (define set-thread-status!      (record-modifier thread-type 'status))
  29. (define set-thread-queue!      (record-modifier thread-type 'queue))
  30.  
  31. (define thread? (record-predicate thread-type))
  32.  
  33. (define-syntax with-interrupts-inhibited
  34.   (syntax-rules ()
  35.     ((with-interrupts-inhibited . body)
  36.      (begin (set-enabled-interrupts! 0)
  37.         (let ((result (begin . body)))
  38.           (set-enabled-interrupts! all-interrupts)
  39.           result)))))
  40.  
  41.  
  42. ; Spawn a new thread
  43.  
  44. (define (spawn thunk . name-option)
  45.   (let* ((name (if (null? name-option) #f (car name-option)))
  46.      (thread (make-thread thunk name)))
  47.     (start-thread thread)
  48.     thread))
  49.  
  50.  
  51. (define *thread-uid* 1)
  52.  
  53. (define make-thread
  54.   (let ((make (record-constructor thread-type
  55.                   '(uid continuation
  56.                     dynamic-state
  57.                     status queue name))))
  58.     (lambda (thunk name)
  59.       (let ((thread (make *thread-uid*
  60.               (compose-continuation
  61.                (lambda (ignore)
  62.                  (thread-top-level thunk))
  63.                #f)
  64.               #f
  65.               'stopped
  66.               runnable-threads
  67.               name)))
  68.     (set-thread-dynamic-state!
  69.        thread
  70.        (make-dynamic-state thread (thread-initial-dynamic-env)))
  71.     (set! *thread-uid* (+ *thread-uid* 1))
  72.     thread))))
  73.  
  74. (define (thread-top-level thunk)
  75.   (set-enabled-interrupts! all-interrupts)
  76.   (thunk)
  77.   (terminate-current-thread))
  78.  
  79. (define (terminate-current-thread)
  80.   (set-enabled-interrupts! all-interrupts)
  81.   (travel-to-empty!)            ;Unwind
  82.   (set-enabled-interrupts! 0)
  83.   (set-thread-status! (current-thread) 'done)
  84.   (set-thread-continuation! (current-thread) #f)
  85.   (schedule-thread (another-thread)))
  86.  
  87. (define (start-thread thread)        ;Interrupts enabled
  88.   (with-interrupts-inhibited
  89.     (really-start-thread thread)))
  90.  
  91. (define (really-start-thread thread)    ;Interrupts disabled
  92.   (if (eq? (thread-status thread) 'stopped)
  93.       (begin (set-thread-status! thread 'active)
  94.          (move-to-queue (current-thread) runnable-threads)
  95.          (switch-to-thread thread)
  96.          #t)
  97.       (eq? (thread-status thread) 'active)))
  98.  
  99. (define (stop-thread thread)        ;Interrupts enabled
  100.   (with-interrupts-inhibited
  101.     (really-stop-thread thread)))
  102.  
  103. (define (really-stop-thread thread)    ;Call with interrupts disabled
  104.   (if (eq? (thread-status thread) 'active)
  105.       (let ((q (thread-queue thread)))
  106.     (if q (delete-from-queue! q thread))
  107.     (set-thread-status! thread 'stopped)
  108.     (if (eq? thread (current-thread))
  109.         (suspend-this-thread))
  110.     #t)
  111.       (eq? (thread-status thread) 'stopped)))
  112.  
  113. (define (kill-thread thread)        ;Interrupts enabled
  114.   (interrupt-thread thread terminate-current-thread))
  115.  
  116. (define (interrupt-thread thread thunk)
  117.   (with-interrupts-inhibited
  118.     (cond ((eq? thread (current-thread))
  119.        (let ((ei (set-enabled-interrupts! all-interrupts)))
  120.          (thunk)
  121.          (set-enabled-interrupts! ei)
  122.          #t))
  123.       ((really-stop-thread thread)
  124.        (set-thread-queue! thread runnable-threads)
  125.        (set-thread-continuation!
  126.         thread
  127.         (compose-continuation
  128.          (lambda (ignore)
  129.            (set-enabled-interrupts! all-interrupts)
  130.            (thunk))
  131.          (thread-continuation thread)))
  132.        (really-start-thread thread))
  133.       (else #f))))
  134.  
  135. (define (move-to-queue thread q)
  136.   (set-thread-queue! thread q)
  137.   (enqueue q thread))
  138.  
  139.  
  140. ; --------------------
  141. ; Scheduler
  142.  
  143. (define runnable-threads (make-queue))
  144.  
  145. (define (make-ready! thread)
  146.   (move-to-queue thread runnable-threads))
  147.  
  148. (define (handle-alarmclock-interrupt ei)
  149.   (arrange-for-alarm-interrupt)    ;Allow another one to come along
  150.   ;; Interrupts are disabled at this point
  151.   (if (not (queue-empty? runnable-threads))    ;speed/consing hack
  152.       (relinquish-timeslice))
  153.   (set-enabled-interrupts! ei))
  154.  
  155. (define (suspend-this-thread)        ;Call this with interrupts disabled
  156.   (switch-to-thread (another-thread)))
  157.  
  158. (define (switch-to-thread thread)
  159.   (primitive-catch  ;(internal-catch (lambda (cont env) ...))
  160.    (lambda (cont)
  161.      (set-thread-continuation! (current-thread) cont)
  162.      (schedule-thread thread))))
  163.  
  164. (define (schedule-thread thread)    ;Call with interrupts disabled
  165.   (set-dynamic-state! (thread-dynamic-state thread))
  166.   (with-continuation (thread-continuation (current-thread))
  167.              unspecified))
  168.  
  169. (define (another-thread)        ;Call with interrupts disabled
  170.   (if (queue-empty? runnable-threads)
  171.       (if (and *keyboard-interrupt-thread*
  172.            (not (eq? (thread-status *keyboard-interrupt-thread*) 'done)))
  173.       (interrupt-thread *keyboard-interrupt-thread*
  174.                 (lambda ()
  175.                   (error "no threads to run")))
  176.       (halt 0))
  177.       (dequeue runnable-threads)))
  178.  
  179. (define (dispatch)            ;Interrupts disabled
  180.   (make-ready! (current-thread))
  181.   (suspend-this-thread))
  182.  
  183.  
  184. (define (relinquish-timeslice)        ;Interrupts enabled
  185.   (with-interrupts-inhibited (dispatch)))
  186.  
  187. ; --------------------
  188. ; Locks (= semaphores)
  189.  
  190. (define lock-type
  191.   (make-record-type 'lock '(identification owner queue)))
  192.  
  193. (define lock-identification (record-accessor lock-type 'identification))
  194. (define lock-owner        (record-accessor lock-type 'owner))
  195. (define lock-queue        (record-accessor lock-type 'queue))
  196. (define set-lock-owner! (record-modifier lock-type 'owner))
  197.  
  198. (define lock? (record-predicate lock-type))
  199.  
  200. (define *lock-uid* 0)
  201.  
  202. (define make-lock
  203.   (let ((make (record-constructor lock-type
  204.                   '(identification owner queue))))
  205.     (lambda ()
  206.       (let ((uid *lock-uid*))
  207.     (set! *lock-uid* (+ uid 1))
  208.     (make uid #f (make-queue))))))
  209.  
  210. (define (obtain-lock lock)        ;Interrupts enabled
  211.   (with-interrupts-inhibited
  212.     (let loop ()
  213.       (if (let ((owner (lock-owner lock)))
  214.         (and owner
  215.          (not (eq? owner (current-thread)))
  216.          (not (eq? (thread-status owner) 'done))))
  217.       (begin (move-to-queue (current-thread)
  218.                 (lock-queue lock))
  219.          (suspend-this-thread)
  220.          (loop))
  221.       (set-lock-owner! lock (current-thread))))))
  222.  
  223. (define (release-lock lock)        ;Interrupts enabled
  224.   (if (eq? (lock-owner lock) (current-thread))
  225.       (with-interrupts-inhibited
  226.     (set-lock-owner! lock #f)
  227.     (if (not (queue-empty? (lock-queue lock)))
  228.         (begin (make-ready! (current-thread))
  229.            (switch-to-thread (dequeue (lock-queue lock))))))))
  230.  
  231. (define (with-lock lock thunk)        ;Interrupts enabled
  232.   (if (eq? (lock-owner lock) (current-thread))
  233.       (thunk)
  234.       (dynamic-wind (lambda () (obtain-lock lock))
  235.             thunk
  236.             (lambda () (release-lock lock)))))
  237.  
  238.  
  239. ; --------------------
  240. ; Condition variables
  241.  
  242. (define (make-condvar)
  243.   (cons (make-queue) #f))
  244. (define condvar-queue car)  ; #f means variable has been set
  245. (define condvar-value cdr)
  246.  
  247. (define (condvar-ref condvar)        ;Interrupts enabled
  248.   (with-interrupts-inhibited
  249.     (let loop ()
  250.       (if (condvar-queue condvar)
  251.       (begin (move-to-queue (current-thread)
  252.                 (condvar-queue condvar))
  253.          (suspend-this-thread)
  254.          (loop))
  255.       (condvar-value condvar)))))
  256.  
  257. (define (condvar-set! condvar value)    ;Interrupts enabled
  258.   (if (with-interrupts-inhibited
  259.     (let ((q (condvar-queue condvar)))
  260.       (if q
  261.           (begin (set-cdr! condvar value)
  262.              (set-car! condvar #f)
  263.              (if (queue-empty? q)
  264.              #f
  265.              (let ((first (dequeue q)))
  266.                (let loop ()
  267.                  (if (queue-empty? q)
  268.                  (begin (make-ready! (current-thread))
  269.                     (switch-to-thread first)
  270.                     #f)
  271.                  (begin (make-ready! (dequeue q))
  272.                     (loop)))))))
  273.           ;; OK to store the same value twice.
  274.           (not (eq? value (condvar-value condvar))))))
  275.       (error "invalid condvar-set!" (condvar-value condvar) value)))
  276.  
  277. (define (kill-condvar condvar)
  278.   (for-each kill-thread (with-interrupts-inhibited
  279.              (if (condvar-queue condvar)
  280.                  (queue->list (condvar-queue condvar))
  281.                  '()))))
  282.  
  283.  
  284. ; --------------------
  285. ; Input
  286.  
  287. (define (thread-read-char port)
  288.   (with-interrupts-inhibited
  289.     (let loop ()
  290.       (if (char-ready? port)
  291.       (read-char port)
  292.       (begin (dispatch)
  293.          (loop))))))
  294.  
  295. (define (thread-peek-char port)
  296.   (with-interrupts-inhibited
  297.     (let loop ()
  298.       (if (char-ready? port)
  299.       (peek-char port)
  300.       (begin (dispatch)
  301.          (loop))))))
  302.  
  303.  
  304. ; --------------------
  305. ; Initialization
  306.  
  307. (define (start-multitasking handler)
  308.   (set! *one-second* (vm-extension 1 #f))
  309.   (set! runnable-threads (make-queue))
  310.   (set! *thread-initial-dynamic-env*
  311.     (make-thread-initial-dynamic-env handler))
  312.   (let* ((this-thread (make-thread #f 'initial))
  313.      (state (make-dynamic-state this-thread
  314.                     (get-dynamic-env))))
  315.     (set-thread-dynamic-state! this-thread state)
  316.     (set-thread-status! this-thread 'active)
  317.     (set-dynamic-state! state))
  318.   (vector-set! interrupt-handlers
  319.            interrupt/periodic
  320.            handle-alarmclock-interrupt)
  321.   (arrange-for-alarm-interrupt)
  322.   (let ((ei (set-enabled-interrupts! 0)))
  323.     (set! all-interrupts
  324.       (bitwise-ior ei (arithmetic-shift 1 interrupt/periodic)))
  325.     (set-enabled-interrupts! all-interrupts)))
  326.  
  327. (define (simple-thread-condition-handler)
  328.   (let ((port (current-output-port)))
  329.     (lambda (c h)
  330.       (cond ((warning? c)
  331.          (display-condition c port)
  332.          (unspecified))        ;Proceed
  333.         ((interrupt? c)
  334.          (terminate-current-thread))
  335.         ((error? c)
  336.          (display-condition c port)
  337.          (terminate-current-thread))
  338.         (else            ;Proceed
  339.          (unspecified))))))
  340.  
  341. (define (make-thread-initial-dynamic-env handler)
  342.   (let ((in  (current-input-port))
  343.     (out (current-output-port)))
  344.     (with-dynamic-env (empty-dynamic-env)
  345.       (lambda ()
  346.     (let-fluid $current-input-port in
  347.       (lambda ()
  348.         (let-fluid $current-output-port out
  349.           (lambda ()
  350.         (really-with-handler handler
  351.           get-dynamic-env)))))))))
  352.  
  353. (define (set-keyboard-interrupt-thread! thread)
  354.   (set! *keyboard-interrupt-thread* thread)
  355.   (vector-set! interrupt-handlers
  356.            interrupt/keyboard
  357.            (if thread
  358.            handle-keyboard-interrupt
  359.            (lambda (ei)
  360.              (set-enabled-interrupts! all-interrupts)
  361.              (error "interrupt not handled")))))
  362.  
  363. (define *keyboard-interrupt-thread* #f)
  364.  
  365. (define (handle-keyboard-interrupt ei)
  366.   (interrupt-thread *keyboard-interrupt-thread*
  367.             (lambda ()
  368.               (raise '(interrupt keyboard)))))
  369.  
  370.  
  371. (define *thread-initial-dynamic-env* #f)
  372.  
  373. (define (thread-initial-dynamic-env)
  374.   *thread-initial-dynamic-env*)
  375.  
  376. (define (arrange-for-alarm-interrupt)
  377.   (vm-extension 3 *one-second*))    ;This causes an interrupt in 1 second
  378.  
  379. (define *one-second* 120)
  380.  
  381. (define all-interrupts 0)
  382.  
  383. (define (kill-all-other-threads)    ;Interrupts enabled
  384.   (for-each kill-thread (with-interrupts-inhibited
  385.               (queue->list runnable-threads)))
  386.   (relinquish-timeslice))
  387.  
  388.  
  389. (define-record-discloser thread-type
  390.   (lambda (thread)
  391.     (cons 'thread
  392.       (cons (thread-uid thread)
  393.         (let ((name (thread-name thread)))
  394.           (if name
  395.               (list name)
  396.               '()))))))
  397.  
  398. ;(put 'with-interrupts-inhibited 'scheme-indent-hook 0)
  399. ;(put 'with-dynamic-env 'scheme-indent-hook 1)
  400. ;(put 'really-with-handler 'scheme-indent-hook 1)
  401.