diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 4 | ||||
-rw-r--r-- | module/ice-9/ftw.scm | 5 | ||||
-rw-r--r-- | module/rnrs/io/simple.scm | 13 | ||||
-rw-r--r-- | module/scripts/snarf-check-and-output-texi.scm | 15 | ||||
-rw-r--r-- | module/srfi/srfi-18.scm | 8 | ||||
-rw-r--r-- | module/srfi/srfi-19.scm | 9 | ||||
-rw-r--r-- | module/system/base/types.scm | 529 | ||||
-rw-r--r-- | module/system/repl/coop-server.scm | 193 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 14 | ||||
-rw-r--r-- | module/system/repl/server.scm | 103 |
10 files changed, 841 insertions, 52 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index a6b20aff9..abc8a7363 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -202,6 +202,7 @@ SYSTEM_BASE_SOURCES = \ system/base/lalr.scm \ system/base/message.scm \ system/base/target.scm \ + system/base/types.scm \ system/base/ck.scm ICE_9_SOURCES = \ @@ -386,7 +387,8 @@ SYSTEM_SOURCES = \ system/repl/common.scm \ system/repl/command.scm \ system/repl/repl.scm \ - system/repl/server.scm + system/repl/server.scm \ + system/repl/coop-server.scm LIB_SOURCES = \ statprof.scm \ diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 9c9694fd7..133e9c9b5 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- file system tree walk -;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -259,7 +259,8 @@ (let* ((perms (stat:perms s)) (perms-bit-set? (lambda (mask) (not (= 0 (logand mask perms)))))) - (or (and (= uid (stat:uid s)) + (or (zero? uid) + (and (= uid (stat:uid s)) (perms-bit-set? #o400)) (and (= gid (stat:gid s)) (perms-bit-set? #o040)) diff --git a/module/rnrs/io/simple.scm b/module/rnrs/io/simple.scm index 031628b38..5eb396f0e 100644 --- a/module/rnrs/io/simple.scm +++ b/module/rnrs/io/simple.scm @@ -1,6 +1,6 @@ ;;; simple.scm --- The R6RS simple I/O library -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -91,6 +91,7 @@ eof-object eof-object? file-options + buffer-mode native-transcoder get-char lookahead-char @@ -131,10 +132,16 @@ (lambda (port) (with-output-to-port port thunk)))) (define (open-input-file filename) - (open-file-input-port filename (file-options) (native-transcoder))) + (open-file-input-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define (open-output-file filename) - (open-file-output-port filename (file-options) (native-transcoder))) + (open-file-output-port filename + (file-options) + (buffer-mode block) + (native-transcoder))) (define close-input-port close-port) (define close-output-port close-port) diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index 6ca07a1f4..82d71f4a9 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -63,7 +63,7 @@ (let loop ((s s)) (cond ((stream-null? s) #t) - ((eq? 'eol (stream-car s)) + ((memq (stream-car s) '(eol hash)) (loop (stream-cdr s))) (else (cons (stream-car s) (stream-cdr s)))))) (port->stream port read))))) @@ -265,17 +265,6 @@ (set! *file* file) (set! *line* line)) - ;; newer gccs like to throw around more location markers into the - ;; preprocessed source; these (hash . hash) bits are what they translate to - ;; in snarfy terms. - (('location ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - - (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash)) - (set! *file* file) - (set! *line* line)) - (('arglist rest ...) (set! *args* (do-arglist rest))) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 684a1254e..832b43606 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -82,7 +82,7 @@ uncaught-exception? uncaught-exception-reason ) - :re-export (thread? mutex? condition-variable?) + :re-export (current-thread thread? mutex? condition-variable?) :replace (current-time make-thread make-mutex @@ -236,7 +236,7 @@ (list timeout) '())))) (secs (inexact->exact (truncate t))) - (usecs (inexact->exact (truncate (* (- t secs) 1000))))) + (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) (and (> secs 0) (sleep secs)) (and (> usecs 0) (usleep usecs)) *unspecified*)) @@ -380,4 +380,4 @@ (cons (inexact->exact fx) (inexact->exact (truncate (* (- x fx) 1000000))))))) -;; srfi-18.scm ends here
\ No newline at end of file +;; srfi-18.scm ends here diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index c0a27b1a2..6d86ee638 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,6 +1,7 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, +;; 2011, 2014 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -171,7 +172,7 @@ ;; A table of leap seconds ;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat ;; and update as necessary. -;; this procedures reads the file in the abover +;; this procedures reads the file in the above ;; format and creates the leap second table ;; it also calls the almost standard, but not R5 procedures read-line ;; & open-input-string @@ -202,7 +203,9 @@ ;; each entry is (tai seconds since epoch . # seconds to subtract for utc) ;; note they go higher to lower, and end in 1972. (define leap-second-table - '((1136073600 . 33) + '((1341100800 . 35) + (1230768000 . 34) + (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) diff --git a/module/system/base/types.scm b/module/system/base/types.scm new file mode 100644 index 000000000..6c1d40d7f --- /dev/null +++ b/module/system/base/types.scm @@ -0,0 +1,529 @@ +;;; 'SCM' type tag decoding. +;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;; +;;; This library is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +(define-module (system base types) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-60) + #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (ice-9 format) + #:use-module (ice-9 vlist) + #:use-module (system foreign) + #:export (%word-size + + memory-backend + memory-backend? + %ffi-memory-backend + dereference-word + memory-port + type-number->name + + inferior-object? + inferior-object-kind + inferior-object-sub-kind + inferior-object-address + + inferior-fluid? + inferior-fluid-number + + inferior-struct? + inferior-struct-name + inferior-struct-fields + + scm->object)) + +;;; Commentary: +;;; +;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB. +;;; +;;; Code: + + +;;; +;;; Memory back-ends. +;;; + +(define %word-size + ;; The pointer size. + (sizeof '*)) + +(define-record-type <memory-backend> + (memory-backend peek open type-name) + memory-backend? + (peek memory-backend-peek) + (open memory-backend-open) + (type-name memory-backend-type-name)) ; for SMOBs and ports + +(define %ffi-memory-backend + ;; The FFI back-end to access the current process's memory. The main + ;; purpose of this back-end is to allow testing. + (let () + (define (dereference-word address) + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + + (define (open address size) + (define current-address address) + + (define (read-memory! bv index count) + (let* ((ptr (make-pointer current-address)) + (mem (pointer->bytevector ptr count))) + (bytevector-copy! mem 0 bv index count) + (set! current-address (+ current-address count)) + count)) + + (if size + (let* ((ptr (make-pointer address)) + (bv (pointer->bytevector ptr size))) + (open-bytevector-input-port bv)) + (let ((port (make-custom-binary-input-port "ffi-memory" + read-memory! + #f #f #f))) + (setvbuf port _IONBF) + port))) + + (memory-backend dereference-word open #f))) + +(define-inlinable (dereference-word backend address) + "Return the word at ADDRESS, using BACKEND." + (let ((peek (memory-backend-peek backend))) + (peek address))) + +(define-syntax memory-port + (syntax-rules () + "Return an input port to the SIZE bytes at ADDRESS, using BACKEND. When +SIZE is omitted, return an unbounded port to the memory at ADDRESS." + ((_ backend address) + (let ((open (memory-backend-open backend))) + (open address #f))) + ((_ backend address size) + (let ((open (memory-backend-open backend))) + (open address size))))) + +(define (get-word port) + "Read a word from PORT and return it as an integer." + (let ((bv (get-bytevector-n port %word-size))) + (bytevector-uint-ref bv 0 (native-endianness) %word-size))) + +(define-inlinable (type-number->name backend kind number) + "Return the name of the type NUMBER of KIND, where KIND is one of +'smob or 'port, or #f if the information is unavailable." + (let ((proc (memory-backend-type-name backend))) + (and proc (proc kind number)))) + + +;;; +;;; Matching bit patterns and cells. +;;; + +(define-syntax match-cell-words + (syntax-rules (bytevector) + ((_ port ((bytevector name len) rest ...) body) + (let ((name (get-bytevector-n port len)) + (remainder (modulo len %word-size))) + (unless (zero? remainder) + (get-bytevector-n port (- %word-size remainder))) + (match-cell-words port (rest ...) body))) + ((_ port (name rest ...) body) + (let ((name (get-word port))) + (match-cell-words port (rest ...) body))) + ((_ port () body) + body))) + +(define-syntax match-bit-pattern + (syntax-rules (& || = _) + ((match-bit-pattern bits ((a || b) & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((b tag) + (a (logand bits (bitwise-not n)))) + consequent) + alternate))) + ((match-bit-pattern bits (x & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + (let ((x bits)) + consequent) + alternate))) + ((match-bit-pattern bits (_ & n = c) consequent alternate) + (let ((tag (logand bits n))) + (if (= tag c) + consequent + alternate))) + ((match-bit-pattern bits ((a << n) || c) consequent alternate) + (let ((tag (bitwise-and bits (- (expt 2 n) 1)))) + (if (= tag c) + (let ((a (arithmetic-shift bits (- n)))) + consequent) + alternate))))) + +(define-syntax match-cell-clauses + (syntax-rules () + ((_ port tag (((tag-pattern thing ...) body) rest ...)) + (match-bit-pattern tag tag-pattern + (match-cell-words port (thing ...) body) + (match-cell-clauses port tag (rest ...)))) + ((_ port tag ()) + (inferior-object 'unmatched-tag tag)))) + +(define-syntax match-cell + (syntax-rules () + "Match a cell---i.e., a non-immediate value other than a pair. The +cell's contents are read from PORT." + ((_ port (pattern body ...) ...) + (let ((port* port) + (tag (get-word port))) + (match-cell-clauses port* tag + ((pattern (begin body ...)) + ...)))))) + +(define-syntax match-scm-clauses + (syntax-rules () + ((_ bits + (bit-pattern body ...) + rest ...) + (match-bit-pattern bits bit-pattern + (begin body ...) + (match-scm-clauses bits rest ...))) + ((_ bits) + 'unmatched-scm))) + +(define-syntax match-scm + (syntax-rules () + "Match BITS, an integer representation of an 'SCM' value, against +CLAUSES. Each clause must have the form: + + (PATTERN BODY ...) + +PATTERN is a bit pattern that may specify bitwise operations on BITS to +determine if it matches. TEMPLATE specify the name of the variable to bind +the matching bits, possibly with bitwise operations to extract it from BITS." + ((_ bits clauses ...) + (let ((bits* bits)) + (match-scm-clauses bits* clauses ...))))) + + +;;; +;;; Tags---keep in sync with libguile/tags.h! +;;; + +;; Immediate values. +(define %tc2-int 2) +(define %tc3-imm24 4) + +(define %tc3-cons 0) +(define %tc3-int1 %tc2-int) +(define %tc3-int2 (+ %tc2-int 4)) + +(define %tc8-char (+ 8 %tc3-imm24)) +(define %tc8-flag (+ %tc3-imm24 0)) + +;; Cell types. +(define %tc3-struct 1) +(define %tc7-symbol 5) +(define %tc7-vector 13) +(define %tc7-wvect 15) +(define %tc7-string 21) +(define %tc7-number 23) +(define %tc7-hashtable 29) +(define %tc7-pointer 31) +(define %tc7-fluid 37) +(define %tc7-stringbuf 39) +(define %tc7-dynamic-state 45) +(define %tc7-frame 47) +(define %tc7-program 69) +(define %tc7-vm-continuation 71) +(define %tc7-bytevector 77) +(define %tc7-weak-set 85) +(define %tc7-weak-table 87) +(define %tc7-array 93) +(define %tc7-bitvector 95) +(define %tc7-port 125) +(define %tc7-smob 127) + +(define %tc16-bignum (+ %tc7-number (* 1 256))) +(define %tc16-real (+ %tc7-number (* 2 256))) +(define %tc16-complex (+ %tc7-number (* 3 256))) +(define %tc16-fraction (+ %tc7-number (* 4 256))) + + +;; "Stringbufs". +(define-record-type <stringbuf> + (stringbuf string) + stringbuf? + (string stringbuf-contents)) + +(set-record-type-printer! <stringbuf> + (lambda (stringbuf port) + (display "#<stringbuf " port) + (write (stringbuf-contents stringbuf) port) + (display "#>" port))) + +;; Structs. +(define-record-type <inferior-struct> + (inferior-struct name fields) + inferior-struct? + (name inferior-struct-name) + (fields inferior-struct-fields set-inferior-struct-fields!)) + +(define print-inferior-struct + (let ((%printed-struct (make-parameter vlist-null))) + (lambda (struct port) + (if (vhash-assq struct (%printed-struct)) + (format port "#-1#") + (begin + (format port "#<struct ~a" + (inferior-struct-name struct)) + (parameterize ((%printed-struct + (vhash-consq struct #t (%printed-struct)))) + (for-each (lambda (field) + (if (eq? field struct) + (display " #0#" port) + (format port " ~s" field))) + (inferior-struct-fields struct))) + (format port " ~x>" (object-address struct))))))) + +(set-record-type-printer! <inferior-struct> print-inferior-struct) + +;; Fluids. +(define-record-type <inferior-fluid> + (inferior-fluid number value) + inferior-fluid? + (number inferior-fluid-number) + (value inferior-fluid-value)) + +(set-record-type-printer! <inferior-fluid> + (lambda (fluid port) + (match fluid + (($ <inferior-fluid> number) + (format port "#<fluid ~a ~x>" + number + (object-address fluid)))))) + +;; Object type to represent complex objects from the inferior process that +;; cannot be really converted to usable Scheme objects in the current +;; process. +(define-record-type <inferior-object> + (%inferior-object kind sub-kind address) + inferior-object? + (kind inferior-object-kind) + (sub-kind inferior-object-sub-kind) + (address inferior-object-address)) + +(define inferior-object + (case-lambda + "Return an object representing an inferior object at ADDRESS, of type +KIND/SUB-KIND." + ((kind address) + (%inferior-object kind #f address)) + ((kind sub-kind address) + (%inferior-object kind sub-kind address)))) + +(set-record-type-printer! <inferior-object> + (lambda (io port) + (match io + (($ <inferior-object> kind sub-kind address) + (format port "#<~a ~:[~*~;~a ~]~x>" + kind sub-kind sub-kind + address))))) + +(define (inferior-smob backend type-number address) + "Return an object representing the SMOB at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'smob + (or (type-number->name backend 'smob type-number) + type-number) + address)) + +(define (inferior-port backend type-number address) + "Return an object representing the port at ADDRESS whose type is +TYPE-NUMBER." + (inferior-object 'port + (or (type-number->name backend 'port type-number) + type-number) + address)) + +(define %visited-cells + ;; Vhash of mapping addresses of already visited cells to the + ;; corresponding inferior object. This is used to detect and represent + ;; cycles. + (make-parameter vlist-null)) + +(define-syntax visited + (syntax-rules (->) + ((_ (address -> object) body ...) + (parameterize ((%visited-cells (vhash-consv address object + (%visited-cells)))) + body ...)))) + +(define (address->inferior-struct address vtable-data-address backend) + "Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct' +object representing it." + (define %vtable-layout-index 0) + (define %vtable-name-index 5) + + (let* ((layout-address (+ vtable-data-address + (* %vtable-layout-index %word-size))) + (layout-bits (dereference-word backend layout-address)) + (layout (scm->object layout-bits backend)) + (name-address (+ vtable-data-address + (* %vtable-name-index %word-size))) + (name-bits (dereference-word backend name-address)) + (name (scm->object name-bits backend))) + (if (symbol? layout) + (let* ((layout (symbol->string layout)) + (len (/ (string-length layout) 2)) + (slots (dereference-word backend (+ address %word-size))) + (port (memory-port backend slots (* len %word-size))) + (fields (get-bytevector-n port (* len %word-size))) + (result (inferior-struct name #f))) + + ;; Keep track of RESULT so callees can refer to it if we are + ;; decoding a circular struct. + (visited (address -> result) + (let ((values (map (cut scm->object <> backend) + (bytevector->uint-list fields + (native-endianness) + %word-size)))) + (set-inferior-struct-fields! result values) + result))) + (inferior-object 'invalid-struct address)))) + +(define* (cell->object address #:optional (backend %ffi-memory-backend)) + "Return an object representing the object at ADDRESS, reading from memory +using BACKEND." + (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object + (let ((port (memory-port backend address))) + (match-cell port + (((vtable-data-address & 7 = %tc3-struct)) + (address->inferior-struct address + (- vtable-data-address %tc3-struct) + backend)) + (((_ & #x7f = %tc7-symbol) buf hash props) + (match (cell->object buf backend) + (($ <stringbuf> string) + (string->symbol string)))) + (((_ & #x7f = %tc7-string) buf start len) + (match (cell->object buf backend) + (($ <stringbuf> string) + (substring string start (+ start len))))) + (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len)) + (stringbuf (bytevector->string buf "ISO-8859-1"))) + (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf)) + len (bytevector buf (* 4 len))) + (stringbuf (bytevector->string buf (match (native-endianness) + ('little "UTF-32LE") + ('big "UTF-32BE"))))) + (((_ & #x7f = %tc7-bytevector) len address) + (let ((bv-port (memory-port backend address len))) + (get-bytevector-all bv-port))) + ((((len << 8) || %tc7-vector)) + (let ((words (get-bytevector-n port (* len %word-size))) + (vector (make-vector len))) + (visited (address -> vector) + (fold (lambda (element index) + (vector-set! vector index element) + (+ 1 index)) + 0 + (map (cut scm->object <> backend) + (bytevector->uint-list words (native-endianness) + %word-size))) + vector))) + (((_ & #x7f = %tc7-wvect)) + (inferior-object 'weak-vector address)) ; TODO: show elements + ((((n << 8) || %tc7-fluid) init-value) + (inferior-fluid n #f)) ; TODO: show current value + (((_ & #x7f = %tc7-dynamic-state)) + (inferior-object 'dynamic-state address)) + ((((flags+type << 8) || %tc7-port)) + (inferior-port backend (logand flags+type #xff) address)) + (((_ & #x7f = %tc7-program)) + (inferior-object 'program address)) + (((_ & #xffff = %tc16-bignum)) + (inferior-object 'bignum address)) + (((_ & #xffff = %tc16-real) pad) + (let* ((address (+ address (* 2 %word-size))) + (port (memory-port backend address (sizeof double))) + (words (get-bytevector-n port (sizeof double)))) + (bytevector-ieee-double-ref words 0 (native-endianness)))) + (((_ & #x7f = %tc7-number) mpi) + (inferior-object 'number address)) + (((_ & #x7f = %tc7-hashtable) buckets meta-data unused) + (inferior-object 'hash-table address)) + (((_ & #x7f = %tc7-pointer) address) + (make-pointer address)) + (((_ & #x7f = %tc7-vm-continuation)) + (inferior-object 'vm-continuation address)) + (((_ & #x7f = %tc7-weak-set)) + (inferior-object 'weak-set address)) + (((_ & #x7f = %tc7-weak-table)) + (inferior-object 'weak-table address)) + (((_ & #x7f = %tc7-array)) + (inferior-object 'array address)) + (((_ & #x7f = %tc7-bitvector)) + (inferior-object 'bitvector address)) + ((((smob-type << 8) || %tc7-smob) word1) + (inferior-smob backend smob-type address)))))) + + +(define* (scm->object bits #:optional (backend %ffi-memory-backend)) + "Return the Scheme object corresponding to BITS, the bits of an 'SCM' +object." + (match-scm bits + (((integer << 2) || %tc2-int) + integer) + ((address & 6 = %tc3-cons) + (let* ((type (dereference-word backend address)) + (pair? (not (bit-set? 0 type)))) + (if pair? + (or (and=> (vhash-assv address (%visited-cells)) cdr) + (let ((car type) + (cdrloc (+ address %word-size)) + (pair (cons *unspecified* *unspecified*))) + (visited (address -> pair) + (set-car! pair (scm->object car backend)) + (set-cdr! pair + (scm->object (dereference-word backend cdrloc) + backend)) + pair))) + (cell->object address backend)))) + (((char << 8) || %tc8-char) + (integer->char char)) + (((flag << 8) || %tc8-flag) + (case flag + ((0) #f) + ((1) #nil) + ((3) '()) + ((4) #t) + ((8) (if #f #f)) + ((9) (inferior-object 'undefined bits)) + ((10) (eof-object)) + ((11) (inferior-object 'unbound bits)))))) + +;;; Local Variables: +;;; eval: (put 'match-scm 'scheme-indent-function 1) +;;; eval: (put 'match-cell 'scheme-indent-function 1) +;;; eval: (put 'visited 'scheme-indent-function 1) +;;; End: + +;;; types.scm ends here diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm new file mode 100644 index 000000000..c19dda191 --- /dev/null +++ b/module/system/repl/coop-server.scm @@ -0,0 +1,193 @@ +;;; Cooperative REPL server + +;; Copyright (C) 2014 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Code: + +(define-module (system repl coop-server) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 threads) + #:use-module (ice-9 q) + #:use-module (srfi srfi-9) + #:use-module ((system repl repl) + #:select (start-repl* prompting-meta-read)) + #:use-module ((system repl server) + #:select (run-server* make-tcp-server-socket + add-open-socket! close-socket!)) + #:export (spawn-coop-repl-server + poll-coop-repl-server)) + +(define-record-type <coop-repl-server> + (%make-coop-repl-server mutex queue) + coop-repl-server? + (mutex coop-repl-server-mutex) + (queue coop-repl-server-queue)) + +(define (make-coop-repl-server) + (%make-coop-repl-server (make-mutex) (make-q))) + +(define (coop-repl-server-eval coop-server opcode . args) + "Queue a new instruction with the symbolic name OPCODE and an arbitrary +number of arguments, to be processed the next time COOP-SERVER is polled." + (with-mutex (coop-repl-server-mutex coop-server) + (enq! (coop-repl-server-queue coop-server) + (cons opcode args)))) + +(define-record-type <coop-repl> + (%make-coop-repl mutex condvar thunk cont) + coop-repl? + (mutex coop-repl-mutex) + (condvar coop-repl-condvar) ; signaled when thunk becomes non-#f + (thunk coop-repl-read-thunk set-coop-repl-read-thunk!) + (cont coop-repl-cont set-coop-repl-cont!)) + +(define (make-coop-repl) + (%make-coop-repl (make-mutex) (make-condition-variable) #f #f)) + +(define (coop-repl-read coop-repl) + "Read an expression via the thunk stored in COOP-REPL." + (let ((thunk + (with-mutex (coop-repl-mutex coop-repl) + (unless (coop-repl-read-thunk coop-repl) + (wait-condition-variable (coop-repl-condvar coop-repl) + (coop-repl-mutex coop-repl))) + (let ((thunk (coop-repl-read-thunk coop-repl))) + (unless thunk + (error "coop-repl-read: condvar signaled, but thunk is #f!")) + (set-coop-repl-read-thunk! coop-repl #f) + thunk)))) + (thunk))) + +(define (store-repl-cont cont coop-repl) + "Save the partial continuation CONT within COOP-REPL." + (set-coop-repl-cont! coop-repl + (lambda (exp) + (coop-repl-prompt + (lambda () (cont exp)))))) + +(define (coop-repl-prompt thunk) + "Apply THUNK within a prompt for cooperative REPLs." + (call-with-prompt 'coop-repl-prompt thunk store-repl-cont)) + +(define (make-coop-reader coop-repl) + "Return a new procedure for reading user input from COOP-REPL. The +generated procedure passes the responsibility of reading input to +another thread and aborts the cooperative REPL prompt." + (lambda (repl) + (let ((read-thunk + ;; Need to preserve the REPL stack and current module across + ;; threads. + (let ((stack (fluid-ref *repl-stack*)) + (module (current-module))) + (lambda () + (with-fluids ((*repl-stack* stack)) + (set-current-module module) + (prompting-meta-read repl)))))) + (with-mutex (coop-repl-mutex coop-repl) + (when (coop-repl-read-thunk coop-repl) + (error "coop-reader: read-thunk is not #f!")) + (set-coop-repl-read-thunk! coop-repl read-thunk) + (signal-condition-variable (coop-repl-condvar coop-repl)))) + (abort-to-prompt 'coop-repl-prompt coop-repl))) + +(define (reader-loop coop-server coop-repl) + "Run an unbounded loop that reads an expression for COOP-REPL and +stores the expression within COOP-SERVER for later evaluation." + (coop-repl-server-eval coop-server 'eval coop-repl + (coop-repl-read coop-repl)) + (reader-loop coop-server coop-repl)) + +(define (poll-coop-repl-server coop-server) + "Poll the cooperative REPL server COOP-SERVER and apply a pending +operation if there is one, such as evaluating an expression typed at the +REPL prompt. This procedure must be called from the same thread that +called spawn-coop-repl-server." + (let ((op (with-mutex (coop-repl-server-mutex coop-server) + (let ((queue (coop-repl-server-queue coop-server))) + (and (not (q-empty? queue)) + (deq! queue)))))) + (when op + (match op + (('new-repl client) + (start-repl-client coop-server client)) + (('eval coop-repl exp) + ((coop-repl-cont coop-repl) exp)))) + *unspecified*)) + +(define (start-coop-repl coop-server) + "Start a new cooperative REPL process for COOP-SERVER." + ;; Calling stop-server-and-clients! from a REPL will cause an + ;; exception to be thrown when trying to read from the socket that has + ;; been closed, so we catch that here. + (false-if-exception + (let ((coop-repl (make-coop-repl))) + (make-thread reader-loop coop-server coop-repl) + (start-repl* (current-language) #f (make-coop-reader coop-repl))))) + +(define (run-coop-repl-server coop-server server-socket) + "Start the cooperative REPL server for COOP-SERVER using the socket +SERVER-SOCKET." + (run-server* server-socket (make-coop-client-proc coop-server))) + +(define* (spawn-coop-repl-server + #:optional (server-socket (make-tcp-server-socket))) + "Create and return a new cooperative REPL server object, and spawn a +new thread to listen for connections on SERVER-SOCKET. Proper +functioning of the REPL server requires that poll-coop-repl-server be +called periodically on the returned server object." + (let ((coop-server (make-coop-repl-server))) + (make-thread run-coop-repl-server + coop-server + server-socket) + coop-server)) + +(define (make-coop-client-proc coop-server) + "Return a new procedure that is used to schedule the creation of a new +cooperative REPL for COOP-SERVER." + (lambda (client addr) + (coop-repl-server-eval coop-server 'new-repl client))) + +(define (start-repl-client coop-server client) + "Run a cooperative REPL for COOP-SERVER within a prompt. All input +and output is sent over the socket CLIENT." + + ;; Add the client to the list of open sockets, with a 'force-close' + ;; procedure that closes the underlying file descriptor. We do it + ;; this way because we cannot close the port itself safely from + ;; another thread. + (add-open-socket! client (lambda () (close-fdes (fileno client)))) + + (with-continuation-barrier + (lambda () + (coop-repl-prompt + (lambda () + (parameterize ((current-input-port client) + (current-output-port client) + (current-error-port client) + (current-warning-port client)) + (with-fluids ((*repl-stack* '())) + (save-module-excursion + (lambda () + (start-coop-repl coop-server))))) + + ;; This may fail if 'stop-server-and-clients!' is called, + ;; because the 'force-close' procedure above closes the + ;; underlying file descriptor instead of the port itself. + (false-if-exception + (close-socket! client))))))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 16495560c..5b27125f1 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -1,6 +1,7 @@ ;;; Read-Eval-Print Loop -;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011, 2013, +;; 2014 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -107,6 +108,8 @@ ;; to be able to re-use the existing readline machinery. ;; ;; Catches read errors, returning *unspecified* in that case. +;; +;; Note: although not exported, this is used by (system repl coop-server) (define (prompting-meta-read repl) (catch #t (lambda () @@ -129,10 +132,14 @@ ;;; (define* (start-repl #:optional (lang (current-language)) #:key debug) + (start-repl* lang debug prompting-meta-read)) + +;; Note: although not exported, this is used by (system repl coop-server) +(define (start-repl* lang debug prompting-meta-read) ;; ,language at the REPL will update the current-language. Make ;; sure that it does so in a new dynamic scope. (parameterize ((current-language lang)) - (run-repl (make-repl lang debug)))) + (run-repl* (make-repl lang debug) prompting-meta-read))) ;; (put 'abort-on-error 'scheme-indent-function 1) (define-syntax-rule (abort-on-error string exp) @@ -144,6 +151,9 @@ (abort)))) (define (run-repl repl) + (run-repl* repl prompting-meta-read)) + +(define (run-repl* repl prompting-meta-read) (define (with-stack-and-prompt thunk) (call-with-prompt (default-prompt-tag) (lambda () (start-stack #t (thunk))) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index 4f3391c0b..ff9ee5cbc 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -22,34 +22,45 @@ (define-module (system repl server) #:use-module (system repl repl) #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (make-tcp-server-socket make-unix-domain-server-socket run-server spawn-server stop-server-and-clients!)) +;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a +;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down +;; the socket. (define *open-sockets* '()) (define sockets-lock (make-mutex)) +;; WARNING: it is unsafe to call 'close-socket!' from another thread. +;; Note: although not exported, this is used by (system repl coop-server) (define (close-socket! s) (with-mutex sockets-lock - (set! *open-sockets* (delq! s *open-sockets*))) + (set! *open-sockets* (assq-remove! *open-sockets* s))) ;; Close-port could block or raise an exception flushing buffered ;; output. Hmm. (close-port s)) -(define (add-open-socket! s) +;; Note: although not exported, this is used by (system repl coop-server) +(define (add-open-socket! s force-close) (with-mutex sockets-lock - (set! *open-sockets* (cons s *open-sockets*)))) + (set! *open-sockets* (acons s force-close *open-sockets*)))) (define (stop-server-and-clients!) (cond ((with-mutex sockets-lock - (and (pair? *open-sockets*) - (car *open-sockets*))) - => (lambda (s) - (close-socket! s) + (match *open-sockets* + (() #f) + (((s . force-close) . rest) + (set! *open-sockets* rest) + force-close))) + => (lambda (force-close) + (force-close) (stop-server-and-clients!))))) (define* (make-tcp-server-socket #:key @@ -67,37 +78,82 @@ (bind sock AF_UNIX path) sock)) +;; List of errno values from 'select' or 'accept' that should lead to a +;; retry in 'run-server'. +(define errs-to-retry + (delete-duplicates + (filter-map (lambda (name) + (and=> (module-variable the-root-module name) + variable-ref)) + '(EINTR EAGAIN EWOULDBLOCK)))) + (define* (run-server #:optional (server-socket (make-tcp-server-socket))) + (run-server* server-socket serve-client)) + +;; Note: although not exported, this is used by (system repl coop-server) +(define (run-server* server-socket serve-client) + ;; We use a pipe to notify the server when it should shut down. + (define shutdown-pipes (pipe)) + (define shutdown-read-pipe (car shutdown-pipes)) + (define shutdown-write-pipe (cdr shutdown-pipes)) + + ;; 'shutdown-server' is called by 'stop-server-and-clients!'. + (define (shutdown-server) + (display #\! shutdown-write-pipe) + (force-output shutdown-write-pipe)) + + (define monitored-ports + (list server-socket + shutdown-read-pipe)) + (define (accept-new-client) (catch #t - (lambda () (accept server-socket)) - (lambda (k . args) - (cond - ((port-closed? server-socket) - ;; Shutting down. - #f) - (else - (warn "Error accepting client" k args) - ;; Retry after a timeout. - (sleep 1) - (accept-new-client)))))) - + (lambda () + (let ((ready-ports (car (select monitored-ports '() '())))) + ;; If we've been asked to shut down, return #f. + (and (not (memq shutdown-read-pipe ready-ports)) + (accept server-socket)))) + (lambda k-args + (let ((err (system-error-errno k-args))) + (cond + ((memv err errs-to-retry) + (accept-new-client)) + (else + (warn "Error accepting client" k-args) + ;; Retry after a timeout. + (sleep 1) + (accept-new-client))))))) + + ;; Put the socket into non-blocking mode. + (fcntl server-socket F_SETFL + (logior O_NONBLOCK + (fcntl server-socket F_GETFL))) + (sigaction SIGPIPE SIG_IGN) - (add-open-socket! server-socket) + (add-open-socket! server-socket shutdown-server) (listen server-socket 5) (let lp ((client (accept-new-client))) ;; If client is false, we are shutting down. (if client (let ((client-socket (car client)) (client-addr (cdr client))) - (add-open-socket! client-socket) (make-thread serve-client client-socket client-addr) - (lp (accept-new-client)))))) + (lp (accept-new-client))) + (begin (close shutdown-write-pipe) + (close shutdown-read-pipe) + (close server-socket))))) (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) (make-thread run-server server-socket)) (define (serve-client client addr) + + (let ((thread (current-thread))) + ;; Close the socket when this thread exits, even if canceled. + (set-thread-cleanup! thread (lambda () (close-socket! client))) + ;; Arrange to cancel this thread to forcefully shut down the socket. + (add-open-socket! client (lambda () (cancel-thread thread)))) + (with-continuation-barrier (lambda () (parameterize ((current-input-port client) @@ -105,5 +161,4 @@ (current-error-port client) (current-warning-port client)) (with-fluids ((*repl-stack* '())) - (start-repl))))) - (close-socket! client)) + (start-repl)))))) |