From 1de341cf0652fb0eb8354f64d95acb0899811173 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Fri, 11 Apr 2003 20:13:00 +0000 Subject: [PATCH] 0.pre8.54 Assorted fixes ... add TAGS to .cvsignore (tonyms) ... delete unused variable in REPL (tonyms) ... 'WITH-' macrology for SB-GROVEL contrib, plus make-it-work fixes (Andreas Fuchs) ... set MAX_INTERRUPTS back to some reasonable value (dan) ... use modify_ldt, not __modify_ldt, which is glibc-internal and causes problems with RPM packaging (dan) --- .cvsignore | 2 +- contrib/sb-grovel/array-data.lisp | 72 +++++++++++++++++++++++++++++++++++ contrib/sb-grovel/foreign-glue.lisp | 13 ++++++- contrib/sb-grovel/sb-grovel.asd | 4 +- src/code/toplevel.lisp | 39 +++++++++---------- src/runtime/interrupt.h | 6 ++- src/runtime/x86-linux-os.c | 8 ++-- version.lisp-expr | 2 +- 8 files changed, 116 insertions(+), 30 deletions(-) create mode 100644 contrib/sb-grovel/array-data.lisp diff --git a/.cvsignore b/.cvsignore index cd87c38..ef3a9ef 100644 --- a/.cvsignore +++ b/.cvsignore @@ -4,4 +4,4 @@ ChangeLog customize-backend-subfeatures.lisp customize-target-features.lisp local-target-features.lisp-expr - +TAGS diff --git a/contrib/sb-grovel/array-data.lisp b/contrib/sb-grovel/array-data.lisp new file mode 100644 index 0000000..ad5aa4a --- /dev/null +++ b/contrib/sb-grovel/array-data.lisp @@ -0,0 +1,72 @@ +(in-package :sb-grovel) + +;;; borrowed from CMUCL manual, lightly ported + +(defun array-data-address (array) + "Return the physical address of where the actual data of an array is +stored. + +ARRAY must be a specialized array type - an array of one of these types: + + double-float + single-float + (unsigned-byte 32) + (unsigned-byte 16) + (unsigned-byte 8) + (signed-byte 32) + (signed-byte 16) + (signed-byte 8) +" + (declare (type (or (array (signed-byte 8)) + (array base-char) + simple-base-string + (array (signed-byte 16)) + (array (signed-byte 32)) + (array (unsigned-byte 8)) + (array (unsigned-byte 16)) + (array (unsigned-byte 32)) + (array single-float) + (array double-float)) + array) + (optimize (speed 0) (debug 3) (safety 3))) + ;; with-array-data will get us to the actual data. However, because + ;; the array could have been displaced, we need to know where the + ;; data starts. + + (let* ((type (car (multiple-value-list (array-element-type array)))) + (type-size + (cond ((or (equal type '(signed-byte 8)) + (equal type 'cl::base-char) + (equal type '(unsigned-byte 8))) + 1) + ((or (equal type '(signed-byte 16)) + (equal type '(unsigned-byte 16))) + 2) + ((or (equal type '(signed-byte 32)) + (equal type '(unsigned-byte 32))) + 4) + ((equal type 'single-float) + 4) + ((equal type 'double-float) + 8) + (t (error "Unknown specialized array element type"))))) + (sb-kernel::with-array-data ((data array) + (start) + (end)) + (declare (ignore end)) + ;; DATA is a specialized simple-array. Memory is laid out like this: + ;; + ;; byte offset Value + ;; 0 type code (e.g. 70 for double-float vector) + ;; 4 FIXNUMIZE(number of elements in vector) + ;; 8 1st element of vector + ;; ... ... + ;; + (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data))))) + (declare (type (unsigned-byte 32) addr) + (optimize (speed 3) (safety 0))) + (sb-sys:int-sap (the (unsigned-byte 32) + (+ addr (* type-size start)))))))) + + + diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index c74c333..b2c1f00 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -61,7 +61,18 @@ (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0 :element-type '(unsigned-byte 8))) (defconstant ,(p "SIZE-OF-") ,size) - (defun ,(p "FREE-" ) (p) (declare (ignore p)))))) + (defun ,(p "FREE-" ) (p) (declare (ignore p))) + (defmacro ,(p "WITH-") (var (&rest field-values) &body body) + (labels ((field-name (x) + (intern (concatenate 'string + (symbol-name ',name) "-" + (symbol-name x)) + ,(symbol-package name)))) + (append `(let ((,var ,'(,(p "ALLOCATE-"))))) + (mapcar (lambda (pair) + `(setf (,(field-name (car pair)) ,var) ,(cadr pair))) + field-values) + body)))))) (defun foreign-nullp (c) "C is a pointer to 0?" diff --git a/contrib/sb-grovel/sb-grovel.asd b/contrib/sb-grovel/sb-grovel.asd index 13d5a40..9f29c2b 100644 --- a/contrib/sb-grovel/sb-grovel.asd +++ b/contrib/sb-grovel/sb-grovel.asd @@ -6,7 +6,9 @@ (defsystem sb-grovel :version "0.01" :components ((:file "defpackage") - (:file "def-to-lisp" :depends-on ("defpackage")))) + (:file "def-to-lisp" :depends-on ("defpackage")) + (:file "foreign-glue" :depends-on ("defpackage")) + (:file "array-data" :depends-on ("defpackage")))) (defmethod perform ((o test-op) (c (eql (find-system :sb-grovel)))) t) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 4bb67ab..d779e57 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -542,27 +542,26 @@ (defun repl (noprint) (/show0 "entering REPL") - (let ((eof-marker (cons :eof nil))) - (loop - ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) - (scrub-control-stack) + (loop + ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) + (scrub-control-stack) + (unless noprint + (funcall *repl-prompt-fun* *standard-output*) + ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own + ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to + ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems + ;; odd. But maybe there *is* a valid reason in some + ;; circumstances? perhaps some deadlock issue when being driven + ;; by another process or something...) + (force-output *standard-output*)) + (let* ((form (funcall *repl-read-form-fun* + *standard-input* + *standard-output*)) + (results (multiple-value-list (interactive-eval form)))) (unless noprint - (funcall *repl-prompt-fun* *standard-output*) - ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own - ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to - ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems - ;; odd. But maybe there *is* a valid reason in some - ;; circumstances? perhaps some deadlock issue when being driven - ;; by another process or something...) - (force-output *standard-output*)) - (let* ((form (funcall *repl-read-form-fun* - *standard-input* - *standard-output*)) - (results (multiple-value-list (interactive-eval form)))) - (unless noprint - (dolist (result results) - (fresh-line) - (prin1 result))))))) + (dolist (result results) + (fresh-line) + (prin1 result)))))) ;;; suitable value for *DEBUGGER-HOOK* for a noninteractive Unix-y program (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook) diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h index 25d151f..0996471 100644 --- a/src/runtime/interrupt.h +++ b/src/runtime/interrupt.h @@ -18,8 +18,10 @@ * * Note: In CMU CL, this was 4096, but there was no explanation given, * and it's hard to see why we'd need that many nested interrupts, so - * I've scaled it back to see what happens. -- WHN 20000730 */ -#define MAX_INTERRUPTS 8 + * I've scaled it back (to 256) to see what happens. -- WHN 20000730 + + * Nothing happened, so let's creep it back a bit further -- dan 20030411 */ +#define MAX_INTERRUPTS 32 union interrupt_handler { lispobj lisp; diff --git a/src/runtime/x86-linux-os.c b/src/runtime/x86-linux-os.c index 460cc9c..140f0fd 100644 --- a/src/runtime/x86-linux-os.c +++ b/src/runtime/x86-linux-os.c @@ -56,7 +56,7 @@ u32 local_ldt_copy[LDT_ENTRIES*LDT_ENTRY_SIZE/sizeof(u32)]; void debug_get_ldt() { - int n=__modify_ldt (0, local_ldt_copy, sizeof local_ldt_copy); + int n=modify_ldt (0, local_ldt_copy, sizeof local_ldt_copy); printf("%d bytes in ldt: print/x local_ldt_copy\n", n); } @@ -71,7 +71,7 @@ int arch_os_thread_init(struct thread *thread) { 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1 }; /* get next free ldt entry */ - int n=__modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy); + int n=modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy); if(n) { u32 *p; for(n=0,p=local_ldt_copy;*p;p+=LDT_ENTRY_SIZE/sizeof(u32)) @@ -81,7 +81,7 @@ int arch_os_thread_init(struct thread *thread) { ldt_entry.base_addr=(unsigned long) thread; ldt_entry.limit=dynamic_values_bytes; ldt_entry.limit_in_pages=0; - if (__modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) + if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) /* modify_ldt call failed: something magical is not happening */ return -1; __asm__ __volatile__ ("movw %w0, %%fs" : : "q" @@ -130,7 +130,7 @@ int arch_os_thread_cleanup(struct thread *thread) { }; ldt_entry.entry_number=thread->tls_cookie; - if (__modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) + if (modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) /* modify_ldt call failed: something magical is not happening */ return 0; return 1; diff --git a/version.lisp-expr b/version.lisp-expr index 8ebadb7..2f33dff 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.53" +"0.pre8.54" -- 1.7.10.4