summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am4
-rw-r--r--module/ice-9/ftw.scm5
-rw-r--r--module/rnrs/io/simple.scm13
-rw-r--r--module/scripts/snarf-check-and-output-texi.scm15
-rw-r--r--module/srfi/srfi-18.scm8
-rw-r--r--module/srfi/srfi-19.scm9
-rw-r--r--module/system/base/types.scm529
-rw-r--r--module/system/repl/coop-server.scm193
-rw-r--r--module/system/repl/repl.scm14
-rw-r--r--module/system/repl/server.scm103
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))))))