Skip to content
Snippets Groups Projects
Commit 9d39632f authored by wlott's avatar wlott
Browse files

Totally re-written for the new system.

parent 877439a6
No related branches found
No related tags found
No related merge requests found
;;; -*- 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)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment