diff --git a/code/foreign.lisp b/code/foreign.lisp index 402ba4b4a3e3f75276543be7bd8658450131282a..1be9c026f168cb812642d568ad8dae4e49d2ddbb 100644 --- a/code/foreign.lisp +++ b/code/foreign.lisp @@ -1,93 +1,183 @@ -;;; -*- Log: code.log; Package: Extensions -*- - +;;; -*- Package: SYSTEM -*- +;;; ;;; ********************************************************************** ;;; This code was written as part of the Spice Lisp project at ;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of Spice Lisp, please contact ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** - -;;; Functions for dealing with foreign function calls in Common Lisp. - -;;; Written by David B. McDonald, January 1987. - -;;; ******************************************************************* -(in-package "EXTENSIONS" :nicknames '("EXT") :use '("LISP" "SYSTEM")) - -(export '(load-foreign get-code-pointer get-data-pointer)) - -(defconstant Unix-OMagic #x107) -(defconstant Unix-NMagic #x108) -(defconstant Unix-ZMagic #x10b) - -(defconstant Unix-header-size 32) -(defconstant Symbol-Table-Entry-Size 12) - -(defconstant n_undf #x0) -(defconstant n_abs #x2) -(defconstant n_text #x4) -(defconstant n_data #x6) -(defconstant n_bss #x8) -(defconstant n_comm #x12) -(defconstant n_fn #x1f) -(defconstant n_ext #x1) - -(defvar file-count 0 - "Number of foreign function files loaded into the current Lisp.") - -(defvar temporary-foreign-files NIL - "List of dotted pairs containing location and size of object code - loaded so that foreign functions can be called.") - -(proclaim '(fixnum file-count)) - -(defstruct unix-ste - (type 0 :type fixnum) - (location 0)) - - -(defvar foreign-symbols (make-hash-table :size 1000 :test #'equal)) - -(defmacro read-cword (sap offset) - `(let ((rsap ,sap) - (roff ,offset)) - (declare (fixnum roff)) - (setq roff (the fixnum (ash roff 1))) - (logior (ash (%primitive 16bit-system-ref rsap roff) 16) - (%primitive 16bit-system-ref rsap (the fixnum (1+ roff)))))) - -(defun read-miscop-free-pointer () - (let ((aa lisp::alloctable-address) - (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift))) - (declare (fixnum in)) - (logand (+ (logior (%primitive 16bit-system-ref aa (the fixnum (1+ in))) - (ash (%primitive 16bit-system-ref aa in) 16)) 3) - (lognot 3)))) - -(defun write-miscop-free-pointer (value) - (let ((aa lisp::alloctable-address) - (in (ash lisp::%assembler-code-type lisp::%alloc-ref-type-shift)) - (vl (logand value #xFFFF)) - (vh (logand (ash value -16) #xFFFF))) - (declare (fixnum in)) - (%primitive 16bit-system-set aa (the fixnum (1+ in)) vl) - (%primitive 16bit-system-set aa in vh))) - -;;; Load-foreign accepts a file or a list of files to be loaded into the -;;; currently running Lisp core. These files should be standard object -;;; files created by you favourite compiler (e.g., cc). It accepts two -;;; optional parameters: libraries is a list of libraries to search -;;; for unresolved references (default is the standard C library), and -;;; env which is a list of Unix environment strings (default is what -;;; lisp started with). Load-foreign runs ld creating an object file -;;; that has been linked so that it can be loaded into a predetermined -;;; location in memory. +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.3 1991/01/31 01:20:54 wlott Exp $ +;;; +;;; Load-foreign and support routines. +;;; +(in-package "SYSTEM") + +(export '(load-foreign)) + +(defconstant foreign-segment-start #x00C00000) +(defconstant foreign-segment-size #x00400000) + +(defvar *previous-linked-object-file* nil) +(defvar *foreign-segment-free-pointer* foreign-segment-start) + +(defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C")) + (let ((code (char-code #\A))) + (loop + (let ((name (format nil base (mach:unix-getpid) (code-char code)))) + (multiple-value-bind + (fd errno) + (mach:unix-open name + (logior mach:o_wronly mach:o_creat mach:o_excl) + #o666) + (cond ((not (null fd)) + (mach:unix-close fd) + (return name)) + ((not (= errno mach:eexist)) + (error "Could not create temporary file ~S: ~A" + name (mach:get-unix-error-msg errno))) + + ((= code (char-code #\Z)) + (setf code (char-code #\a))) + ((= code (char-code #\z)) + (return nil)) + (t + (incf code)))))))) + +#+sparc +(ext:def-c-record exec + (magic ext:unsigned-long) + (text ext:unsigned-long) + (data ext:unsigned-long) + (bss ext:unsigned-long) + (syms ext:unsigned-long) + (entry ext:unsigned-long) + (trsize ext:unsigned-long) + (drsize ext:unsigned-long)) + +(defun allocate-space-in-foreign-segment (bytes) + (let* ((pagesize-1 (1- (gr-call* mach:vm_statistics *task-self*))) + (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1)) + (addr (int-sap *foreign-segment-free-pointer*)) + (new-ptr (+ *foreign-segment-free-pointer* bytes))) + (when (> new-ptr (+ foreign-segment-start foreign-segment-size)) + (error "Not enough memory left.")) + (setf *foreign-segment-free-pointer* new-ptr) + (gr-call* mach:vm_allocate *task-self* addr memory-needed nil) + addr)) + +#+sparc +(defun load-object-file (name) + (format t ";;; Loading object file...~%") + (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0) + (unless fd + (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno))) + (unwind-protect + (with-stack-alien (header exec #.(ext:c-sizeof 'exec)) + (mach:unix-read fd + (alien-sap (alien-value header)) + (truncate (alien-size (alien-value header)) + (bytes 1))) + (let* ((len-of-text-and-data + (+ (alien-access (exec-text (alien-value header))) + (alien-access (exec-data (alien-value header))))) + (memory-needed + (+ len-of-text-and-data + (alien-access (exec-bss (alien-value header))))) + (addr (allocate-space-in-foreign-segment memory-needed))) + (mach:unix-read fd addr len-of-text-and-data))) + (mach:unix-close fd)))) + +#+pmax +(ext:def-c-record filehdr + (magic ext:unsigned-short) + (nscns ext:unsigned-short) + (timdat ext:long) + (symptr ext:long) + (nsyms ext:long) + (opthdr ext:unsigned-short) + (flags ext:unsigned-short)) + +#+pmax +(ext:def-c-record aouthdr + (magic ext:short) + (vstamp ext:short) + (tsize ext:long) + (dsize ext:long) + (bsize ext:long) + (entry ext:long) + (text_start ext:long) + (data_start ext:long)) + +#+pmax +(defconstant filhsz 20) +#+pmax +(defconstant aouthsz 56) +#+pmax +(defconstant scnhsz 40) + +#+pmax +(defun load-object-file (name) + (format t ";;; Loading object file...~%") + (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0) + (unless fd + (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno))) + (unwind-protect + (with-stack-alien (filehdr filehdr #.(ext:c-sizeof 'filehdr)) + (with-stack-alien (aouthdr aouthdr #.(ext:c-sizeof 'aouthdr)) + (mach:unix-read fd + (alien-sap (alien-value filehdr)) + (truncate (alien-size (alien-value filehdr)) + (bytes 1))) + (mach:unix-read fd + (alien-sap (alien-value aouthdr)) + (truncate (alien-size (alien-value aouthdr)) + (bytes 1))) + (let* ((len-of-text-and-data + (+ (alien-access (aouthdr-tsize (alien-value aouthdr))) + (alien-access (aouthdr-dsize (alien-value aouthdr))))) + (memory-needed + (+ len-of-text-and-data + (alien-access (aouthdr-bsize (alien-value aouthdr))))) + (addr (allocate-space-in-foreign-segment memory-needed)) + (pad-size-1 (if (< (alien-access + (aouthdr-vstamp (alien-value aouthdr))) + 23) + 7 15))) + (mach:unix-lseek fd + (logandc2 (+ filhsz aouthsz + (* scnhsz + (alien-access + (filehdr-nscns + (alien-value filehdr)))) + pad-size-1) + pad-size-1) + mach:l_set) + (mach:unix-read fd addr len-of-text-and-data)))) + (mach:unix-close fd)))) + +(defun parse-symbol-table (name) + (format t ";;; Parsing symbol table...~%") + (let ((symbol-table (make-hash-table :test #'equal))) + (with-open-file (file name) + (loop + (let ((line (read-line file nil nil))) + (unless line + (return)) + (let* ((symbol (subseq line 11)) + (address (parse-integer line :end 8 :radix 16)) + (old-address (gethash symbol lisp::*foreign-symbols*))) + (unless (or (null old-address) (= address old-address)) + (warn "~S moved from #x~8,'0X to #x~8,'0X.~%" + symbol old-address address)) + (setf (gethash symbol symbol-table) address))))) + (setf lisp::*foreign-symbols* symbol-table))) (defun load-foreign (files &optional (libraries '("-lc")) - (linker "/usr/cs/bin/ld") - (base-file "/usr/misc/.lisp/bin/lisp") - (env lisp::original-lisp-environment)) + (linker "/usr/misc/.cmucl/lib/load-foreign.csh") + (base-file "/usr/misc/.cmucl/bin/lisp") + (env ext:*environment-list*)) "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 @@ -100,181 +190,40 @@ start up code for Lisp. The env argument is the Unix environment variable definitions for the invocation of the linker. The default is the environment passed to Lisp." - (if (null (listp files)) (setq files (list files))) - (format t "[Loading foreign files ~A ...~%" files) - (let ((tfl (if files (format nil "/tmp/L~d.~d" - (mach:unix-getuid) - (the fixnum (+ (the fixnum (mach:unix-getpid)) - file-count))) - base-file)) - (ofl (get-last-loaded-file file-count base-file)) - (addr (read-miscop-free-pointer))) - (when files - (setq file-count (the fixnum (1+ file-count))) - (format t " [Running ld ...") - (force-output t) - (let ((nfiles ())) - (dolist (f files) - (let* ((pn (merge-pathnames f *default-pathname-defaults*)) - (tn (probe-file pn))) - (push (if tn (namestring tn) f) nfiles))) - (setf files (nreverse nfiles))) - (run-program linker `("-N" "-A" ,ofl "-T" - ,(format nil "~X" (+ addr unix-header-size)) - "-o" ,tfl ,@files ,@libraries) - :env env :wait t :output t :error t) - (push tfl temporary-foreign-files) - (format t " done.]~%")) - (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) - (mach:unix-stat tfl) - (declare (ignore ino mode nlnk uid gid rdev)) - (when (null res) - (error "Could not stat intermediate file ~a, unix error: ~A." - tfl (mach:get-unix-error-msg dev))) - (format t " [Reading Unix object file ...") - (force-output t) - (multiple-value-bind (fd err) (mach:unix-open tfl mach:o_rdonly 0) - (when (null fd) - (error "Failed to open intermediate file ~A, unix error: ~A." - (mach:get-unix-error-msg err))) - (multiple-value-bind (bytes err2) - (mach:unix-read fd (int-sap addr) - len) - (when (or (null bytes) (not (eq bytes len))) - (if (null bytes) - (error "Read of intermediate file ~A failed, unix error: ~A" - tfl (mach:get-unix-error-msg err2)) - (error "Read of intermediate file ~A only read ~d of ~d bytes." - tfl bytes len)))) - (mach:unix-close fd))) - (format t " done.]~%") - (let ((fsize (logand (+ (load-object-file tfl addr files) 4) (lognot 3)))) - (when files (write-miscop-free-pointer (+ addr fsize))))) - (format t "done.]~%")) - -;;; Get-last-loaded-file attempts to find the file that was last loaded into -;;; Lisp. If one is found, load-foreign uses it as the bases for the initial -;;; symbol table. Otherwise, it uses the lisp startup code. - -(defun get-last-loaded-file (fc base-file) - (declare (fixnum fc)) - (do ((i (the fixnum (1- fc)) (1- i))) - ((< i 0) base-file) - (declare (fixnum i)) - (let ((tfl (format nil "/tmp/L~d.~d" (mach:unix-getuid) - (the fixnum (+ (the fixnum (mach:unix-getpid)) i))))) - (if (probe-file tfl) (return tfl))))) - -;;; Load-object-file, actually loads the object file created by ld. -;;; It makes sure that it is a legal object file. - -(defun load-object-file (file addr flag) - (format t " [Loading symbol table information ...") - (force-output t) - (let* ((sap (int-sap addr)) - (magic (read-cword sap 0)) - (text-size (read-cword sap 1)) - (idata-size (read-cword sap 2)) - (udata-size (read-cword sap 3)) - (symtab-size (read-cword sap 4)) - (epoint (read-cword sap 5)) - (treloc-size (read-cword sap 6)) - (dreloc-size (read-cword sap 7)) - (load-size (+ text-size idata-size udata-size unix-header-size)) - (symstart (+ text-size idata-size (if flag unix-header-size 2048))) - (strstart (+ symstart (the fixnum symtab-size)))) - (declare (fixnum magic text-size idata-size udata-size - symtab-size symstart strstart treloc-size - dreloc-size) - (ignore epoint)) - (unless (or (null flag) - (and (= magic unix-OMagic) (= treloc-size 0) (= dreloc-size 0))) - (error "File ~A is not a legal Unix object file." file)) - (read-symbol-table (%primitive sap+ sap symstart) symtab-size (%primitive sap+ sap strstart)) - (setq load-size (logand (the fixnum (+ load-size 8192)) (lognot 8191))) - (do ((ind (truncate (+ text-size idata-size unix-header-size) 2) - (1+ ind)) - (end (truncate udata-size 2))) - ((>= ind end)) - (%primitive 16bit-system-set sap ind 0)) - (format t " done.]~%") - load-size)) - -;;; Read-symbol-table reads the symbol table out of the object, making -;;; external symbols available to Lisp, so that they can be used to -;;; link to the C routines. - -(defun read-symbol-table (symstart symtab-size strstart) - (let ((end (%primitive sap+ symstart symtab-size))) - (do* ((se symstart (%primitive sap+ se symbol-table-entry-size)) - (si (logior (ash (%primitive 16bit-system-ref se 0) 16) - (%primitive 16bit-system-ref se 1)) - (logior (ash (%primitive 16bit-system-ref se 0) 16) - (%primitive 16bit-system-ref se 1))) - (st (%primitive 8bit-system-ref se 4) - (%primitive 8bit-system-ref se 4)) - (sv (logior (ash (%primitive 16bit-system-ref se 4) 16) - (%primitive 16bit-system-ref se 5)) - (logior (ash (%primitive 16bit-system-ref se 4) 16) - (%primitive 16bit-system-ref se 5)))) - ((not (%primitive pointer< se end))) - (declare (fixnum st)) - (when (or (= st (logior n_text n_ext)) - (= st (logior n_data n_ext)) - (= st (logior n_bss n_ext))) - (let* ((strend (%primitive find-character strstart si (+ si 512) 0))) - (when (null strend) - (error "Symbol table string didn't terminate.")) - (let ((strlen (the fixnum (- (the fixnum strend) (the fixnum si)))) - (offset 0) - (code NIL) - (str NIL)) - (declare (fixnum strlen offset)) - (when (eq (%primitive 8bit-system-ref strstart si) (char-code #\_)) - (setq offset (the fixnum (1+ offset))) - (when (eq (%primitive 8bit-system-ref strstart - (the fixnum (1+ (the fixnum si)))) - (char-code #\.)) - (setq code T) - (setq offset (the fixnum (1+ offset))))) - (setq str (make-string (the fixnum (- strlen offset)))) - (%primitive byte-blt strstart - (the fixnum (+ (the fixnum si) offset)) str 0 strlen) - (if (let ((x (ash sv (- (+ clc::type-shift-16 16))))) - (not (<= clc::first-pointer-type x clc::last-pointer-type))) - (let ((ste (gethash str foreign-symbols)) - (loc (int-sap sv))) - (cond ((null ste) - (setf (gethash str foreign-symbols) - (make-unix-ste :type (if code - (logior n_text - n_ext) st) - :location (if code nil loc)))) - (code - (setf (unix-ste-type ste) (logior n_text n_ext))) - (T - (setf (unix-ste-location ste) loc))))))))))) - -;;; Get-code-pointer accepts a simple string which should be the name -;;; of a C routine that has already been loaded into the Lisp core image. -;;; This name should use the correct capitalization of the C name without -;;; the default underscore. -(defun get-code-pointer (name) - (let ((ste (gethash name foreign-symbols))) - (when (null ste) - (error "There is no foreign function named ~A loaded." name)) - (when (not (eq (unix-ste-type ste) (logior n_text n_ext))) - (error "~A is a foreign external variable, not a foreign function." name)) - (unix-ste-location ste))) + (let ((output-file (pick-temporary-file-name)) + (symbol-table-file (pick-temporary-file-name)) + (error-output (make-string-output-stream))) + (format t ";;; Running ~A...~%" linker) + (force-output) + (let ((proc (ext:run-program linker + (list* (or *previous-linked-object-file* + base-file) + (format nil "~X" + *foreign-segment-free-pointer*) + output-file + symbol-table-file + (append (if (atom files) + (list files) + files) + libraries)) + :env env + :input nil + :output error-output + :error :output))) + (unless proc + (error "Could not run ~S" linker)) + (unless (zerop (ext:process-exit-code proc)) + (system:serve-all-events 0) + (error "~S failed:~%~A" + linker (get-output-stream-string error-output))) + (load-object-file output-file) + (parse-symbol-table symbol-table-file) + (mach:unix-unlink symbol-table-file) + (let ((old-file *previous-linked-object-file*)) + (setf *previous-linked-object-file* output-file) + (when old-file + (mach:unix-unlink old-file))))) + (format t ";;; Done.~%")) -;;; Get-data-pointer is similar to get-code-pointer, except it returns the -;;; address of a foreign global variable. -(defun get-data-pointer (name) - (let ((ste (gethash name foreign-symbols))) - (when (null ste) - (error "There is no foreign variable named ~A loaded." name)) - (when (eq (unix-ste-type ste) (logior n_text n_ext)) - (error "~A is a foreign function, not a foreign variable." name)) - (unix-ste-location ste)))