home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / intrpt.scm < prev    next >
Text File  |  1999-01-02  |  9KB  |  253 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: intrpt.scm,v 14.22 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Interrupt System
  23. ;;; package: (runtime interrupt-handler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! index:interrupt-vector
  29.     (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
  30.   (set! index:interrupt-mask-vector
  31.     (fixed-objects-vector-slot 'INTERRUPT-MASK-VECTOR))
  32.   (set! index:termination-vector
  33.     (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES))
  34.   (set! hook/clean-input/flush-typeahead false)
  35.   (set! hook/clean-input/keep-typeahead false)
  36.   (set! hook/^B-interrupt false)
  37.   (set! hook/^G-interrupt false)
  38.   (set! hook/^U-interrupt false)
  39.   (set! hook/^X-interrupt false)
  40.   (set! keyboard-interrupt-vector
  41.     (let ((table (make-vector 256 false)))
  42.       (for-each (lambda (entry)
  43.               (vector-set! table
  44.                    (char->ascii (car entry))
  45.                    (cadr entry)))
  46.             `((#\B ,^B-interrupt-handler)
  47.               (#\G ,^G-interrupt-handler)
  48.               (#\U ,^U-interrupt-handler)
  49.               (#\X ,^X-interrupt-handler)))
  50.       table))
  51.   (install))
  52.  
  53. (define-primitives
  54.   (clear-interrupts! 1)
  55.   (tty-next-interrupt-char 0)
  56.   set-fixed-objects-vector!
  57.   (process-timer-clear 0)
  58.   (real-timer-clear 0))
  59.  
  60. ;; These interrupt bit positions must be allocated to bits that fit in
  61. ;; the datum field of a positive-fixnum.
  62.  
  63. (define-integrable stack-overflow-slot 0)
  64. (define-integrable global-gc-slot 1)
  65. (define-integrable gc-slot 2)
  66. (define-integrable character-slot 4)
  67. (define-integrable after-gc-slot 5)
  68. (define-integrable timer-slot 6)
  69. (define-integrable suspend-slot 8)
  70. ;; Room for Descartes profiler interrupt handlers
  71. (define-integrable illegal-interrupt-slot 15)
  72.  
  73. (define index:interrupt-vector)
  74. (define index:interrupt-mask-vector)
  75. (define index:termination-vector)
  76.  
  77. ;;;; Miscellaneous Interrupts
  78.  
  79. (define (timer-interrupt-handler interrupt-code interrupt-enables)
  80.   interrupt-code interrupt-enables
  81.   (clear-interrupts! interrupt-bit/timer)
  82.   (thread-timer-interrupt-handler))
  83.  
  84. ;; This switch is set by the command-line initialization code.
  85. (define generate-suspend-file?)
  86.  
  87. (define (suspend-interrupt-handler interrupt-code interrupt-enables)
  88.   interrupt-code interrupt-enables
  89.   (clear-interrupts! interrupt-bit/suspend)
  90.   (if generate-suspend-file?
  91.       (bind-condition-handler (list condition-type:serious-condition)
  92.       (lambda (condition)
  93.         condition
  94.         (%exit))
  95.     (lambda ()
  96.       (bind-condition-handler (list condition-type:warning)
  97.           (lambda (condition)
  98.         condition
  99.         (muffle-warning))
  100.         (lambda ()
  101.           (if (not (disk-save (merge-pathnames "scheme_suspend"
  102.                            (user-homedir-pathname))
  103.                   true))
  104.           (%exit))))))
  105.       (%exit)))
  106.  
  107. (define (gc-out-of-space-handler . args)
  108.   args
  109.   (abort->nearest "Aborting! Out of memory"))
  110.  
  111. (define (after-gc-interrupt-handler interrupt-code interrupt-enables)
  112.   interrupt-code interrupt-enables
  113.   (trigger-gc-daemons!)
  114.   ;; By clearing the interrupt after running the daemons we ignore an
  115.   ;; GC that occurs while we are running the daemons.  This helps
  116.   ;; prevent us from getting into a loop just running the daemons.
  117.   (clear-interrupts! interrupt-bit/after-gc))
  118.  
  119. (define ((illegal-interrupt-handler interrupt-bit)
  120.      interrupt-code interrupt-enables)
  121.   (clear-interrupts! interrupt-bit)
  122.   (error "Illegal interrupt" interrupt-code interrupt-enables))
  123.  
  124. ;;;; Keyboard Interrupts
  125.  
  126. (define keyboard-interrupt-vector)
  127. (define hook/clean-input/flush-typeahead)
  128. (define hook/clean-input/keep-typeahead)
  129. (define hook/^B-interrupt)
  130. (define hook/^G-interrupt)
  131. (define hook/^U-interrupt)
  132. (define hook/^X-interrupt)
  133.  
  134. (define (external-interrupt-handler interrupt-code interrupt-mask)
  135.   interrupt-code interrupt-mask
  136.   (clear-interrupts! interrupt-bit/kbd)
  137.   (let ((char (tty-next-interrupt-char)))
  138.     (let ((handler (vector-ref keyboard-interrupt-vector char)))
  139.       (if (not handler)
  140.       (error "Bad interrupt character:" char))
  141.       (handler char))))
  142.  
  143. (define (^B-interrupt-handler char)
  144.   (signal-interrupt hook/^B-interrupt
  145.             hook/clean-input/keep-typeahead
  146.             char
  147.             cmdl-interrupt/breakpoint))
  148.  
  149. (define (^G-interrupt-handler char)
  150.   (signal-interrupt hook/^G-interrupt
  151.             hook/clean-input/flush-typeahead
  152.             char
  153.             cmdl-interrupt/abort-top-level))
  154.  
  155. (define (^U-interrupt-handler char)
  156.   (signal-interrupt hook/^U-interrupt
  157.             hook/clean-input/flush-typeahead
  158.             char
  159.             cmdl-interrupt/abort-previous))
  160.  
  161. (define (^X-interrupt-handler char)
  162.   (signal-interrupt hook/^X-interrupt
  163.             hook/clean-input/flush-typeahead
  164.             char
  165.             cmdl-interrupt/abort-nearest))
  166.  
  167. (define (signal-interrupt hook/interrupt hook/clean-input char interrupt)
  168.   (let ((thread (thread-mutex-owner (port/thread-mutex console-i/o-port))))
  169.     (if thread
  170.     (signal-thread-event thread
  171.       (lambda ()
  172.         (if hook/interrupt
  173.         (hook/interrupt))
  174.         (if (or (not hook/clean-input)
  175.             (hook/clean-input char))
  176.         (interrupt)))))))
  177.  
  178. (define (install)
  179.   (without-interrupts
  180.    (lambda ()
  181.      (let ((system-interrupt-vector
  182.         (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
  183.        (old-interrupt-mask-vector
  184.         (vector-ref (get-fixed-objects-vector)
  185.             index:interrupt-mask-vector))
  186.        (old-termination-vector
  187.         (vector-ref (get-fixed-objects-vector) index:termination-vector)))
  188.        (let ((interrupt-mask-vector
  189.           (let ((length (vector-length system-interrupt-vector)))
  190.         (if (and (vector? old-interrupt-mask-vector)
  191.              (= (vector-length old-interrupt-mask-vector) length))
  192.             old-interrupt-mask-vector
  193.             (make-vector length))))
  194.          (termination-vector
  195.           (let ((length (microcode-termination/code-limit)))
  196.         (if old-termination-vector
  197.             (if (> length (vector-length old-termination-vector))
  198.             (vector-grow old-termination-vector length)
  199.             old-termination-vector)
  200.             (make-vector length #f)))))
  201.  
  202.      (let ((length (vector-length system-interrupt-vector)))
  203.        (do ((i 0 (fix:+ i 1)))
  204.            ((fix:= i length))
  205.          (if (not (vector-ref system-interrupt-vector i))
  206.          (let ((interrupt-bit (fix:lsh 1 i)))
  207.            (vector-set! interrupt-mask-vector i
  208.                 (fix:- interrupt-bit 1)) ; higher priority only
  209.            (vector-set! system-interrupt-vector i
  210.                 (illegal-interrupt-handler interrupt-bit))))))
  211.  
  212.      (vector-set! interrupt-mask-vector stack-overflow-slot
  213.               interrupt-mask/none)
  214.  
  215.      (vector-set! interrupt-mask-vector gc-slot
  216.               ;; interrupt-mask/none
  217.               (fix:lsh 1 global-gc-slot))
  218.  
  219.      (vector-set! system-interrupt-vector timer-slot
  220.               timer-interrupt-handler)
  221.      (vector-set! interrupt-mask-vector timer-slot
  222.               interrupt-mask/gc-ok)
  223.  
  224.      (vector-set! system-interrupt-vector character-slot
  225.               external-interrupt-handler)
  226.      (vector-set! interrupt-mask-vector character-slot
  227.               interrupt-mask/timer-ok)
  228.  
  229.      (vector-set! system-interrupt-vector after-gc-slot
  230.               after-gc-interrupt-handler)
  231.      (vector-set! interrupt-mask-vector after-gc-slot
  232.               interrupt-mask/timer-ok)
  233.  
  234.      (vector-set! system-interrupt-vector suspend-slot
  235.               suspend-interrupt-handler)
  236.      (vector-set! interrupt-mask-vector suspend-slot
  237.               interrupt-mask/timer-ok)
  238.  
  239.      (vector-set! termination-vector
  240.               (microcode-termination 'GC-OUT-OF-SPACE)
  241.               gc-out-of-space-handler)
  242.  
  243.      ;; Install the new tables atomically:
  244.  
  245.      (vector-set! (get-fixed-objects-vector)
  246.               index:interrupt-mask-vector
  247.               interrupt-mask-vector)
  248.  
  249.      (vector-set! (get-fixed-objects-vector)
  250.               index:termination-vector
  251.               termination-vector)
  252.  
  253.      (set-fixed-objects-vector! (get-fixed-objects-vector)))))))