Newer
Older
(code (pop-stack)))
(setf (code-header-ref code (clone-arg)) value)
(let ((type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(offset (read-arg 4)))
(declare (type index offset))
(unless (zerop (logand offset vm:lowtag-mask))
(error "Unaligned function object, offset = #x~X." offset))
(let ((fun (%primitive compute-function code-object offset)))
(%primitive set-function-self fun fun)
(%primitive set-function-next fun
(%primitive code-entry-points code-object))
(%primitive set-code-entry-points code-object fun)
(%primitive set-function-name fun name)
(%primitive set-function-arglist fun arglist)
(%primitive set-function-type fun type)
(when *load-print*
(load-fresh-line)
(format t "~S defined~%" fun))
;;; These two variables are initially filled in by Genesis.
(defvar *initial-assembler-routines*)
(defvar *initial-foreign-symbols*)
(defvar *assembler-routines* (make-hash-table :test #'eq))
(defvar *foreign-symbols* (make-hash-table :test #'equal))
(defun loader-init ()
(dolist (routine *initial-assembler-routines*)
(setf (gethash (car routine) *assembler-routines*) (cdr routine)))
(dolist (symbol *initial-foreign-symbols*)
(setf (gethash (car symbol) *foreign-symbols*) (cdr symbol)))
(makunbound '*initial-assembler-routines*)
(makunbound '*initial-foreign-symbols*))
(defun foreign-symbol-address (symbol)
(multiple-value-bind
(value found)
(gethash symbol *foreign-symbols* 0)
(unless found
(error "Unknown foreign symbol: ~S" symbol))
(int-sap value)))
(define-fop (fop-foreign-fixup 147)
(let* ((kind (pop-stack))
(code-object (pop-stack))
(len (read-arg 1))
(sym (make-string len)))
(read-n-bytes *fasl-file* sym 0 len)
(multiple-value-bind
(value found)
(gethash sym *foreign-symbols* 0)
(unless found
(error "Unknown foreign symbol: ~S" sym))
(vm:fixup-code-object code-object (read-arg 4) value kind))
code-object))
(define-fop (fop-assembler-code 144)
(error "Cannot load assembler code."))
(define-fop (fop-assembler-routine 145)
(error "Cannot load assembler code."))
(define-fop (fop-assembler-fixup 148)
(let ((routine (pop-stack))
(kind (pop-stack))
(code-object (pop-stack)))
(multiple-value-bind
(value found)
(gethash routine *assembler-routines*)
(unless found
(error "Undefined assembler routine: ~S" routine))
(vm:fixup-code-object code-object (read-arg 4) value kind))
code-object))