Changeset 34359 in project


Ignore:
Timestamp:
08/25/17 19:34:28 (3 months ago)
Author:
kon
Message:

better info in timeout condition

Location:
release/4/mailbox/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/trunk/mailbox.scm

    r34358 r34359  
    9191(include "inline-type-checks")
    9292(include "inline-queue")
    93 
    94 (define-inline (->boolean obj) (and obj #t))
    9593
    9694(cond-expand
     
    130128    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
    131129
     130;;; Support
     131
     132(define-inline (->boolean obj)
     133  (and obj #t) )
     134
    132135;;; Mailbox Support
     136
     137;; Mailbox
    133138
    134139(define-record-type-variant mailbox (unsafe unchecked inline)
     
    139144  (wt %mailbox-waiters %mailbox-waiters-set!) )
    140145
    141 (define-inline (%make-mailbox nm) (%%make-mailbox nm (%make-queue) '()))
     146(define-inline (%make-mailbox nm)
     147  (%%make-mailbox nm (%make-queue) '()) )
    142148
    143149(define-error-type mailbox)
     
    146152;; Message queue
    147153
    148 (define-inline (%mailbox-queue-first-pair mb) (%queue-first-pair (%mailbox-queue mb)))
    149 (define-inline (%mailbox-queue-last-pair mb) (%queue-last-pair (%mailbox-queue mb)))
    150 (define-inline (%mailbox-queue-empty? mb) (%queue-empty? (%mailbox-queue mb)))
    151 (define-inline (%mailbox-queue-count mb) (%queue-count (%mailbox-queue mb)))
    152 (define-inline (%mailbox-queue-add! mb x) (%queue-add! (%mailbox-queue mb) x))
    153 (define-inline (%mailbox-queue-remove! mb) (%queue-remove! (%mailbox-queue mb)))
    154 (define-inline (%mailbox-queue-push-back! mb x) (%queue-push-back! (%mailbox-queue mb) x))
    155 (define-inline (%mailbox-queue-push-back-list! mb ls) (%queue-push-back-list! (%mailbox-queue mb) ls))
     154(define-inline (%mailbox-queue-first-pair mb)
     155        (%queue-first-pair (%mailbox-queue mb)) )
     156
     157(define-inline (%mailbox-queue-last-pair mb)
     158        (%queue-last-pair (%mailbox-queue mb)) )
     159
     160(define-inline (%mailbox-queue-empty? mb)
     161        (%queue-empty? (%mailbox-queue mb)) )
     162
     163(define-inline (%mailbox-queue-count mb)
     164        (%queue-count (%mailbox-queue mb)) )
     165
     166(define-inline (%mailbox-queue-add! mb x)
     167        (%queue-add! (%mailbox-queue mb) x) )
     168
     169(define-inline (%mailbox-queue-remove! mb)
     170        (%queue-remove! (%mailbox-queue mb)) )
     171
     172(define-inline (%mailbox-queue-push-back! mb x)
     173        (%queue-push-back! (%mailbox-queue mb) x) )
     174
     175(define-inline (%mailbox-queue-push-back-list! mb ls)
     176        (%queue-push-back-list! (%mailbox-queue mb) ls) )
    156177
    157178;; Waiting threads
    158179
    159 (define-inline (%mailbox-waiters-empty? mb) ($null? (%mailbox-waiters mb)))
    160 (define-inline (%mailbox-waiters-count mb) ($length (%mailbox-waiters mb)))
     180(define-inline (%mailbox-waiters-empty? mb)
     181  ($null? (%mailbox-waiters mb)) )
     182
     183(define-inline (%mailbox-waiters-count mb)
     184  ($length (%mailbox-waiters mb)) )
    161185
    162186(define-inline (%mailbox-waiters-add! mb th)
     
    180204  (mb %mailbox-cursor-mailbox) )
    181205
    182 (define-inline (%make-mailbox-cursor mb) (%%make-mailbox-cursor '() #f mb))
     206(define-inline (%make-mailbox-cursor mb)
     207  (%%make-mailbox-cursor '() #f mb) )
    183208
    184209(define-error-type mailbox-cursor)
    185210(define-inline-check-type mailbox-cursor)
    186211
    187 (define-inline (%mailbox-cursor-winding? mbc) (->boolean (%mailbox-cursor-prev-pair mbc)))
    188 (define-inline (%mailbox-cursor-next-pair-empty! mbc) (%mailbox-cursor-next-pair-set! mbc '()))
    189 (define-inline (%mailbox-cursor-prev-pair-clear! mbc) (%mailbox-cursor-prev-pair-set! mbc #f))
     212(define-inline (%mailbox-cursor-winding? mbc)
     213  (->boolean (%mailbox-cursor-prev-pair mbc)) )
     214
     215(define-inline (%mailbox-cursor-next-pair-empty! mbc)
     216  (%mailbox-cursor-next-pair-set! mbc '()) )
     217
     218(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
     219  (%mailbox-cursor-prev-pair-set! mbc #f) )
    190220
    191221(define-inline (%mailbox-cursor-rewind! mbc)
     
    200230;; Time Support
    201231
    202 (define-inline (%timeout? obj) (or (number? obj) (time? obj)))
     232(define-inline (%timeout? obj)
     233  (or (number? obj) (time? obj)) )
     234
    203235(define-error-type timeout)
    204236(define-inline-check-type timeout)
     
    215247;;; Mailbox Exceptions
    216248
    217 (define (make-mailbox-timeout-condition loc timout timout-value)
    218   (let ((args
    219           (if ($eq? timout-value NO-TOVAL-TAG)
    220             (list timout)
    221             (list timout timout-value))))
    222     (make-exn-condition+ loc "mailbox wait timeout occurred" args 'mailbox 'timeout) ) )
     249(define (make-mailbox-timeout-condition loc mb timout timout-value)
     250  (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
     251    (make-exn-condition+
     252      loc "mailbox wait timeout occurred" (list timout tv)
     253      `(mailbox box ,mb)
     254      `(timeout time ,timout value ,tv) ) ) )
    223255
    224256;;; Mailbox Threading
     
    267299        (thread-signal!
    268300          ($current-thread)
    269           (make-mailbox-timeout-condition loc timout timout-value))
     301          (make-mailbox-timeout-condition loc mb timout timout-value))
    270302        SEQ-FAIL-TAG ) ) )
    271303  ;Push current thread on mailbox waiting queue
     
    277309      (if (eq? ($current-thread) ##sys#primordial-thread)
    278310        (begin
    279           (warning 'mailbox "attempt to sleep primordial-thread")
     311          (warning "mailbox attempt to sleep primordial-thread" mb)
    280312          (timeout-exit!) )
    281313        (cond
  • release/4/mailbox/trunk/tests/mailbox-primordial-test.scm

    r34355 r34359  
     1;from caolan
     2
     3(print)
     4(print "** Test Primordial Waiting **")
     5
    16(use srfi-18 mailbox)
    27
     
    813                           (thread-signal! primordial 'example))))
    914
    10 ;; this hangs forever and eats all my cycles (with timeout)
    11 (print (mailbox-receive! mbox 4))
     15;; (used to - KRL) this hangs forever and eats all my cycles (with timeout)
     16(handle-exceptions exn
     17  (print "+ wait with timeout NOT OK for primordial thread: " (condition->list exn))
     18  (mailbox-receive! mbox 4) )
    1219
    1320;; this exits as expected with the 'example exception (no timeout)
    14 (print (mailbox-receive! mbox))
     21(handle-exceptions exn
     22  (print
     23    "+ wait with no timeout OK for primordial thread: "
     24    (if (condition? exn) (condition->list exn) exn))
     25  (mailbox-receive! mbox) )
  • release/4/mailbox/trunk/tests/run.scm

    r34355 r34359  
    77(system "csi -n -s mailbox-cursor-test.scm")
    88
    9 (print)
    10 (print "Expect Error")
    119(system "csc mailbox-primordial-test.scm")
    1210(cond-expand
Note: See TracChangeset for help on using the changeset viewer.