From d9e3e0453c30d1c2ea6ee5fd832b25233c9a66ce Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Thu, 13 Dec 1990 23:27:03 +0000 Subject: [PATCH] Added lots of without-interrupts and without-gcing to keep them from happening at bad times. --- hemlock/ts-stream.lisp | 184 ++++++++++++++++++++++------------------- 1 file changed, 100 insertions(+), 84 deletions(-) diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp index cc4454a06..da4f50a8f 100644 --- a/hemlock/ts-stream.lisp +++ b/hemlock/ts-stream.lisp @@ -46,10 +46,11 @@ (defun ts-stream-accept-input (remote string) (let ((stream (wire:remote-object-value remote))) (system:without-interrupts + (system:without-gcing (setf (ts-stream-current-input stream) (nconc (ts-stream-current-input stream) (list string))) - (setf (ts-stream-char-pos stream) 0))) + (setf (ts-stream-char-pos stream) 0)))) nil) ;;; %TS-STREAM-LISTEN --- internal. @@ -59,17 +60,18 @@ ;;; (defun %ts-stream-listen (stream) (flet ((check () - (system:without-interrupts - (loop - (let ((current (ts-stream-current-input stream))) - (cond ((null current) - (return nil)) - ((>= (ts-stream-input-read-index stream) - (length (the simple-string (car current)))) - (pop (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0)) - (t - (return t)))))))) + (system:without-interrupts + (system:without-gcing + (loop + (let ((current (ts-stream-current-input stream))) + (cond ((null current) + (return nil)) + ((>= (ts-stream-input-read-index stream) + (length (the simple-string (car current)))) + (pop (ts-stream-current-input stream)) + (setf (ts-stream-input-read-index stream) 0)) + (t + (return t))))))))) (or (check) (progn (system:serve-all-events 0) @@ -83,9 +85,10 @@ (unless (%ts-stream-listen stream) (let ((wire (ts-stream-wire stream)) (ts (ts-stream-typescript stream))) - (wire:remote wire - (ts-buffer-ask-for-input ts)) - (wire:wire-force-output wire) + (system:without-interrupts + (system:without-gcing + (wire:remote wire (ts-buffer-ask-for-input ts)) + (wire:wire-force-output wire))) (loop (system:serve-all-events) (when (%ts-stream-listen stream) @@ -99,12 +102,11 @@ (declare (ignore eoferr eofval)) ; EOF's are impossible. (wait-for-typescript-input stream) (system:without-interrupts - (prog1 - (schar (car (ts-stream-current-input stream)) - (ts-stream-input-read-index stream)) - (incf (ts-stream-input-read-index stream))))) - - + (system:without-gcing + (prog1 + (schar (car (ts-stream-current-input stream)) + (ts-stream-input-read-index stream)) + (incf (ts-stream-input-read-index stream)))))) ;;; %TS-STREAM-READ-LINE --- internal. ;;; @@ -117,12 +119,13 @@ '(progn (wait-for-typescript-input stream) (system:without-interrupts + (system:without-gcing (prog1 (if (zerop (ts-stream-input-read-index stream)) (pop (ts-stream-current-input stream)) (subseq (pop (ts-stream-current-input stream)) (ts-stream-input-read-index stream))) - (setf (ts-stream-input-read-index stream) 0)))))) + (setf (ts-stream-input-read-index stream) 0))))))) (do ((result (next-str) (concatenate 'simple-string result (next-str)))) ((char= (schar result (1- (length result))) #\newline) (values (subseq result 0 (1- (length result))) @@ -131,20 +134,20 @@ ;;; %TS-STREAM-FLSBUF --- internal. ;;; -;;; Flush the output buffer associated with stream. +;;; Flush the output buffer associated with stream. This should only be used +;;; inside a without-interrupts and without-gcing. ;;; (defun %ts-stream-flsbuf (stream) (when (and (ts-stream-wire stream) (ts-stream-output-buffer stream) (not (zerop (ts-stream-output-buffer-index stream)))) (wire:remote (ts-stream-wire stream) - (ts-buffer-output-string (ts-stream-typescript stream) - (subseq (the simple-string - (ts-stream-output-buffer stream)) - 0 - (ts-stream-output-buffer-index stream)))) - (setf (ts-stream-output-buffer-index stream) - 0))) + (ts-buffer-output-string + (ts-stream-typescript stream) + (subseq (the simple-string (ts-stream-output-buffer stream)) + 0 + (ts-stream-output-buffer-index stream)))) + (setf (ts-stream-output-buffer-index stream) 0))) ;;; %TS-STREAM-OUT --- internal. ;;; @@ -152,20 +155,22 @@ ;;; (defun %ts-stream-out (stream char) (declare (base-character char)) - (when (= (ts-stream-output-buffer-index stream) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream)) - (setf (schar (ts-stream-output-buffer stream) - (ts-stream-output-buffer-index stream)) - char) - (incf (ts-stream-output-buffer-index stream)) - (incf (ts-stream-char-pos stream)) - (when (= (char-code char) - (char-code #\Newline)) - (%ts-stream-flsbuf stream) - (setf (ts-stream-char-pos stream) 0) - (wire:wire-force-output (ts-stream-wire stream))) - char) + (system:without-interrupts + (system:without-gcing + (when (= (ts-stream-output-buffer-index stream) + ts-stream-output-buffer-size) + (%ts-stream-flsbuf stream)) + (setf (schar (ts-stream-output-buffer stream) + (ts-stream-output-buffer-index stream)) + char) + (incf (ts-stream-output-buffer-index stream)) + (incf (ts-stream-char-pos stream)) + (when (= (char-code char) + (char-code #\Newline)) + (%ts-stream-flsbuf stream) + (setf (ts-stream-char-pos stream) 0) + (wire:wire-force-output (ts-stream-wire stream))) + char))) ;;; %TS-STREAM-SOUT --- internal. ;;; @@ -178,32 +183,34 @@ (newline (position #\Newline string :start start :end end :from-end t)) (length (- end start))) (when wire - (let ((index (ts-stream-output-buffer-index stream))) - (cond ((> (+ index length) - ts-stream-output-buffer-size) - (%ts-stream-flsbuf stream) - (wire:remote wire - (ts-buffer-output-string (ts-stream-typescript stream) - (subseq string start end))) - (when newline - (wire:wire-force-output wire))) - (t - (replace (the simple-string (ts-stream-output-buffer stream)) - string - :start1 index - :end1 (+ index length) - :start2 start - :end2 end) - (incf (ts-stream-output-buffer-index stream) - length) - (when newline + (system:without-interrupts + (system:without-gcing + (let ((index (ts-stream-output-buffer-index stream))) + (cond ((> (+ index length) + ts-stream-output-buffer-size) (%ts-stream-flsbuf stream) - (wire:wire-force-output wire)))))) - (setf (ts-stream-char-pos stream) - (if newline - (- end newline 1) - (+ (ts-stream-char-pos stream) - length))))) + (wire:remote wire + (ts-buffer-output-string (ts-stream-typescript stream) + (subseq string start end))) + (when newline + (wire:wire-force-output wire))) + (t + (replace (the simple-string (ts-stream-output-buffer stream)) + string + :start1 index + :end1 (+ index length) + :start2 start + :end2 end) + (incf (ts-stream-output-buffer-index stream) + length) + (when newline + (%ts-stream-flsbuf stream) + (wire:wire-force-output wire))))) + (setf (ts-stream-char-pos stream) + (if newline + (- end newline 1) + (+ (ts-stream-char-pos stream) + length)))))))) ;;; %TS-STREAM-UNREAD --- internal. ;;; @@ -211,6 +218,7 @@ ;;; (defun %ts-stream-unread (stream char) (system:without-interrupts + (system:without-gcing (cond ((and (ts-stream-current-input stream) (> (ts-stream-input-read-index stream) 0)) (setf (schar (car (ts-stream-current-input stream)) @@ -218,7 +226,7 @@ char)) (t (push (string char) (ts-stream-current-input stream)) - (setf (ts-stream-input-read-index stream) 0))))) + (setf (ts-stream-input-read-index stream) 0)))))) ;;; %TS-STREAM-CLOSE --- internal. ;;; @@ -234,12 +242,13 @@ ;;; Pass the request to the editor and clear any buffered input. ;;; (defun %ts-stream-clear-input (stream) - (when (ts-stream-wire stream) - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-clear-input (ts-stream-typescript stream)))) (system:without-interrupts + (system:without-gcing + (when (ts-stream-wire stream) + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-clear-input (ts-stream-typescript stream)))) (setf (ts-stream-current-input stream) nil - (ts-stream-input-read-index stream) 0))) + (ts-stream-input-read-index stream) 0)))) ;;; %TS-STREAM-MISC --- internal. ;;; @@ -260,24 +269,31 @@ t) (:finish-output (when (ts-stream-wire stream) - (%ts-stream-flsbuf stream) - ;; Note: for the return value to come back, - ;; all pending RPCs must have completed. - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-finish-output (ts-stream-typescript stream)))) + (system:without-interrupts + (system:without-gcing + (%ts-stream-flsbuf stream) + ;; Note: for the return value to come back, + ;; all pending RPCs must have completed. + ;; Therefore, we know it has synced. + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-finish-output (ts-stream-typescript stream)))))) t) (:force-output (when (ts-stream-wire stream) - (%ts-stream-flsbuf stream) - (wire:wire-force-output (ts-stream-wire stream))) + (system:without-interrupts + (system:without-gcing + (%ts-stream-flsbuf stream) + (wire:wire-force-output (ts-stream-wire stream))))) t) (:clear-output (setf (ts-stream-output-buffer-index stream) 0) t) (:element-type - 'char-string) + 'base-character) (:charpos (ts-stream-char-pos stream)) (:line-length - (wire:remote-value (ts-stream-wire stream) - (ts-buffer-line-length (ts-stream-typescript stream)))))) + (system:without-interrupts + (system:without-gcing + (wire:remote-value (ts-stream-wire stream) + (ts-buffer-line-length (ts-stream-typescript stream)))))))) -- GitLab