diff --git a/bootfiles/18d/boot4-cross-foreign-linkage.lisp b/bootfiles/18d/boot4-cross-foreign-linkage.lisp new file mode 100644 index 0000000000000000000000000000000000000000..9e59165c75c62a9443f5da22b7f69bca1dd83f22 --- /dev/null +++ b/bootfiles/18d/boot4-cross-foreign-linkage.lisp @@ -0,0 +1,291 @@ +;;; This script builds a cross compiler that can then build a new +;;; system with the linkage table changes. It works well with Pierre +;;; Mai's build scripts. + +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86") +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "X86" + ;; Features to add here + '(:x86 :i486 + :mp :gencgc + :conservative-float-type + :hash-new :random-mt19937 + :cmu :cmu18 :cmu18d +;; :freebsd :freebsd4 :elf + :linkage-table + :relative-package-names + ) + ;; Features to remove from current *features* here + '(:x86-bootstrap :alpha :osf1 :mips + :propagate-fun-type :propagate-float-type :constrain-float-type + :openbsd :pentium ;; :glibc2 :linux :freebsd + :long-float :new-random :small)) + +;;; So compilation of make-fixup will work. +(setf (get 'lisp::fop-foreign-data-fixup 'lisp::fop-code) 150) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) + +(load "target:tools/comcom") +(comf "target:code/foreign-linkage") + + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:x86/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/x86/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "target:code/foreign-linkage") +(load "target:compiler/dump") +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm)))) + syms)))) + (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS + #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-X86:SIMPLE-BIT-VECTOR-TYPE + OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE + OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET + )) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + #+(and bsd (not elf)) + (concatenate 'string "_" name) + #-(and bsd (not elf)) + name) +(export 'extern-alien-name) +(export 'fixup-code-object) +(export 'sanctify-for-execution) + +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-x86::any-reg ht) + (gethash 'x86::any-reg ht))) + +(in-package "ALIEN") + +(defun %def-alien-variable (lisp-name alien-name type) + (setf (info variable kind lisp-name) :alien) + (setf (info variable where-from lisp-name) :defined) + (clear-info variable constant-value lisp-name) + (setf (info variable alien-info lisp-name) + (make-heap-alien-info :type type + :sap-form `(foreign-symbol-address + ',alien-name :flavor :data)))) +(defmacro extern-alien (name type) + "Access the alien variable named NAME, assuming it is of type TYPE. This + is setfable." + (let* ((alien-name (etypecase name + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type)) + (flavor (if (alien-function-type-p alien-type) + :code + :data))) + `(%heap-alien ',(make-heap-alien-info + :type alien-type + :sap-form `(foreign-symbol-address ',alien-name + :flavor ',flavor))))) + +(defmacro with-alien (bindings &body body) + "Establish some local alien variables. Each BINDING is of the form: + VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ] + ALLOCATION should be one of: + :LOCAL (the default) + The alien is allocated on the stack, and has dynamic extent. + :STATIC + The alien is allocated on the heap, and has infinate extent. The alien + is allocated at load time, so the same piece of memory is used each time + this form executes. + :EXTERN + No alien is allocated, but VAR is established as a local name for + the external alien given by EXTERNAL-NAME." + (with-auxiliary-alien-types + (dolist (binding (reverse bindings)) + (destructuring-bind + (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + binding + (let* ((alien-type (parse-alien-type type)) + (flavor (if (alien-function-type-p alien-type) + :code + :data))) + (multiple-value-bind + (allocation initial-value) + (if opt2p + (values opt1 opt2) + (case opt1 + (:extern + (values opt1 (guess-alien-name-from-lisp-name symbol))) + (:static + (values opt1 nil)) + (t + (values :local opt1)))) + (setf body + (ecase allocation + #+nil + (:static + (let ((sap + (make-symbol (concatenate 'string "SAP-FOR-" + (symbol-name symbol))))) + `((let ((,sap (load-time-value (%make-alien ...)))) + (declare (type system-area-pointer ,sap)) + (symbol-macrolet + ((,symbol (sap-alien ,sap ,type))) + ,@(when initial-value + `((setq ,symbol ,initial-value))) + ,@body))))) + (:extern + (let ((info (make-heap-alien-info + :type alien-type + :sap-form `(foreign-symbol-address + ',initial-value + :flavor ',flavor)))) + `((symbol-macrolet + ((,symbol (%heap-alien ',info))) + ,@body)))) + (:local + (let ((var (gensym)) + (initval (if initial-value (gensym))) + (info (make-local-alien-info + :type alien-type))) + `((let ((,var (make-local-alien ',info)) + ,@(when initial-value + `((,initval ,initial-value)))) + (note-local-alien-type ',info ,var) + (multiple-value-prog1 + (symbol-macrolet + ((,symbol (local-alien ',info ,var))) + ,@(when initial-value + `((setq ,symbol ,initval))) + ,@body) + (dispose-local-alien ',info ,var) + ))))))))))) + (verify-local-auxiliaries-okay) + `(compiler-let ((*auxiliary-type-definitions* + ',(append *new-auxiliary-types* + *auxiliary-type-definitions*))) + ,@body))) + diff --git a/code/alieneval.lisp b/code/alieneval.lisp index f3528ff27283b2b8ffe7ec972f6031a29165bddf..29d792c9809bc481c1d56774c8dcda13d6cf9df7 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.51 2001/06/01 12:49:39 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.52 2002/08/27 22:18:23 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1357,19 +1357,24 @@ (setf (info variable alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-address - ',alien-name)))) + ',alien-name :flavor :data)))) ;;; EXTERN-ALIEN -- public. ;;; (defmacro extern-alien (name type) "Access the alien variable named NAME, assuming it is of type TYPE. This is setfable." - (let ((alien-name (etypecase name - (symbol (guess-alien-name-from-lisp-name name)) - (string name)))) + (let* ((alien-name (etypecase name + (symbol (guess-alien-name-from-lisp-name name)) + (string name))) + (alien-type (parse-alien-type type)) + (flavor (if (alien-function-type-p alien-type) + :code + :data))) `(%heap-alien ',(make-heap-alien-info - :type (parse-alien-type type) - :sap-form `(foreign-symbol-address ',alien-name))))) + :type alien-type + :sap-form `(foreign-symbol-address ',alien-name + :flavor ',flavor))))) ;;; WITH-ALIEN -- public. ;;; @@ -1391,7 +1396,10 @@ (destructuring-bind (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding - (let ((alien-type (parse-alien-type type))) + (let* ((alien-type (parse-alien-type type)) + (flavor (if (alien-function-type-p alien-type) + :code + :data))) (multiple-value-bind (allocation initial-value) (if opt2p @@ -1421,7 +1429,8 @@ (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address - ',initial-value)))) + ',initial-value + :flavor ',flavor)))) `((symbol-macrolet ((,symbol (%heap-alien ',info))) ,@body)))) diff --git a/code/debug-int.lisp b/code/debug-int.lisp index e1f1af4e3d8d26776ff4fbb8ba0a2aed8af299ee..43e4d1b943f93b774fdfda70ce847cc83eb39728 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.100 2001/03/04 20:12:31 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.101 2002/08/27 22:18:23 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -4342,11 +4342,14 @@ the PC offset for the trap instruction." (system:without-gcing (let* ((src-start (system:foreign-symbol-address - "function_end_breakpoint_guts")) + "function_end_breakpoint_guts" + :flavor :data)) (src-end (system:foreign-symbol-address - "function_end_breakpoint_end")) + "function_end_breakpoint_end" + :flavor :data)) (trap-loc (system:foreign-symbol-address - "function_end_breakpoint_trap")) + "function_end_breakpoint_trap" + :flavor :data)) (length (system:sap- src-end src-start)) (code-object (system:%primitive diff --git a/code/exports.lisp b/code/exports.lisp index 65a2e84eb718a98e0f56dfac17e97b9985030155..136ecb3cd02e574b7d149c641764d1a579589208 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.193 2002/08/26 20:45:03 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.194 2002/08/27 22:18:24 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -777,6 +777,8 @@ "TARGET-BINDING-STACK-START" "TARGET-BYTE-ORDER" "TARGET-CONTROL-STACK-START" "TARGET-DYNAMIC-SPACE-START" "TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE" + "TARGET-FOREIGN-LINKAGE-ENTRY-SIZE" + "TARGET-FOREIGN-LINKAGE-SPACE-START" "TARGET-HEAP-ADDRESS-SPACE" "TARGET-MOST-NEGATIVE-FIXNUM" "TARGET-MOST-POSITIVE-FIXNUM" "TARGET-READ-ONLY-SPACE-START" "TARGET-STATIC-SPACE-START" "TRACE-TABLE-CALL-SITE" @@ -1099,6 +1101,11 @@ "%SVSET" "%TYPEP" "SHORT-FLOAT-P" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*")) (intern name "LISP")) +(dolist + (name + '("FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" + "FOREIGN-SYMBOL-DATA-ADDRESS")) + (intern name "SYSTEM")) (defpackage "C" (:nicknames "COMPILER") @@ -1111,6 +1118,8 @@ "%SVSET" "%TYPEP" "SHORT-FLOAT-P" "STRING/=*" "STRING<*" "STRING<=*" "STRING=*" "STRING>*" "STRING>=*") + (:import-from "SYSTEM" "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-CODE-ADDRESS" + "FOREIGN-SYMBOL-DATA-ADDRESS") (:export "%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" @@ -1156,7 +1165,9 @@ "FASL-FILE-IMPLEMENTATIONS" "FAST-SAFE-COERCE-TO-FUNCTION" "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FLUSHABLE" "FOLDABLE" - "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" "GET-VECTOR-SUBTYPE" + "FORCE-TN-TO-STACK" "FOREIGN-SYMBOL-ADDRESS" + "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" + "GET-VECTOR-SUBTYPE" "HALT" "IF-EQ" "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL" "KNOWN-RETURN" @@ -1284,6 +1295,7 @@ "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DOUBLE-FLOAT-RADIX" "ENABLE-INTERRUPT" "ENUMERATION" "FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS" + "FOREIGN-SYMBOL-CODE-ADDRESS" "FOREIGN-SYMBOL-DATA-ADDRESS" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" diff --git a/code/foreign-linkage.lisp b/code/foreign-linkage.lisp new file mode 100644 index 0000000000000000000000000000000000000000..c763e1f3c6a1a87c0eb60d444a880755c0b0b227 --- /dev/null +++ b/code/foreign-linkage.lisp @@ -0,0 +1,85 @@ +(in-package "LISP") + +;;; This gets created by genesis and lives in the static area. +(defvar *linkage-table-data*) + +;;; Key is symbol name, value is index into *linkage-table-data* +(defvar *foreign-linkage-symbols* (make-hash-table :test #'equal)) + +;;; Very unlispy layout of the *linkage-table-data*: +;;; symbol name +;;; type - a fixnum, 1 = code, 2 = data +;;; library list - the library list at the time the symbol is registered. + +(defconstant +linkage-data-entry-size+ 3) + +(defun add-linkage-data (symbol-name type table loaded-libs) + (let ((sym-type (ecase type + (:code 1) + (:data 2))) + (entry-num (/ (fill-pointer table) +linkage-data-entry-size+))) + (vector-push-extend symbol-name table) + (vector-push-extend sym-type table) + (vector-push-extend loaded-libs table) + entry-num)) + +(defun foreign-linkage-entry (entry-num) + (let ((index (* entry-num +linkage-data-entry-size+))) + (values (aref *linkage-table-data* index) + (ecase (aref *linkage-table-data* (1+ index)) + (1 :code) + (2 :data)) + (aref *linkage-table-data* (+ index 2))))) + +(defun foreign-linkage-symbols () + (/ (length *linkage-table-data*) +linkage-data-entry-size+)) + +(defun add-foreign-linkage (symbol-name type table linkage-hash + make-linkage-stub-p) + (let ((entry-num (add-linkage-data symbol-name + type + table + (if make-linkage-stub-p + system::*global-table* + nil)))) + (when make-linkage-stub-p + #-building-cross-compiler + (let ((result (alien:alien-funcall (alien:extern-alien + "os_link_one_symbol" + (alien:function c-call:int + c-call:long)) + entry-num))) + (when (zerop result) + (error "~A is not defined as a foreign symbol" + symbol-name)))) + (setf (gethash symbol-name linkage-hash) entry-num) + entry-num)) + +;;; Add a foreign linkage entry if none exists. +;;; +;;; If a linkage table is passed in it's assumed this is genesis and +;;; we don't want to make an actual stub or entry in the table space. +(defun register-foreign-linkage (symbol-name type + &optional + (table *linkage-table-data* tablep) + (linkage-hash *foreign-linkage-symbols*)) + (let ((entry-num (gethash symbol-name linkage-hash))) + (if entry-num + entry-num + (add-foreign-linkage symbol-name + type table + linkage-hash + (not tablep))))) + +;;; At world build time, build the linkage hash table + +(defun foreign-linkage-init () + ;; Sigh, would like to use LENGTH instead of FILL-POINTER but it's + ;; not generic enough during the init process! + ;; XXX I'm not sure that comment is true... + (loop for i from 0 below (/ (fill-pointer *linkage-table-data*) + +linkage-data-entry-size+) + do (setf (gethash (aref *linkage-table-data* + (* i +linkage-data-entry-size+)) + *foreign-linkage-symbols*) + i))) diff --git a/code/foreign.lisp b/code/foreign.lisp index f59cf2778c19e59f419894543fa57b0f6c028a6d..0468d22d6395e739310d8babfe8cb1224aef6dd5 100644 --- a/code/foreign.lisp +++ b/code/foreign.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.40 2002/05/06 18:02:04 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.41 2002/08/27 22:18:24 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -513,7 +513,7 @@ to skip undefined symbols which don't have an address." "path:") #+hpux "library:cmucl.orig") (env ext:*environment-list*) - (verbose *load-verbose*)) + (verbose *load-verbose*)) "Load-foreign loads a list of C object files into a running Lisp. The files argument should be a single file or a list of files. The files may be specified as namestrings or as pathnames. The libraries argument should be a @@ -616,6 +616,7 @@ to skip undefined symbols which don't have an address." ;;; save--this is primarily for irix, which resolves tzname at ;;; runtime, resulting in *global-table* being set in the saved core ;;; image, resulting in havoc upon restart. +#-linkage-table (pushnew #'(lambda () (setq *global-table* nil)) ext:*after-save-initializations*) @@ -650,10 +651,39 @@ to skip undefined symbols which don't have an address." (ensure-lisp-table-opened) ; rtld global: so it can find all the symbols previously loaded ; rtld now: that way dlopen will fail if not all symbols are defined. - (let ((sap (dlopen file (logior rtld-now rtld-global)))) - (if (zerop (sap-int sap)) - (error "Can't open object ~S: ~S" file (dlerror)) - (pushnew sap *global-table* :test #'sap=)))) + (let* ((filename (namestring file )) + (sap (dlopen filename (logior rtld-now rtld-global)))) + (cond ((zerop (sap-int sap)) + (error "Can't open object ~S: ~S" file (dlerror))) + ((null (assoc sap *global-table* :test #'sap=)) + (setf *global-table* (acons sap file *global-table*))) + (t nil)))) + +;;; Clear close all dlopened libraries and clear out the entries in +;;; *global-table*, prior to doing a save-lisp. + +(defun close-global-table () + (loop for lib-entry in *global-table* + for (sap) = lib-entry + do (progn + (dlclose sap) + ;; Probably not necessary, but neater than leaving around + ;; stale handles in the saved image. + (setf (car lib-entry) (int-sap 0))))) + +;;; Open all the libraries in *global-table* +(defun reinitialize-global-table () + (loop for lib-entry in *global-table* + for (sap . lib-path) = lib-entry + for new-sap = (dlopen (namestring lib-path) + (logior rtld-now rtld-global)) + do (progn + (when (zerop (sap-int new-sap)) + ;; We're going down + (error "Couldn't open library ~S: ~S" lib-path (dlerror))) + (setf (car lib-entry) new-sap))) + (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage" + (alien:function c-call:void)))) (defun alternate-get-global-address (symbol) (ensure-lisp-table-opened) @@ -686,7 +716,7 @@ to skip undefined symbols which don't have an address." (let ((output-file (pick-temporary-file-name (concatenate 'string "/tmp/~D~C" (string (gensym))))) (error-output (make-string-output-stream))) - + (when verbose (format t ";;; Running ~A...~%" *dso-linker*) (force-output)) diff --git a/code/gc.lisp b/code/gc.lisp index 7c6484635ee541ab2b696f8d9d8bff2e31bda11a..5db8ffd1b75cb334b80190d2ee2f646ae19d6ea2 100644 --- a/code/gc.lisp +++ b/code/gc.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.26 2001/04/10 13:42:44 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.27 2002/08/27 22:18:24 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -487,3 +487,41 @@ (if (< *gc-trigger* (dynamic-usage)) (sub-gc) (set-auto-gc-trigger *gc-trigger*)))) + +;;; setters and accessors for gencgc parameters + +#+gencgc(eval-when (load eval) +(alien:def-alien-type nil + (alien:struct generation-stats + (bytes-allocated c-call:int) + (gc-trigger c-call:int) + (bytes-consed-between-gc c-call:int) + (num-gc c-call:int) + (trigger-age c-call:int) + (cum-sum-bytes-allocated c-call:int) + (min-av-mem-age c-call:double))) + +(defun gencgc-stats (generation) + (alien:with-alien ((stats (alien:struct generation-stats))) + (alien:alien-funcall (alien:extern-alien "get_generation_stats" + (function c-call:void + c-call:int + (* (alien:struct + generation-stats)))) + generation + (alien:addr stats)) + (values (alien:slot stats 'bytes-allocated) + (alien:slot stats 'gc-trigger) + (alien:slot stats 'bytes-consed-between-gc) + (alien:slot stats 'num-gc) + (alien:slot stats 'trigger-age) + (alien:slot stats 'cum-sum-bytes-allocated) + (alien:slot stats 'min-av-mem-age)))) + +(alien:def-alien-routine set-gc-trigger c-call:void + (gen c-call:int) (trigger c-call:int)) +(alien:def-alien-routine set-trigger-age c-call:void + (gen c-call:int) (trigger-age c-call:int)) +(alien:def-alien-routine set-min-mem-age c-call:void + (gen c-call:int) (min-mem-age c-call:double)) +) diff --git a/code/load.lisp b/code/load.lisp index 229081f9a2a5a26b5dee4f7da2e159618818135e..dd224757c36ec5570ae8321262241c21ce1b25c9 100644 --- a/code/load.lisp +++ b/code/load.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.83 2002/04/07 00:14:12 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.84 2002/08/27 22:18:24 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1340,9 +1340,12 @@ (dolist (symbol *initial-foreign-symbols*) (setf (gethash (car symbol) *foreign-symbols*) (cdr symbol))) (makunbound '*initial-assembler-routines*) - (makunbound '*initial-foreign-symbols*)) + (makunbound '*initial-foreign-symbols*) + (foreign-linkage-init)) -(defun foreign-symbol-address-aux (symbol) +#-linkage-table +(defun foreign-symbol-address-aux (symbol flavor) + (declare (ignore flavor)) (multiple-value-bind (value found) (gethash symbol *foreign-symbols* 0) @@ -1356,8 +1359,13 @@ (error "Unknown foreign symbol: ~S" symbol)) value)))) -(defun foreign-symbol-address (symbol) - (int-sap (foreign-symbol-address-aux (vm:extern-alien-name symbol)))) +(defun foreign-symbol-address (symbol &key (flavor :code)) + (let ((maybe-link-table-addr + (foreign-symbol-address-aux (vm:extern-alien-name symbol) flavor))) + (if (or #-linkage-table t (eq flavor :code)) + (int-sap maybe-link-table-addr) + ;;; Get address out of linkage table + (int-sap (sap-ref-32 maybe-link-table-addr 0))))) (define-fop (fop-foreign-fixup 147) (let* ((kind (pop-stack)) @@ -1366,7 +1374,18 @@ (sym (make-string len))) (read-n-bytes *fasl-file* sym 0 len) (vm:fixup-code-object code-object (read-arg 4) - (foreign-symbol-address-aux sym) + (foreign-symbol-address-aux sym :code) + kind) + code-object)) + +(define-fop (fop-foreign-data-fixup 150) + (let* ((kind (pop-stack)) + (code-object (pop-stack)) + (len (read-arg 1)) + (sym (make-string len))) + (read-n-bytes *fasl-file* sym 0 len) + (vm:fixup-code-object code-object (read-arg 4) + (foreign-symbol-address-aux sym :data) kind) code-object)) diff --git a/code/unix.lisp b/code/unix.lisp index 6222a5cfcb093e94f30ad3bc92f385c63183bd69..4edbc55de29145bfc8a5450a7d3caacffae9b65a 100644 --- a/code/unix.lisp +++ b/code/unix.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.75 2002/08/24 01:59:37 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.76 2002/08/27 22:18:25 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1962,7 +1962,9 @@ #+irix (declaim (notinline fakeout-compiler)) #+irix (defun fakeout-compiler (name dst) (unless unix-tzname-addr - (setf unix-tzname-addr (system:foreign-symbol-address name))) + (setf unix-tzname-addr (system:foreign-symbol-address + name + :flavor :data))) (deref (sap-alien unix-tzname-addr (array c-string 2)) dst)) (def-alien-routine get-timezone c-call:void (when c-call:long :in) diff --git a/code/x86-vm.lisp b/code/x86-vm.lisp index 2dbd6f30a86b0e548dc869bb1418a0b1deccac25..4ef5a575ea24c53de2e3cfd911e76f75e194a520 100644 --- a/code/x86-vm.lisp +++ b/code/x86-vm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.20 2002/05/06 18:02:05 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/x86-vm.lisp,v 1.21 2002/08/27 22:18:25 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -218,7 +218,7 @@ ;;; ;;; Counter to measure the storage overhead. (defvar *num-fixups* 0) -;;; +;;; XXX (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (flet ((add-fixup (code offset) @@ -478,8 +478,9 @@ #-(and bsd (not elf)) name) -#+(or linux (and freebsd elf)) -(defun lisp::foreign-symbol-address-aux (name) +#+(and (or linux (and freebsd elf)) (not linkage-table)) +(defun lisp::foreign-symbol-address-aux (name flavor) + (declare (ignore flavor)) (multiple-value-bind (value found) (gethash name lisp::*foreign-symbols* 0) (if found @@ -495,6 +496,7 @@ (error "Unknown foreign symbol: ~S" name)) value)))))) + ;;; SANCTIFY-FOR-EXECUTION -- Interface. ;;; @@ -657,3 +659,19 @@ ,n-vect ,n-index ,old-list ,new-list) ,old-list) (return ,new-list)))))))) + +#+linkage-table +(progn +(defun lisp::foreign-symbol-address-aux (name flavor) + (let ((entry-num (lisp::register-foreign-linkage name flavor))) + (+ #.vm:target-foreign-linkage-space-start + (* entry-num vm:target-foreign-linkage-entry-size)))) + +(defun lisp::find-foreign-symbol (addr) + (declare (type (unsigned-byte 32) addr)) + (when (>= addr vm:target-foreign-linkage-space-start) + (let ((entry (/ (- addr vm:target-foreign-linkage-space-start) + vm:target-foreign-linkage-entry-size))) + (when (< entry (lisp::foreign-linkage-symbols)) + (lisp::foreign-linkage-entry entry))))) +) diff --git a/compiler/debug.lisp b/compiler/debug.lisp index 9deb6ae6511861d3d21844345a094de9f0e3c934..1184730fbeff53f5e820c47b8da1cd83fd610830 100644 --- a/compiler/debug.lisp +++ b/compiler/debug.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.33 2002/01/11 16:26:29 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.34 2002/08/27 22:18:26 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -978,13 +978,15 @@ (declaim (fixnum ,counter)) (defun ,fto (x) - (or (gethash x ,vto) - (let ((num (incf ,counter))) - (setf (gethash num ,vfrom) x) - (setf (gethash x ,vto) num)))) - + (if (boundp ',vto) + (or (gethash x ,vto) + (let ((num (incf ,counter))) + (setf (gethash num ,vfrom) x) + (setf (gethash x ,vto) num))) + "???")) ;Silly placeholder value (defun ,ffrom (num) - (values (gethash num ,vfrom)))))) + (when (boundp ',vfrom) + (values (gethash num ,vfrom))))))) (frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont) diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp index 461349bc46d60dcec5d819f90c0cbb14541bf1af..09f00f217c04d5cfceadac76d402201b9a67cb66 100644 --- a/compiler/disassem.lisp +++ b/compiler/disassem.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.31 2001/06/25 16:47:31 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.32 2002/08/27 22:18:26 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -3671,7 +3671,9 @@ symbol object that we know about.") (declare (type disassem-state dstate)) (unless (typep address 'address) (return-from maybe-note-assembler-routine nil)) - (let ((name (find-assembler-routine address))) + (let ((name (#+linkage-table lisp::find-foreign-symbol + #-linkage-table find-assembler-routine + address))) (unless (null name) (note #'(lambda (stream) (if NOTE-ADDRESS-P diff --git a/compiler/dump.lisp b/compiler/dump.lisp index d87e6ea91132d3687a37f687a0f5e85eb5b58c90..fddd7e225dc8fd62d03861e0b604bfdef6b8c725 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.75 2002/04/07 00:14:13 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.76 2002/08/27 22:18:26 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -278,6 +278,32 @@ (dump-fop 'lisp::fop-pop file) (incf (fasl-file-table-free file)))) +;;; circular-cons-p -- Internal +;;; +;;; Test for the kind of circularities that would cause equal not to +;;; return, but allow other kinds of shared structure. + +(defun circular-cons-p (obj) + (unless (consp obj) + (return-from circular-cons-p nil)) + (let ((circ-hash (make-hash-table :test #'eq))) + (labels ((circular-cons-p-aux (obj top-level) + (do* ((sublist obj (cdr sublist))) + ((not (consp sublist)) + nil) + (let ((car-list (car sublist))) + (when (gethash sublist circ-hash) + (return-from circular-cons-p t)) + (setf (gethash sublist circ-hash) t) + (when (consp car-list) + (circular-cons-p-aux car-list nil)))) + (when (not top-level) + (do ((sublist obj (cdr sublist))) + ((not (consp sublist)) + nil) + (remhash sublist circ-hash))) + nil)) + (circular-cons-p-aux obj t)))) ;;; EQUAL-CHECK-TABLE -- Internal ;;; @@ -587,9 +613,11 @@ (dump-object name file)) (dump-fop 'lisp::fop-maybe-cold-load file) (dump-fop 'lisp::fop-assembler-fixup file)) - (:foreign + ((:foreign :foreign-data) (assert (stringp name)) - (dump-fop 'lisp::fop-foreign-fixup file) + (if (eq flavor :foreign) + (dump-fop 'lisp::fop-foreign-fixup file) + (dump-fop 'lisp::fop-foreign-data-fixup file)) (let ((len (length name))) (assert (< len 256)) (dump-byte len file) @@ -869,7 +897,7 @@ (typecase x (symbol (dump-symbol x file)) (list - (cond (*coalesce-constants* + (cond (*coalesce-constants* ;(and (not (circular-cons-p x))) (unless (equal-check-table x file) (dump-list x file) (equal-save-object x file))) diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp index 0ab0fba1f4de3336d32fa59c7aac29f82b56f012..937a537bdd753cb050dc88e49a3b1f870ada208c 100644 --- a/compiler/generic/core.lisp +++ b/compiler/generic/core.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.39 1999/02/25 13:03:12 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.40 2002/08/27 22:18:27 moore Rel $") ;;; ;;; ********************************************************************** ;;; @@ -93,9 +93,13 @@ (:assembly-routine (assert (symbolp name)) (gethash name lisp::*assembler-routines*)) - (:foreign + ((:foreign :foreign-data) (assert (stringp name)) - (let ((val (lisp::foreign-symbol-address-aux name))) + (let ((val (lisp::foreign-symbol-address-aux name + (if (eq flavor + :foreign) + :code + :data)))) ;; Foreign-symbol-address-aux always signals exactly ;; the same error we would if the symbol isn't found (values val t))) diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp index 0af78fdcad97385dc8883fead8d37da22cfb65d3..7b0b4fe3cd0dc08bc8abef83b2d76b64a156179a 100644 --- a/compiler/generic/interr.lisp +++ b/compiler/generic/interr.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.10 1998/07/24 17:22:30 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.11 2002/08/27 22:18:27 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -184,4 +184,6 @@ (nil-function-returned "Function with declared result type NIL returned.") (layout-invalid - "Layout is invalid (instance obsolete.)")) + "Layout is invalid (instance obsolete.)") + (undefined-foreign-symbol + "No value for foreign symbol.")) diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 311dabbd2258125e7504839be2c253beb6c4f5cd..b3dc359a20e57cfab8dd529bdb5c413101c79a34 100644 --- a/compiler/generic/new-genesis.lisp +++ b/compiler/generic/new-genesis.lisp @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.47 2002/08/23 17:01:00 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.48 2002/08/27 22:18:27 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -29,6 +29,9 @@ (defvar *read-only* nil) (defparameter read-only-space-id 3) +(defvar *foreign-linkage* nil) +(defparameter foreign-linkage-space-id 4) + (defmacro round-up (num size) "Rounds number up to be an integral multiple of size." (let ((size-var (gensym))) @@ -114,7 +117,7 @@ (truncate address space-alignment) (declare (ignore ignore)) (unless (zerop remainder) - (error "The address #x~X is not aligned on a #x~X boundry." + (error "The address #x~X is not aligned on a #x~X boundary." address space-alignment))) (let* ((actual-size (round-up initial-size (c:backend-page-size c:*backend*))) @@ -714,7 +717,8 @@ (frob *batch-mode* (cold-intern nil)) (frob *initial-layouts* (list-all-layouts)) - + #+linkage-table + (frob system::*global-table* (cold-intern nil)) (let ((res *nil-descriptor*)) (dolist (cpkg *cold-packages*) (let* ((pkg (car cpkg)) @@ -1366,6 +1370,42 @@ (make-fixnum-descriptor total-elements))) result)) +(defun make-cold-linkage-vector (vec) + (let* ((result (allocate-boxed-object *dynamic* + (+ vm:array-dimensions-offset 1) + vm:other-pointer-type)) + (vec-length (length vec)) + (data-vec (allocate-vector-object *dynamic* + vm:word-bits + vec-length + vm:simple-vector-type))) + (loop for i from 0 below vec-length + for vec-elem = (aref vec i) + do (write-indexed data-vec (+ i vm:vector-data-offset) + (etypecase vec-elem + (string + (string-to-core vec-elem)) + (number + (number-to-core vec-elem)) + (null + *nil-descriptor*)))) + (write-memory result + (make-other-immediate-descriptor vm:array-dimensions-offset + vm:complex-vector-type)) + (write-indexed result vm:array-elements-slot (number-to-core vec-length)) + (write-indexed result vm:array-displacement-slot (number-to-core 0)) + (write-indexed result vm:array-displaced-p-slot *nil-descriptor*) + (write-indexed result vm:array-data-slot data-vec) + (write-indexed result + vm:array-fill-pointer-slot + (number-to-core vec-length)) + (write-indexed result vm:array-fill-pointer-p-slot (cold-intern t)) + (write-indexed result + vm:array-dimensions-offset + (number-to-core vec-length)) + result)) + + ;;; Loading numbers. (defmacro cold-number (fop) @@ -1699,7 +1739,22 @@ (sym (make-string len))) (read-n-bytes *fasl-file* sym 0 len) (let ((offset (read-arg 4)) - (value (lookup-foreign-symbol sym))) + (value #+linkage-table (cold-register-foreign-linkage sym :code) + #-linkage-table (lookup-maybe-prefix-foreign-symbol sym))) + (do-cold-fixup code-object offset value kind)) + code-object)) + +;;; Should we do something for this in the non linkage table case, or should we +;;; count on not emitting them at all? + +(define-cold-fop (fop-foreign-data-fixup) + (let* ((kind (pop-stack)) + (code-object (pop-stack)) + (len (read-arg 1)) + (sym (make-string len))) + (read-n-bytes *fasl-file* sym 0 len) + (let ((offset (read-arg 4)) + (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) code-object)) @@ -1812,43 +1867,45 @@ version))) (defun lookup-foreign-symbol (name) - (let ((linux-p (and (eq (c:backend-fasl-file-implementation c:*backend*) - #.c:x86-fasl-file-implementation) - (c:backend-featurep :linux))) - (bsd-p (and (eq (c:backend-fasl-file-implementation c:*backend*) + (flet ((lookup-sym (name) + #-linkage-table + (gethash name *cold-foreign-symbol-table* nil) + #+linkage-table + (cold-register-foreign-linkage name :code))) + (let ((linux-p (and (eq (c:backend-fasl-file-implementation c:*backend*) #.c:x86-fasl-file-implementation) - (c:backend-featurep :bsd))) - (bsd-elf-p (and (eq (c:backend-fasl-file-implementation c:*backend*) - #.c:x86-fasl-file-implementation) - (c:backend-featurep :bsd) - (c:backend-featurep :elf))) - (freebsd4-p (and (eq (c:backend-fasl-file-implementation c:*backend*) - #.c:x86-fasl-file-implementation) - (c:backend-featurep :freebsd4)))) - (cond - ((and bsd-p (not bsd-elf-p) - (gethash (concatenate 'string "_" name) - *cold-foreign-symbol-table* nil))) - ((and (or linux-p freebsd4-p) - (gethash (concatenate 'string "PVE_stub_" name) - *cold-foreign-symbol-table* nil))) - ;; Non-linux case - (#-irix - (gethash name *cold-foreign-symbol-table* nil) - #+irix - (let ((value (gethash name *cold-foreign-symbol-table* nil))) - (when (and (numberp value) (zerop value)) - (warn "Not-really-defined foreign symbol: ~S" name)) - value)) - ((and linux-p (gethash (concatenate 'string "__libc_" name) - *cold-foreign-symbol-table* nil))) - ((and linux-p (gethash (concatenate 'string "__" name) - *cold-foreign-symbol-table* nil))) - ((and linux-p (gethash (concatenate 'string "_" name) - *cold-foreign-symbol-table* nil))) - (t - (warn "Undefined foreign symbol: ~S" name) - 0)))) + (c:backend-featurep :linux))) + (bsd-p (and (eq (c:backend-fasl-file-implementation c:*backend*) + #.c:x86-fasl-file-implementation) + (c:backend-featurep :bsd))) + (bsd-elf-p (and (eq (c:backend-fasl-file-implementation c:*backend*) + #.c:x86-fasl-file-implementation) + (c:backend-featurep :bsd) + (c:backend-featurep :elf))) + (freebsd4-p (and (eq (c:backend-fasl-file-implementation c:*backend*) + #.c:x86-fasl-file-implementation) + (c:backend-featurep :freebsd4)))) + (cond + ((and bsd-p (not bsd-elf-p) + (lookup-sym (concatenate 'string "_" name)))) + ((and #+linkage-table nil + (or linux-p freebsd4-p) + (lookup-sym (concatenate 'string "PVE_stub_" name)))) + ;; Non-linux case + (#-irix + (lookup-sym name) + #+irix + (let ((value (lookup-sym name))) + (when (and (numberp value) (zerop value)) + (warn "Not-really-defined foreign symbol: ~S" name)) + value)) + ((and linux-p (lookup-sym (concatenate 'string "__libc_" name)))) + ((and linux-p (lookup-sym (concatenate 'string "__" name)))) + ((and linux-p (lookup-sym (concatenate 'string "_" name)))) + (t + (warn "Undefined foreign symbol: ~S" name) + 0))))) + ;; FreeBSD wants C language symbols prefixed with "_" including all the ;; syscalls and Unix library things. Linux doesn't or maybe does @@ -1882,6 +1939,24 @@ ) name))) +(defvar *cold-linkage-table* (make-array 8192 :adjustable t :fill-pointer 0)) +(defvar *cold-foreign-hash* (make-hash-table :test #'equal)) + + +(defun cold-register-foreign-linkage (sym type) + (let ((entry-num (register-foreign-linkage sym + type + *cold-linkage-table* + *cold-foreign-hash*))) + (+ vm:target-foreign-linkage-space-start + (* entry-num vm:target-foreign-linkage-entry-size)))) + +(defun init-foreign-linkage () + (setf (fill-pointer *cold-linkage-table*) 0) + (clrhash *cold-foreign-hash*) + ;; This has gotta be the first entry. + (cold-register-foreign-linkage "resolve_linkage_tramp" :code)) + (defvar *cold-assembler-routines* nil) (defvar *cold-assembler-fixups* nil) @@ -2126,7 +2201,9 @@ (cold-intern (car rtn)) (number-to-core (cdr rtn))) result)) - (cold-setq (cold-intern '*initial-assembler-routines*) result))) + (cold-setq (cold-intern '*initial-assembler-routines*) result)) + (cold-setq (cold-intern '*linkage-table-data*) + (make-cold-linkage-vector *cold-linkage-table*))) @@ -2314,7 +2391,7 @@ (header-name *genesis-c-header-name*)) "Builds a kernel Lisp image from the .FASL files specified in the given File-List and writes it to a file named by Core-Name." - (unless symbol-table + (unless (or #+linkage-table t symbol-table) (error "Can't genesis without a symbol-table.")) (format t "~&Building ~S for the ~A~%" core-name (c:backend-version c:*backend*)) @@ -2326,8 +2403,11 @@ (progn (clrhash *fdefn-objects*) (clrhash *cold-symbols*) - (init-foreign-symbol-table) - (let ((version (load-foreign-symbol-table symbol-table))) + #-linkage-table (init-foreign-symbol-table) + #+linkage-table (init-foreign-linkage) + (let ((version #-linkage-table (load-foreign-symbol-table + symbol-table) + #+linkage-table 0)) (initialize-spaces) (initialize-symbols) (initialize-layouts) diff --git a/compiler/saptran.lisp b/compiler/saptran.lisp index 5520d0c81958fbaf2214c37144884b638f3a5bf2..1ce21cae8ab3a8c92b56a0d9b536973c340f225d 100644 --- a/compiler/saptran.lisp +++ b/compiler/saptran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.11 1999/09/15 15:11:30 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/saptran.lisp,v 1.12 2002/08/27 22:18:27 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,9 +20,38 @@ ;;;; Defknowns -(defknown foreign-symbol-address (simple-string) system-area-pointer +(defknown foreign-symbol-address (simple-string &key (:flavor t)) + system-area-pointer + (movable flushable)) + +(defknown foreign-symbol-code-address (simple-string) system-area-pointer (movable flushable)) +(defknown foreign-symbol-data-address (simple-string) system-area-pointer + (movable flushable)) + +;;; Preserve compatibility for ports that don't use linkage table yet +(deftransform foreign-symbol-address ((symbol &key flavor) + (simple-string &rest *)) + (if (not flavor) + (progn + #+linkage-table (compiler-error "FOREIGN-SYMBOL-ADDRESS must be qualified with :CODE or :DATA") + #-linkage-table (give-up)) + (let ((flav (cond ((not (constant-continuation-p flavor)) + (compiler-error "FOREIGN-SYMBOL-ADDRESS flavor is not constant." + flavor)) + (t (continuation-value flavor))))) + (cond ((eq flav :code) + `(#+linkage-table foreign-symbol-code-address + #-linkage-table foreign-symbol-address + symbol)) + ((eq flav :data) + `(#+linkage-table foreign-symbol-data-address + #-linkage-table foreign-symbol-address + symbol)) + (t (compiler-error + "FOREIGN-SYMBOL-ADDRESS flavor ~S is not :CODE or :DATA")))))) + (defknown (sap< sap<= sap= sap>= sap>) (system-area-pointer system-area-pointer) boolean (movable flushable)) diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp index 0200bf97a8ba4574d706a37c5af22fe491135d71..ce977406ea07b5e372126110d9c748d98f20864c 100644 --- a/compiler/x86/alloc.lisp +++ b/compiler/x86/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.7 1998/02/19 19:34:35 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.8 2002/08/27 22:18:28 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -234,6 +234,7 @@ (:translate make-symbol) (:args (name :scs (descriptor-reg) :to :eval)) (:temporary (:sc unsigned-reg :from :eval) temp) + (:temporary (:sc unsigned-reg :from :eval) state-addr) (:results (result :scs (descriptor-reg) :from :argument)) (:node-var node) (:generator 37 @@ -242,12 +243,12 @@ (storew unbound-marker-type result symbol-value-slot other-pointer-type) ;; Setup a random hash value for the symbol. Perhaps the object ;; address could be used for even faster and smaller code! + (load-foreign-data-symbol state-addr "fast_random_state") (inst imul temp - (make-fixup (extern-alien-name "fast_random_state") :foreign) + (make-ea :dword :base state-addr) 1103515245) (inst add temp 12345) - (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign) - temp) + (inst mov (make-ea :dword :base state-addr) temp) ;; Want a positive fixnum for the hash value, discard the LS bits. (inst shr temp 1) (inst and temp #xfffffffc) diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp index bdce84f209fb3b56edbb188cb1b649d31f08625e..1183fbdba4dd7e5bb66b581a1215dfefe58f97f7 100644 --- a/compiler/x86/c-call.lisp +++ b/compiler/x86/c-call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.11 1999/11/11 16:11:37 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.12 2002/08/27 22:18:28 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -192,8 +192,9 @@ ,@(new-args)))))) (c::give-up)))) -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) +(define-vop (foreign-symbol-code-address) + (:translate #+linkage-table foreign-symbol-code-address + #-linkage-table foreign-symbol-address) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -204,6 +205,18 @@ (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign)))) +(define-vop (foreign-symbol-data-address) + (:translate foreign-symbol-data-address) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 2 + (inst mov res (make-fixup (extern-alien-name foreign-symbol) + :foreign-data)))) + (define-vop (call-out) (:args (function :scs (sap-reg)) (args :more t)) diff --git a/compiler/x86/macros.lisp b/compiler/x86/macros.lisp index 58a6fdcd3db38eacf57dd76f8d102bf030c0e45c..fcfa3d06f2926ed790d57f5da3266a4c7bef46d2 100644 --- a/compiler/x86/macros.lisp +++ b/compiler/x86/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.15 2000/08/20 14:44:23 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/macros.lisp,v 1.16 2002/08/27 22:18:28 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -94,6 +94,12 @@ (- other-pointer-type))) ,reg)) +(defun make-symbol-value-ea (symbol) + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset symbol) + (ash symbol-value-slot word-shift) + (- other-pointer-type)))) (defmacro load-type (target source &optional (offset 0)) "Loads the type bits of a pointer into target independent of @@ -109,6 +115,11 @@ `(inst mov ,n-target (make-ea :byte :base ,n-source :disp (+ ,n-offset 3))))))) +(defmacro load-foreign-data-symbol (reg name ) + #+linkage-table `(inst mov ,reg (make-fixup (extern-alien-name ,name) + :foreign-data)) + #-linkage-table `(inst lea ,reg (make-fixup (extern-alien-name ,name) + :foreign))) ;;;; Allocation helpers @@ -140,11 +151,9 @@ ;; register as alloc-tn. (load-size alloc-tn size) (inst add alloc-tn - (make-fixup (extern-alien-name "current_region_free_pointer") - :foreign)) + (make-symbol-value-ea '*current-region-free-pointer*)) (inst cmp alloc-tn - (make-fixup (extern-alien-name "current_region_end_addr") - :foreign)) + (make-symbol-value-ea '*current-region-end-addr*)) (inst jmp :be OK) ;; Dispatch to the appropriate overflow routine. There is a ;; routine for each destination. @@ -168,9 +177,7 @@ (inst call (make-fixup (extern-alien-name "alloc_overflow_edi") :foreign)))) (emit-label ok) - (inst xchg (make-fixup - (extern-alien-name "current_region_free_pointer") - :foreign) + (inst xchg (make-symbol-value-ea '*current-region-free-pointer*) alloc-tn)) ;; C call to allocate via dispatch routines. Each ;; destination has a special entry point. The size may be a diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp index 50ded4c3c2718e89e21c898d26d6bc3fbcddc6a4..1ca92c10512d8256e0c07659d8f8cf54ebc3b2ad 100644 --- a/compiler/x86/parms.lisp +++ b/compiler/x86/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.19 2002/03/31 14:48:41 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.20 2002/08/27 22:18:28 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -173,7 +173,9 @@ (export '(target-read-only-space-start target-static-space-start - target-dynamic-space-start)) + target-dynamic-space-start + target-foreign-linkage-space-start + target-foreign-linkage-entry-size)) ;;; Where to put the different spaces. ;;; @@ -181,6 +183,8 @@ (defparameter target-static-space-start #+FreeBSD #x28F00000 #-FreeBSD #x28000000) (defparameter target-dynamic-space-start #x48000000) +(defparameter target-foreign-linkage-space-start #xB0000000) +(defconstant target-foreign-linkage-entry-size 8) ;In bytes. Duh. ;;; Given that NIL is the first thing allocated in static space, we ;;; know its value at compile time: @@ -312,7 +316,14 @@ ;; Used by CGC. *x86-cgc-active-p* + ;; Foreign linkage stuff + lisp::*linkage-table-data* + system::*global-table* + *current-region-free-pointer* + *current-region-end-addr* *static-blue-bag* ; Must be last or change C code + + )) (defparameter static-functions diff --git a/compiler/x86/system.lisp b/compiler/x86/system.lisp index 4d3cc160113e8b68f0a4b04ddbb7bfe3fa6a572b..ae392894fbab2f7b3460eb8bdd7d90972c967989 100644 --- a/compiler/x86/system.lisp +++ b/compiler/x86/system.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/system.lisp,v 1.10 2000/01/17 16:46:10 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/system.lisp,v 1.11 2002/08/27 22:18:29 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -386,8 +386,8 @@ vm:other-pointer-type)) esp-tn) (inst inc index) - (inst mov stack (make-fixup (extern-alien-name "control_stack_end") - :foreign)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :dword :base stack)) (inst jmp-short LOOP) FRESH-STACK @@ -395,8 +395,8 @@ ;; Setup the return context. (inst push (make-fixup nil :code-object return)) - (inst mov stack (make-fixup (extern-alien-name "control_stack_end") - :foreign)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :dword :base stack)) ;; New FP is the Top of the stack. (inst push stack) ;; Save the stack. @@ -474,8 +474,8 @@ vm:other-pointer-type)) esp-tn) (inst inc index) - (inst mov stack (make-fixup (extern-alien-name "control_stack_end") - :foreign)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :dword :base stack)) LOOP (inst cmp stack esp-tn) (inst jmp :le STACK-SAVE-DONE) @@ -500,8 +500,8 @@ :disp (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))) (inst inc index) - (inst mov stack (make-fixup (extern-alien-name "control_stack_end") - :foreign)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :dword :base stack)) LOOP2 (inst cmp stack esp-tn) (inst jmp :le STACK-RESTORE-DONE) @@ -543,8 +543,8 @@ :disp (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type))) (inst inc index) - (inst mov stack (make-fixup (extern-alien-name "control_stack_end") - :foreign)) + (load-foreign-data-symbol stack "control_stack_end") + (inst mov stack (make-ea :dword :base stack)) LOOP (inst cmp stack esp-tn) (inst jmp :le STACK-RESTORE-DONE) diff --git a/lisp/Config.FreeBSD_gencgc b/lisp/Config.FreeBSD_gencgc index ecf673116b6ee797a623923dd84e268466e810e5..05c040076b8fcfb49933c8fd9f48cb8530b52d0d 100644 --- a/lisp/Config.FreeBSD_gencgc +++ b/lisp/Config.FreeBSD_gencgc @@ -7,13 +7,13 @@ CPPFLAGS = -I. -I$(PATH2) -I$(PATH1) -I- -I/usr/X11R6/include CC = gcc LD = ld CPP = cpp -CFLAGS = -Wstrict-prototypes -Wall -O2 -g -DGENCGC -ASFLAGS = -g -DGENCGC +CFLAGS = -Wstrict-prototypes -Wall -O2 -g -DGENCGC -DLINKAGE_TABLE +ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE NM = nm -gp UNDEFSYMPATTERN = -Xlinker -u -Xlinker & ASSEM_SRC = x86-assem.S linux-stubs.S ARCH_SRC = x86-arch.c OS_SRC = FreeBSD-os.c os-common.c -OS_LINK_FLAGS = -Xlinker --export-dynamic +OS_LINK_FLAGS = -dynamic -export-dynamic OS_LIBS = GC_SRC = gencgc.c diff --git a/lisp/Config.linux_gencgc b/lisp/Config.linux_gencgc index c3538e15b74375cd72865ace29fbf14aacbc7964..2d6df1aedcdbdc67ce1aa1e44a9dc739c81f64aa 100644 --- a/lisp/Config.linux_gencgc +++ b/lisp/Config.linux_gencgc @@ -7,13 +7,13 @@ CPPFLAGS = -I. -I$(PATH2) -I$(PATH1) -I- -I/usr/X11R6/include CC = gcc LD = ld CPP = cpp -CFLAGS = -Wstrict-prototypes -Wall -O2 -g -DGENCGC -ASFLAGS = -g -DGENCGC +CFLAGS = -rdynamic -Wstrict-prototypes -Wall -g -DGENCGC -DLINKAGE_TABLE +ASFLAGS = -g -DGENCGC -DLINKAGE_TABLE NM = $(PATH1)/linux-nm UNDEFSYMPATTERN = -Xlinker -u -Xlinker & ASSEM_SRC = x86-assem.S linux-stubs.S ARCH_SRC = x86-arch.c OS_SRC = Linux-os.c os-common.c -OS_LINK_FLAGS = -Xlinker --export-dynamic +OS_LINK_FLAGS = -rdynamic -Xlinker --export-dynamic -Xlinker -Map -Xlinker foo OS_LIBS = -ldl GC_SRC = gencgc.c diff --git a/lisp/FreeBSD-os.c b/lisp/FreeBSD-os.c index 21dd0b33fe77466bd1fa272b1ef4da3e03e55320..2d546d721952935f31146e2da9dd5fe911136bcb 100644 --- a/lisp/FreeBSD-os.c +++ b/lisp/FreeBSD-os.c @@ -12,7 +12,7 @@ * Much hacked by Paul Werkowski * GENCGC support by Douglas Crosher, 1996, 1997. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/FreeBSD-os.c,v 1.7 2002/03/13 08:02:04 moore Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/FreeBSD-os.c,v 1.8 2002/08/27 22:18:30 moore Exp $ * */ @@ -32,6 +32,7 @@ #include <signal.h> /* #include <sys/sysinfo.h> */ #include <sys/proc.h> +#include <dlfcn.h> #include "validate.h" vm_size_t os_vm_page_size; @@ -206,3 +207,22 @@ void os_install_interrupt_handlers(void) interrupt_install_low_level_handler(SIGSEGV, sigsegv_handler); interrupt_install_low_level_handler(SIGBUS, sigbus_handler); } + +void *os_dlsym(const char *sym_name, lispobj lib_list) +{ + if (lib_list != NIL) { + lispobj lib_list_head; + + for (lib_list_head = lib_list; + lib_list_head != NIL; + lib_list_head = (CONS(lib_list_head))->cdr) { + struct cons *lib_cons = (CONS(lib_list_head))->car; + struct sap *dlhandle = (CONS(lib_cons))->car; + void *sym_addr = dlsym((void *)dlhandle->pointer, sym_name); + + if (sym_addr) + return sym_addr; + } + } + return dlsym(RTLD_DEFAULT, sym_name); +} diff --git a/lisp/FreeBSD-os.h b/lisp/FreeBSD-os.h index 353bea60a27e8d9541cb218146c53bcef499cef3..9a18619a30941790dd93a0b1d69b9c28d19b04cb 100644 --- a/lisp/FreeBSD-os.h +++ b/lisp/FreeBSD-os.h @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/FreeBSD-os.h,v 1.3 2000/04/12 17:31:19 pw Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/FreeBSD-os.h,v 1.4 2002/08/27 22:18:30 moore Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -26,12 +26,17 @@ typedef int os_vm_prot_t; #define OS_VM_DEFAULT_PAGESIZE 4096 +int +sc_reg(struct sigcontext*,int); +void +os_save_context(); +/* #define SAVE_CONTEXT os_save_context*/ + /* I *think* this is when things became incompatible with old signals. */ #if __FreeBSD_version > 400010 #define POSIX_SIGS -int /* If we used SA_SIGINFO in sigaction() the third argument to signal handlers would be a struct ucontext_t. (The manpage for sigaction(2) is wrong!) Sigcontext and ucontext_t are @@ -40,6 +45,4 @@ int */ #define USE_SA_SIGINFO 0 #define uc_sigmask sc_mask -sc_reg(struct sigcontext*,int); #endif - diff --git a/lisp/GNUmakefile b/lisp/GNUmakefile index 23819cdce624055b0e8d451d004c50a4cc601a08..328e9218664da364e0787cfced8e80803987fa3a 100644 --- a/lisp/GNUmakefile +++ b/lisp/GNUmakefile @@ -1,4 +1,4 @@ -# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.16 2001/12/06 22:15:34 pmai Exp $ +# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.17 2002/08/27 22:18:30 moore Exp $ all: lisp.nm @@ -23,14 +23,6 @@ OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS)))) ### Don't look in RCS for the files, because we might not want the latest. %: RCS/%,v -### Special target used to make a lisp.nm file for genesis. -### Use when internals.h does not yet exist. -### This is the same 'lisp.nm' but not depending on an existing build. -initial-map: version - echo 'Map file for lisp version ' `cat version` > ,lisp.nm - $(NM) lisp | grep -v " F \| U " >> ,lisp.nm - mv ,lisp.nm lisp.nm - lisp.nm: lisp echo 'Map file for lisp version ' `cat version` > ,lisp.nm $(NM) lisp | grep -v " F \| U " >> ,lisp.nm diff --git a/lisp/Linux-os.c b/lisp/Linux-os.c index 15ea86991556fe17b4fbe6cd2a90081d62319489..355f1fb4bf785b4e07c5fd60ef3745e400951fb5 100644 --- a/lisp/Linux-os.c +++ b/lisp/Linux-os.c @@ -15,7 +15,7 @@ * GENCGC support by Douglas Crosher, 1996, 1997. * Alpha support by Julian Dolby, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.12 2000/10/24 13:32:30 dtc Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/Linux-os.c,v 1.13 2002/08/27 22:18:31 moore Exp $ * */ @@ -42,6 +42,8 @@ #include <sys/resource.h> #include <sys/wait.h> #include <netdb.h> +#include <link.h> +#include <dlfcn.h> #include "validate.h" size_t os_vm_page_size; @@ -279,3 +281,50 @@ void os_install_interrupt_handlers(void) interrupt_install_low_level_handler(SIGSEGV, sigsegv_handler); interrupt_install_low_level_handler(SIGBUS, sigbus_handler); } + +/* Some symbols, most notably stat and lstat, don't appear at all in + the glibc .so files as a result of preprocessor and linker magic / + braindamage. So, try falling back to a stub in linux-stubs.S that + will call the proper function if it's one of those. */ + +static void *dlsym_fallback(void *handle, const char *name) +{ + char newsym[1024]; + void *sym_addr; + + strcpy(newsym, "PVE_stub_"); + strcat(newsym, name); + if ((sym_addr = dlsym(handle, newsym)) == 0) { + fputs(dlerror(), stderr); + } + return sym_addr; +} + +void *os_dlsym(const char *sym_name, lispobj lib_list) +{ + static void *program_handle; + void *sym_addr = 0; + + if (!program_handle) + program_handle = dlopen((void *)0, RTLD_LAZY | RTLD_GLOBAL); + if (lib_list != NIL) { + lispobj lib_list_head; + + for (lib_list_head = lib_list; + lib_list_head != NIL; + lib_list_head = (CONS(lib_list_head))->cdr) { + struct cons *lib_cons = (struct cons *)(CONS(lib_list_head))->car; + struct sap *dlhandle = (struct sap *)(CONS(lib_cons))->car; + + sym_addr = dlsym((void *)dlhandle->pointer, sym_name); + if (sym_addr) + return sym_addr; + } + } + sym_addr = dlsym(program_handle, sym_name); + if (!sym_addr && dlerror()) { + return dlsym_fallback(program_handle,sym_name); + } else { + return sym_addr; + } +} diff --git a/lisp/arch.h b/lisp/arch.h index 975e4ace48529516e111049293e43c2351e77ccc..8874192c6586b7d039a86f42765121af3c4b33cc 100644 --- a/lisp/arch.h +++ b/lisp/arch.h @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/arch.h,v 1.5 2000/10/27 19:25:54 dtc Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/arch.h,v 1.6 2002/08/27 22:18:31 moore Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -33,4 +33,9 @@ extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, extern void fpu_save(void *); extern void fpu_restore(void *); +extern void arch_make_linkage_entry(long, void *, long); +extern long arch_linkage_entry(unsigned long); +void arch_make_lazy_linkage(long linkage_entry); +long arch_linkage_entry(unsigned long retaddr); + #endif /* __ARCH_H__ */ diff --git a/lisp/gencgc.c b/lisp/gencgc.c index 14bfb59133c4fe430fa30e22620aad19e81d1a5c..4159a62352d1f9313383740f1cdb94e29f123559 100644 --- a/lisp/gencgc.c +++ b/lisp/gencgc.c @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997, 1998, 1999. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.26 2002/01/28 20:19:39 pmai Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.27 2002/08/27 22:18:31 moore Exp $ * */ @@ -255,6 +255,21 @@ struct generation { */ static struct generation generations[NUM_GENERATIONS + 1]; +/* Statistics about a generation, extracted from the generations + array. This gets returned to Lisp. +*/ + +struct generation_stats { + int bytes_allocated; + int gc_trigger; + int bytes_consed_between_gc; + int num_gc; + int trigger_age; + int cum_sum_bytes_allocated; + double min_av_mem_age; +}; + + /* * The oldest generation that will currently be GCed by default. * Valid values are: 0, 1, ... (NUM_GENERATIONS - 1) @@ -441,7 +456,42 @@ static void print_generation_stats(int verbose) fpu_restore(fpu_state); } +/* Get statistics that are kept "on the fly" out of the generation + array. +*/ +void get_generation_stats(int gen, struct generation_stats *stats) +{ + if (gen <= NUM_GENERATIONS) { + stats->bytes_allocated = generations[gen].bytes_allocated; + stats->gc_trigger = generations[gen].gc_trigger; + stats->bytes_consed_between_gc = generations[gen].bytes_consed_between_gc; + stats->num_gc = generations[gen].num_gc; + stats->trigger_age = generations[gen].trigger_age; + stats->cum_sum_bytes_allocated = generations[gen].cum_sum_bytes_allocated; + stats->min_av_mem_age = generations[gen].min_av_mem_age; + } +} + +void set_gc_trigger(int gen, int trigger) +{ + if (gen <= NUM_GENERATIONS) { + generations[gen].gc_trigger = trigger; + } +} +void set_trigger_age(int gen, int trigger_age) +{ + if (gen <= NUM_GENERATIONS) { + generations[gen].trigger_age = trigger_age; + } +} + +void set_min_mem_age(int gen, double min_mem_age) +{ + if (gen <= NUM_GENERATIONS) { + generations[gen].min_av_mem_age = min_mem_age; + } +} /* * Allocation routines. @@ -499,11 +549,13 @@ static void print_generation_stats(int verbose) struct alloc_region boxed_region; struct alloc_region unboxed_region; +#if 0 /* * X hack. current lisp code uses the following. Need coping in/out. */ void *current_region_free_pointer; void *current_region_end_addr; +#endif /* The generation currently being allocated to. X */ static int gc_alloc_generation; @@ -5670,13 +5722,15 @@ static void verify_zero_fill(void) void gencgc_verify_zero_fill(void) { /* Flush the alloc regions updating the tables. */ - boxed_region.free_pointer = current_region_free_pointer; + + boxed_region.free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER); gc_alloc_update_page_tables(0, &boxed_region); gc_alloc_update_page_tables(1, &unboxed_region); fprintf(stderr, "* Verifying zero fill\n"); verify_zero_fill(); - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, + (lispobj)boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, (lispobj)boxed_region.end_addr); } static void verify_dynamic_space(void) @@ -5965,7 +6019,7 @@ void collect_garbage(unsigned last_gen) int gen_to_wp; int i; - boxed_region.free_pointer = current_region_free_pointer; + boxed_region.free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER); /* Check last_gen */ if (last_gen > NUM_GENERATIONS) { @@ -6075,8 +6129,8 @@ void collect_garbage(unsigned last_gen) update_x86_dynamic_space_free_pointer(); - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); /* Call the scavenger hook functions */ { @@ -6187,8 +6241,8 @@ void gc_free_heap(void) last_free_page = 0; SetSymbolValue(ALLOCATION_POINTER, (lispobj) heap_base); - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); if (verify_after_free_heap) { /* Check if purify has left any bad pointers. */ @@ -6263,8 +6317,8 @@ void gc_init(void) last_free_page = 0; - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); } /* @@ -6297,8 +6351,8 @@ void gencgc_pickup_dynamic(void) generations[0].bytes_allocated = PAGE_SIZE * page; bytes_allocated = PAGE_SIZE * page; - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); } @@ -6330,7 +6384,7 @@ int alloc_entered = 0; char *alloc(int nbytes) { /* Check for alignment allocation problems. */ - gc_assert(((unsigned) current_region_free_pointer & 0x7) == 0 + gc_assert(((unsigned) SymbolValue(CURRENT_REGION_FREE_POINTER) & 0x7) == 0 && (nbytes & 0x7) == 0); if (SymbolValue(PSEUDO_ATOMIC_ATOMIC)) { @@ -6342,12 +6396,12 @@ char *alloc(int nbytes) fprintf(stderr,"* Alloc re-entered\n"); /* Check if there is room in the current region. */ - new_free_pointer = current_region_free_pointer + nbytes; + new_free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER) + nbytes; if (new_free_pointer <= boxed_region.end_addr) { /* If so then allocate from the current region. */ - void *new_obj = current_region_free_pointer; - current_region_free_pointer = new_free_pointer; + void *new_obj = SymbolValue(CURRENT_REGION_FREE_POINTER); + SetSymbolValue(CURRENT_REGION_FREE_POINTER, new_free_pointer); alloc_entered--; return (void *) new_obj; } @@ -6368,11 +6422,11 @@ char *alloc(int nbytes) goto retry1; } /* Call gc_alloc */ - boxed_region.free_pointer = current_region_free_pointer; + boxed_region.free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER); { void *new_obj = gc_alloc(nbytes); - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); alloc_entered--; return new_obj; } @@ -6401,12 +6455,12 @@ char *alloc(int nbytes) fprintf(stderr,"* Alloc re-entered\n"); /* Check if there is room in the current region. */ - new_free_pointer = current_region_free_pointer + nbytes; + new_free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER) + nbytes; if (new_free_pointer <= boxed_region.end_addr) { /* If so then allocate from the current region. */ - void *new_obj = current_region_free_pointer; - current_region_free_pointer = new_free_pointer; + void *new_obj = SymbolValue(CURRENT_REGION_FREE_POINTER); + SetSymbolValue(CURRENT_REGION_FREE_POINTER, new_free_pointer); alloc_entered--; SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0)); @@ -6433,10 +6487,10 @@ char *alloc(int nbytes) } /* Else call gc_alloc */ - boxed_region.free_pointer = current_region_free_pointer; + boxed_region.free_pointer = SymbolValue(CURRENT_REGION_FREE_POINTER); result = gc_alloc(nbytes); - current_region_free_pointer = boxed_region.free_pointer; - current_region_end_addr = boxed_region.end_addr; + SetSymbolValue(CURRENT_REGION_FREE_POINTER, boxed_region.free_pointer); + SetSymbolValue(CURRENT_REGION_END_ADDR, boxed_region.end_addr); alloc_entered--; SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0)); diff --git a/lisp/gencgc.h b/lisp/gencgc.h index 0e8e32796fc84f717800f303a69c0c4635574c64..e1dab261c1e2c638d7f09ef65639b88b1425b3e8 100644 --- a/lisp/gencgc.h +++ b/lisp/gencgc.h @@ -7,7 +7,7 @@ * * Douglas Crosher, 1996, 1997. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.h,v 1.6 2000/10/27 19:25:55 dtc Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.h,v 1.7 2002/08/27 22:18:32 moore Exp $ * */ @@ -159,4 +159,4 @@ lispobj * component_ptr_from_pc(lispobj *pc); void gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region); -#endif _GENCGC_H_ +#endif /* _GENCGC_H_ */ diff --git a/lisp/linux-stubs.S b/lisp/linux-stubs.S index 79859cae1ccce4f4e6acb95b5e5b77714fdd6287..b22e4b502c72c965e23ac20b68ac373ef94f5759 100644 --- a/lisp/linux-stubs.S +++ b/lisp/linux-stubs.S @@ -1,6 +1,6 @@ /* linux-stubs.S - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/linux-stubs.S,v 1.10 2001/01/22 10:49:52 dtc Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/linux-stubs.S,v 1.11 2002/08/27 22:18:32 moore Exp $ These are needed because the locations of the libraries are filled in by ld.so at runtime. @@ -19,7 +19,19 @@ PVE_stub_ ## fct: ;\ jmp fct ;\ .L ## fct ## e1: ;\ .size PVE_stub_ ## fct,.L ## fct ## e1-PVE_stub_ ## fct ; - +#if defined(LINKAGE_TABLE) && !defined(__FreeBSD__) + /* This is a workaround for glibc braindamage. These symbols are + magically transformed by the preprocessor and linker so that + these symbols of don't appear in libc.so. These stubs + are here so that os_dlsym will still work with them. + Eventually we'll autogenerate this list of symbols by looking + of the output of 'nm /usr/lib/libc_nonshared.a'. */ + doe(atexit) + doe(stat) + doe(fstat) + doe(lstat) + doe(mknod) +#else doe(accept) doe(access) doe(acos) @@ -910,3 +922,4 @@ PVE_stub_ ## fct: ;\ /* doe(yp_unbind) */ /* doe(yperr_string) */ /* doe(ypprot_err) */ +#endif /* defined(LINKAGE_TABLE) && !defined(__FreeBSD__) */ diff --git a/lisp/lisp.c b/lisp/lisp.c index 95351b85bbbd764c34a4e9ef3428e970bcf27dbd..8a260363cd60607d8d2fff2baeabba42ad78cb42 100644 --- a/lisp/lisp.c +++ b/lisp/lisp.c @@ -1,7 +1,7 @@ /* * main() entry point for a stand alone lisp image. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.c,v 1.25 2002/01/29 01:23:33 pmai Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/lisp.c,v 1.26 2002/08/27 22:18:32 moore Exp $ * */ @@ -206,7 +206,9 @@ int main(int argc, char *argv[], char *envp[]) globals_init(); initial_function = load_core_file(core); - +#if defined LINKAGE_TABLE + os_foreign_linkage_init(); +#endif /* LINKAGE_TABLE */ #if defined GENCGC gencgc_pickup_dynamic(); diff --git a/lisp/os-common.c b/lisp/os-common.c index 5e0b634c53a3bc7cb36a08848b4e41d5bb8c4737..d3e4fc04bd029531d8d4e131a9f1a17bb9b9c562 100644 --- a/lisp/os-common.c +++ b/lisp/os-common.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os-common.c,v 1.4 1994/10/27 17:13:54 ram Exp $ + $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os-common.c,v 1.5 2002/08/27 22:18:33 moore Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -8,8 +8,12 @@ */ #include <stdio.h> +#include <string.h> #include "os.h" +#include "internals.h" +#include "validate.h" +#include "lisp.h" /* Except for os_zero, these routines are only called by Lisp code. These routines may also be replaced by os-dependent versions instead. See @@ -98,3 +102,134 @@ os_vm_address_t os_reallocate(os_vm_address_t addr, os_vm_size_t old_len, return addr; } } + +extern void resolve_linkage_tramp(void); + +/* In words */ + +#define LINKAGE_DATA_ENTRY_SIZE 3 +void os_foreign_linkage_init (void) +{ +#ifdef LINKAGE_TABLE + lispobj linkage_data_obj = SymbolValue(LINKAGE_TABLE_DATA); + struct array *linkage_data = 0; + long table_size = 0; + struct vector *data_vector = 0; + long i; + + linkage_data = (struct array *)PTR(linkage_data_obj); + table_size = fixnum_value(linkage_data->fill_pointer); + data_vector = (struct vector *)PTR(linkage_data->data); + for (i = 0; i < table_size; i += LINKAGE_DATA_ENTRY_SIZE) { + struct vector *symbol_name + = (struct vector *)PTR(data_vector->data[i]); + long type = fixnum_value(data_vector->data[i + 1]); + lispobj lib_list = data_vector->data[i + 2]; + + if (i == 0) { + if (type != 1 || strcmp((char *)symbol_name->data, + "resolve_linkage_tramp")) { + lose("First element of linkage_data is bogus.\n"); + } + arch_make_linkage_entry(0, &resolve_linkage_tramp, 1); + continue; + } + if (type == 2 && lib_list == NIL) { + void *target_addr = os_dlsym((char *)symbol_name->data, NIL); + + if (!target_addr) { + lose("%s is not defined.\n", (char *)symbol_name->data); + } + arch_make_linkage_entry(i / LINKAGE_DATA_ENTRY_SIZE, target_addr, + type); + } else { + arch_make_lazy_linkage(i / LINKAGE_DATA_ENTRY_SIZE); + } + } +#endif /* LINKAGE_TABLE */ +} + +/* At the second stage of initialization, after Lisp has dlopened all + needed shared libraries, go back through the table and initialize + data symbols. */ + +void +os_resolve_data_linkage(void) +{ +#ifdef LINKAGE_TABLE + lispobj linkage_data_obj = SymbolValue(LINKAGE_TABLE_DATA); + struct array *linkage_data = 0; + long table_size = 0; + struct vector *data_vector = 0; + long i; + + linkage_data = (struct array *)PTR(linkage_data_obj); + table_size = fixnum_value(linkage_data->fill_pointer); + data_vector = (struct vector *)PTR(linkage_data->data); + for (i = 0; i < table_size; i += LINKAGE_DATA_ENTRY_SIZE) { + struct vector *symbol_name + = (struct vector *)PTR(data_vector->data[i]); + long type = fixnum_value(data_vector->data[i + 1]); + lispobj lib_list = data_vector->data[i + 2]; + + if (type == 2 && lib_list != NIL) { + void *target_addr = os_dlsym((char *)symbol_name->data, lib_list); + + if (!target_addr) { + lose("%s is not defined.\n", (char *)symbol_name->data); + } + arch_make_linkage_entry(i / LINKAGE_DATA_ENTRY_SIZE, target_addr, + type); + } + } +#endif /* LINKAGE_TABLE */ +} + +/* Make entry for the symbol at entry in LINKAGE_TABLE_DATA. Called + from register-foreign-linkage. */ + +extern void undefined_ff_tramp(lispobj arg); + +unsigned long os_link_one_symbol(long entry) +{ +#ifdef LINKAGE_TABLE + lispobj linkage_data_obj = SymbolValue(LINKAGE_TABLE_DATA); + struct array *linkage_data = 0; + long table_size = 0; + struct vector *data_vector = 0; + struct vector *symbol_name; + long type; + void *target_addr; + long table_index = entry * LINKAGE_DATA_ENTRY_SIZE; + + linkage_data = (struct array *)PTR(linkage_data_obj); + table_size = fixnum_value(linkage_data->fill_pointer); + if (table_index >= table_size - 1) { + return 0; + } + data_vector = (struct vector *)PTR(linkage_data->data); + symbol_name = (struct vector *)PTR(data_vector->data[table_index]); + type = fixnum_value(data_vector->data[table_index + 1]); + target_addr = os_dlsym((char *)symbol_name->data, + data_vector->data[table_index + 2]); + if (!target_addr) { + undefined_ff_tramp((lispobj)data_vector->data[table_index]); + } + arch_make_linkage_entry(entry, target_addr, type); + return target_addr; +#else + return 0; +#endif /* LINKAGE_TABLE */ +} + +unsigned long lazy_resolve_linkage(unsigned long retaddr) +{ +#ifdef LINKAGE_TABLE + unsigned long target_addr + = os_link_one_symbol(arch_linkage_entry(retaddr)); + + return target_addr; +#else + return 0; +#endif /* LINKAGE_TABLE */ +} diff --git a/lisp/os.h b/lisp/os.h index 8c14ed6ab930b3934dd2efe730e3ee0fcb901ba9..a0a1c0cc3a378592b9aa19fb37ed9e608d9a65c3 100644 --- a/lisp/os.h +++ b/lisp/os.h @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os.h,v 1.9 2002/01/28 20:17:11 pmai Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os.h,v 1.10 2002/08/27 22:18:33 moore Exp $ * * Common interface for os-dependent functions. * @@ -102,4 +102,7 @@ extern boolean valid_addr(os_vm_address_t test); #define os_round_up_size_to_page(size) \ os_trunc_size_to_page((size)+(os_vm_page_size-1)) +extern void os_foreign_linkage_init(void); +extern void *os_dlsym (const char *sym_name, lispobj lib_list); + #endif diff --git a/lisp/validate.c b/lisp/validate.c index a8b093a4e0e7368d2878556bea2e5b3c463553cd..1985cf242c0d8e07933b3aae86fbc8497dc78ac0 100644 --- a/lisp/validate.c +++ b/lisp/validate.c @@ -1,5 +1,5 @@ /* - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.c,v 1.9 2000/10/27 19:32:52 dtc Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/validate.c,v 1.10 2002/08/27 22:18:33 moore Exp $ * * Memory Validation */ @@ -59,7 +59,10 @@ void validate(void) /* Binding Stack */ binding_stack = (lispobj *) BINDING_STACK_START; ensure_space(binding_stack, BINDING_STACK_SIZE); - +#ifdef LINKAGE_TABLE + ensure_space((lispobj *)FOREIGN_LINKAGE_SPACE_START, + FOREIGN_LINKAGE_SPACE_SIZE); +#endif #ifdef sparc make_holes(); #endif diff --git a/lisp/x86-arch.c b/lisp/x86-arch.c index 5bff6125d42dc3637441c82de0400153160c50dd..c99252fab5bbea27d33cbb6262b8247bda73efb4 100644 --- a/lisp/x86-arch.c +++ b/lisp/x86-arch.c @@ -1,6 +1,6 @@ /* x86-arch.c -*- Mode: C; comment-column: 40 -*- * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-arch.c,v 1.16 2002/01/28 20:17:12 pmai Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-arch.c,v 1.17 2002/08/27 22:18:33 moore Exp $ * */ @@ -342,3 +342,58 @@ lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2) args[2] = arg2; return call_into_lisp(function, args, 3); } + +/* Linkage entry size is 8, for no good reason. */ +#define LINKAGE_ENTRY_SIZE 8 + +#ifdef LINKAGE_TABLE +void arch_make_linkage_entry(long linkage_entry, void *target_addr, long type) +{ + char *reloc_addr = (char *)(FOREIGN_LINKAGE_SPACE_START + + linkage_entry * LINKAGE_ENTRY_SIZE); + + if (type == 1) { /* code reference */ + /* Make JMP to function entry. */ + /* JMP offset is calculated from next instruction. */ + long offset = (char *)target_addr - (reloc_addr + 5); + int i; + + *reloc_addr++ = 0xe9; /* opcode for JMP rel32 */ + for (i = 0; i < 4; i++) { + *reloc_addr++ = offset & 0xff; + offset >>= 8; + } + /* write a nop for good measure. */ + *reloc_addr = 0x90; + } else if (type == 2) { + *(unsigned long *)reloc_addr = (unsigned long)target_addr; + } +} + +/* Make a call to the first function in the linkage table, which is + resolve_linkage_tramp. */ +void arch_make_lazy_linkage(long linkage_entry) +{ + char *reloc_addr = (char *)(FOREIGN_LINKAGE_SPACE_START + + linkage_entry * LINKAGE_ENTRY_SIZE); + long offset = (char *)(FOREIGN_LINKAGE_SPACE_START) - (reloc_addr + 5); + int i; + + *reloc_addr++ = 0xe8; /* opcode for CALL rel32 */ + for (i = 0; i < 4; i++) { + *reloc_addr++ = offset & 0xff; + offset >>= 8; + } + /* write a nop for good measure. */ + *reloc_addr = 0x90; +} + +/* Get linkage entry. The initial instruction in the linkage + entry is a CALL; the return address we're passed points to the next + instruction. */ + +long arch_linkage_entry(unsigned long retaddr) +{ + return ((retaddr - 5) - FOREIGN_LINKAGE_SPACE_START) / LINKAGE_ENTRY_SIZE; +} +#endif /* LINKAGE_TABLE */ diff --git a/lisp/x86-assem.S b/lisp/x86-assem.S index 5df5517fc744d9a10ed05c68b505f10809c20aef..44175c60898a19fa46a19379ba826c41df8be4a1 100644 --- a/lisp/x86-assem.S +++ b/lisp/x86-assem.S @@ -1,6 +1,6 @@ ### x86-assem.S -*- Mode: Asm; -*- /** - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.21 2002/08/23 17:01:02 pmai Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.22 2002/08/27 22:18:34 moore Exp $ * * Authors: Paul F. Werkowski <pw@snoopy.mv.com> * Douglas T. Crosher @@ -732,7 +732,7 @@ GNAME(alloc_overflow_eax): pushl %ecx # Save ecx pushl %edx # Save edx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%eax + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%eax pushl %eax # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -751,7 +751,7 @@ GNAME(alloc_overflow_ecx): pushl %eax # Save eax pushl %edx # Save edx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%ecx + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ecx pushl %ecx # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -771,7 +771,7 @@ GNAME(alloc_overflow_edx): pushl %eax # Save eax pushl %ecx # Save ecx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%edx + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edx pushl %edx # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -792,7 +792,7 @@ GNAME(alloc_overflow_ebx): pushl %ecx # Save ecx pushl %edx # Save edx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%ebx + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ebx pushl %ebx # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -814,7 +814,7 @@ GNAME(alloc_overflow_esi): pushl %ecx # Save ecx pushl %edx # Save edx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%esi + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%esi pushl %esi # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -836,7 +836,7 @@ GNAME(alloc_overflow_edi): pushl %ecx # Save ecx pushl %edx # Save edx /* Calculate the size for the allocation. */ - subl GNAME(current_region_free_pointer),%edi + subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edi pushl %edi # Push the size call GNAME(alloc) addl $4,%esp # pop the size arg. @@ -850,4 +850,81 @@ GNAME(alloc_overflow_edi): #endif +/* Call into C code to resolve a linkage entry. The initial code in the + * linkage entry has done a call to here; pass that return entry along as a + * parameter. + * + * We could be called from raw Lisp code or from a foreign call site, so we + * have to save all the registers... + */ + .align align_4byte + .globl GNAME(resolve_linkage_tramp) + .type GNAME(resolve_linkage_tramp),@function +GNAME(resolve_linkage_tramp): + pushl %ebp # save old frame pointer + movl %esp,%ebp # establish new frame + pushl %eax + pushl %ebx + pushl %ecx + pushl %edx + pushl %edi + pushl %esi + /* calling location (plus offset) was on top of stack */ + movl 4(%ebp), %eax + pushl %eax # push for C function + call GNAME(lazy_resolve_linkage) + /* real address of target is in %eax. Replace return address on stack + * with it. That way we can get out of here without trashing any + *registers! + */ + movl %eax,4(%ebp) + addl $4, %esp # bump off argument to lazy_resolve_linkage + popl %esi + popl %edi + popl %edx + popl %ecx + popl %ebx + popl %eax + popl %ebp + ret # jump to the real target + .size GNAME(resolve_linkage_tramp),.-GNAME(resolve_linkage_tramp) + +/* + * The undefined-ff-function trampoline. + */ + .text + .align align_4byte,0x90 + .global GNAME(undefined_ff_tramp) + .type GNAME(undefined_ff_tramp),@function +GNAME(undefined_ff_tramp): + /* C Calling Convention, move one arg to EAX */ + pushl %ebp + movl %esp,%ebp + movl 8(%ebp),%eax + + /* Now trap to Lisp */ + int3 + /* The trap code: */ + .byte trap_Error + /* The number of arguments, including the error code */ + .byte 2 + /* The error code, which varies with long-float availability */ + /* Here we use undefined-foreign-symbol-error. */ +#ifdef type_LongFloat + .byte 67 +#else + .byte 66 +#endif + /* Now the real args. Each arg is provided via a SC-OFFSET. + SC-OFFSETS are defined in code/debug-info.lisp. They + encode the storage class and storage class offset in + one 27bit integer, the storage class taking the 5 LSBs, + with the 22 MSBs indicating the offset. */ + .byte sc_DescriptorReg | 0x00 # EAX in the Descriptor-reg SC. + + /* C Calling Convention */ + /* Doesn't matter here, but could if we'd use trap_Cerror */ + leave + ret + .size GNAME(undefined_ff_tramp), .-GNAME(undefined_ff_tramp) .end diff --git a/lisp/x86-validate.h b/lisp/x86-validate.h index f6c3ac3fef653d7fac104db151c5571818b5dc6f..e16e55b2717b9de02992e723560874a986543851 100644 --- a/lisp/x86-validate.h +++ b/lisp/x86-validate.h @@ -3,7 +3,7 @@ * This code was written as part of the CMU Common Lisp project at * Carnegie Mellon University, and has been placed in the public domain. * - * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-validate.h,v 1.15 2002/03/13 08:02:05 moore Exp $ + * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-validate.h,v 1.16 2002/08/27 22:18:34 moore Exp $ * */ @@ -64,7 +64,11 @@ #define DYNAMIC_SPACE_SIZE (0x04000000) /* 64MB */ #endif #define DEFAULT_DYNAMIC_SPACE_SIZE (0x20000000) /* 512MB */ +#ifdef LINKAGE_TABLE +#define FOREIGN_LINKAGE_SPACE_START (0xb0000000) +#define FOREIGN_LINKAGE_SPACE_SIZE (0x100000) /* 1MB */ #endif +#endif /* __FreeBSD__ */ #if defined(__OpenBSD__) || defined(__NetBSD__) @@ -110,6 +114,10 @@ #define DYNAMIC_SPACE_SIZE (0x04000000) /* 64MB */ #endif #define DEFAULT_DYNAMIC_SPACE_SIZE (0x20000000) /* 512MB */ +#ifdef LINKAGE_TABLE +#define FOREIGN_LINKAGE_SPACE_START (0xb0000000) +#define FOREIGN_LINKAGE_SPACE_SIZE (0x100000) /* 1MB */ +#endif #endif diff --git a/tools/comcom.lisp b/tools/comcom.lisp index 96e2839a71ccea805cc1dd6267902761695b93fe..6f599ca207a91ab1a4b3e14063cacc6e3dd43dce 100644 --- a/tools/comcom.lisp +++ b/tools/comcom.lisp @@ -3,7 +3,7 @@ ;;; ********************************************************************** ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/comcom.lisp,v 1.52 2002/08/26 20:45:03 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/comcom.lisp,v 1.53 2002/08/27 22:18:35 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -67,6 +67,8 @@ (defvar c::*target-backend* (c::make-backend)) (comf (vmdir "target:compiler/parms") :proceed t) +;(when *load-stuff* +; (load (vmdir "target:compiler/parms"))) (comf "target:compiler/generic/objdef" :proceed t) (comf "target:compiler/generic/interr") @@ -90,6 +92,8 @@ (load "target:compiler/meta-vmdef")) (comf "target:compiler/disassem" :byte-compile *byte-compile*) (comf "target:compiler/new-assem") +(when *load-stuff* + (load "target:compiler/new-assem")) (comf "target:compiler/alloc") (comf "target:compiler/knownfun") (comf "target:compiler/fndb") diff --git a/tools/worldbuild.lisp b/tools/worldbuild.lisp index e73bcd6a52cbd082d1862c359ddd4058376f40e7..8f521ecf5ca7c6b2c152e21db6ca062749f7c431 100644 --- a/tools/worldbuild.lisp +++ b/tools/worldbuild.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.43 2001/12/06 19:15:48 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldbuild.lisp,v 1.44 2002/08/27 22:18:35 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -146,6 +146,7 @@ "target:code/package" "target:code/reader" "target:code/load" + "target:code/foreign-linkage" ,@(when (c:backend-featurep :pmax) '("target:code/pmax-vm")) ,@(when (c:backend-featurep :sparc) diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp index cefce81f96b2729d472c174cd08bb60c0926a5cc..46ae866d100bb6c0aa1b05f077ad13d0a94db7e5 100644 --- a/tools/worldcom.lisp +++ b/tools/worldcom.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.81 2001/03/03 15:16:07 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.82 2002/08/27 22:18:35 moore Exp $") ;;; ;;; ********************************************************************** ;;; @@ -233,6 +233,7 @@ (comf "target:code/filesys") #-no-runtime (comf "target:code/filesys" :byte-compile t) (comf "target:code/load") +(comf "target:code/foreign-linkage") (comf "target:code/module" :byte-compile *byte-compile*) (comf "target:code/eval")