From bf84be07a3ae2eb93dbf6e4a57003151a177b383 Mon Sep 17 00:00:00 2001 From: moore <moore> Date: Tue, 27 Aug 2002 22:18:35 +0000 Subject: [PATCH] On x86 FreeBSD and Linux, change the way foreign symbol addresses are resolved. They now go through a table -- effectively a new space in the core file. Function references are resolved lazily, data references are resolved on startup and when a .so is loaded. The end result is that cores can be dumped that contain references to symbols in shared libraries. Also, the dependence of the core on addresses in the Lisp runtime is broken. The linkage table feature is controlled by :linkage-table and LINKAGE_TABLE in C runtime. Several foreign symbols are now Lisp static symbols, so a cross compile is required whether or not the new stuff is used. I've checked in boot4-cross-foreign-linkage.lisp that builds the compiler for linkage table; do whatever you usually do for the non-linkage table case:) Seriously, lets start a discussion on standardizing "cross compilation," not to mention the general build procedure. --- .../18d/boot4-cross-foreign-linkage.lisp | 291 ++++++++++++++++++ code/alieneval.lisp | 27 +- code/debug-int.lisp | 11 +- code/exports.lisp | 16 +- code/foreign-linkage.lisp | 85 +++++ code/foreign.lisp | 44 ++- code/gc.lisp | 40 ++- code/load.lisp | 31 +- code/unix.lisp | 6 +- code/x86-vm.lisp | 26 +- compiler/debug.lisp | 16 +- compiler/disassem.lisp | 6 +- compiler/dump.lisp | 36 ++- compiler/generic/core.lisp | 10 +- compiler/generic/interr.lisp | 6 +- compiler/generic/new-genesis.lisp | 168 +++++++--- compiler/saptran.lisp | 33 +- compiler/x86/alloc.lisp | 9 +- compiler/x86/c-call.lisp | 19 +- compiler/x86/macros.lisp | 23 +- compiler/x86/parms.lisp | 15 +- compiler/x86/system.lisp | 22 +- lisp/Config.FreeBSD_gencgc | 6 +- lisp/Config.linux_gencgc | 6 +- lisp/FreeBSD-os.c | 22 +- lisp/FreeBSD-os.h | 11 +- lisp/GNUmakefile | 10 +- lisp/Linux-os.c | 51 ++- lisp/arch.h | 7 +- lisp/gencgc.c | 106 +++++-- lisp/gencgc.h | 4 +- lisp/linux-stubs.S | 17 +- lisp/lisp.c | 6 +- lisp/os-common.c | 137 ++++++++- lisp/os.h | 5 +- lisp/validate.c | 7 +- lisp/x86-arch.c | 57 +++- lisp/x86-assem.S | 91 +++++- lisp/x86-validate.h | 10 +- tools/comcom.lisp | 6 +- tools/worldbuild.lisp | 3 +- tools/worldcom.lisp | 3 +- 42 files changed, 1308 insertions(+), 197 deletions(-) create mode 100644 bootfiles/18d/boot4-cross-foreign-linkage.lisp create mode 100644 code/foreign-linkage.lisp diff --git a/bootfiles/18d/boot4-cross-foreign-linkage.lisp b/bootfiles/18d/boot4-cross-foreign-linkage.lisp new file mode 100644 index 000000000..9e59165c7 --- /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 f3528ff27..29d792c98 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 e1f1af4e3..43e4d1b94 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 65a2e84eb..136ecb3cd 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 000000000..c763e1f3c --- /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 f59cf2778..0468d22d6 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 7c6484635..5db8ffd1b 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 229081f9a..dd224757c 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 6222a5cfc..4edbc55de 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 2dbd6f30a..4ef5a575e 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 9deb6ae65..1184730fb 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 461349bc4..09f00f217 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 d87e6ea91..fddd7e225 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 0ab0fba1f..937a537bd 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 0af78fdca..7b0b4fe3c 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 311dabbd2..b3dc359a2 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 5520d0c81..1ce21cae8 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 0200bf97a..ce977406e 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 bdce84f20..1183fbdba 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 58a6fdcd3..fcfa3d06f 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 50ded4c3c..1ca92c105 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 4d3cc1601..ae392894f 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 ecf673116..05c040076 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 c3538e15b..2d6df1aed 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 21dd0b33f..2d546d721 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 353bea60a..9a18619a3 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 23819cdce..328e92186 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 15ea86991..355f1fb4b 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 975e4ace4..8874192c6 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 14bfb5913..4159a6235 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 0e8e32796..e1dab261c 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 79859cae1..b22e4b502 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 95351b85b..8a260363c 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 5e0b634c5..d3e4fc04b 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 8c14ed6ab..a0a1c0cc3 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 a8b093a4e..1985cf242 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 5bff6125d..c99252fab 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 5df5517fc..44175c608 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 f6c3ac3fe..e16e55b27 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 96e2839a7..6f599ca20 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 e73bcd6a5..8f521ecf5 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 cefce81f9..46ae866d1 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") -- GitLab