customize-backend-subfeatures.lisp
customize-target-features.lisp
local-target-features.lisp-expr
-
+TAGS
--- /dev/null
+(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))))))))
+
+
+
(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?"
(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)
(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)
*
* 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;
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);
}
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))
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"
};
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;
;;; 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"
projects / sbcl.git / commitdiff