Commit bf84be07 authored by moore's avatar moore
Browse files

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.
parent 08395aae
Loading
Loading
Loading
Loading
+291 −0
Original line number Diff line number Diff line
;;; 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)))
+18 −9
Original line number Diff line number Diff line
@@ -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
  (let* ((alien-name (etypecase name
		       (symbol (guess-alien-name-from-lisp-name name))
		      (string 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))))
+7 −4
Original line number Diff line number Diff line
@@ -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
+14 −2
Original line number Diff line number Diff line
@@ -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"
+85 −0
Original line number Diff line number Diff line
(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)))
Loading