diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp new file mode 100644 index 0000000000000000000000000000000000000000..289e98b40604b19698dad86c451f96443d311cee --- /dev/null +++ b/compiler/generic/core.lisp @@ -0,0 +1,225 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; 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). +;;; ********************************************************************** +;;; +;;; +;;; This file contains stuff that knows how to load compiled code directly +;;; into core, e.g. incremental compilation. +;;; +(in-package 'c) + + +;;; The CORE-OBJECT structure holds the state needed to resolve cross-component +;;; references during in-core compilation. +;;; +(defstruct (core-object + (:constructor make-core-object ()) + (:print-function + (lambda (s stream d) + (declare (ignore s d)) + (format stream "#<Core-Object>")))) + ;; + ;; A hashtable translating ENTRY-INFO structures to the corresponding actual + ;; FUNCTIONs for functions in this compilation. + (entry-table (make-hash-table :test #'eq) :type hash-table) + ;; + ;; A list of all the DEBUG-INFO objects created, kept so that we can + ;; backpatch with the source info. + (debug-info () :type list)) + + +;;; MAKE-FUNCTION-ENTRY -- Internal +;;; +;;; Make a function entry, filling in slots from the ENTRY-INFO. +;;; +(defun make-function-entry (entry code-obj object) + (declare (type entry-info entry) (type core-object object)) + (let ((offset (label-position (entry-info-offset entry)))) + (declare (type index offset)) + (unless (zerop (logand offset vm:lowtag-mask)) + (error "Unaligned function object, offset = #x~X." offset)) + (let ((res (%primitive compute-function code-obj offset))) + (%primitive set-function-self res res) + (%primitive set-function-next res + (%primitive code-entry-points code-obj)) + (%primitive set-code-entry-points code-obj res) + (%primitive set-function-name res (entry-info-name entry)) + (%primitive set-function-arglist res + (entry-info-arguments entry)) + (%primitive set-function-type res + (entry-info-type entry)) + (setf (gethash entry (core-object-entry-table object)) res))) + (undefined-value)) + +;;; CORE-FUNCTION-OR-LOSE -- Internal +;;; +;;; Get the function for a function entry that has been dumped to core. +;;; +(defun core-function-or-lose (fun object) + (declare (type clambda fun) (type core-object object)) + (let ((res (gethash (leaf-info fun) (core-object-entry-table object)))) + (assert res () "Unresolved forward function reference?") + res)) + + +;;; DO-CORE-FIXUPS -- Internal +;;; +;;; Do "load-time" fixups on the code vector. +;;; +(defun do-core-fixups (code fixups) + (declare (list fixups)) + (dolist (info fixups) + (let* ((kind (first info)) + (fixup (second info)) + (name (fixup-name fixup)) + (flavor (fixup-flavor fixup)) + (offset (third info))) + (ecase kind + (:addi + ;; ### The lui fixup assumes that an addi follows it. + ) + (:lui + (ecase flavor + (:assembly-routine + (assert (symbolp name)) + (multiple-value-bind + (value found) + (gethash name lisp::*assembler-routines*) + (unless found + (error "Undefined assembler routine: ~S" name)) + (lisp::fixup-code-object code offset value))) + (:foreign + (assert (stringp name)) + (multiple-value-bind + (value found) + (gethash name lisp::*foreign-symbols* 0) + (unless found + (error "Unknown foreign symbol: ~S" name)) + (lisp::fixup-code-object code offset value))))) + #+nil + (:jump + ;; ### Need to impliment this. + ))))) + +;;; MAKE-CORE-COMPONENT -- Interface +;;; +;;; Dump a component to core. We pass in the assembler fixups, code vector +;;; and node info. +;;; +(defun make-core-component (component segment length object) + (declare (type component component) + (type index length) + (type core-object object)) + (without-gcing + (let* ((2comp (component-info component)) + (constants (ir2-component-constants 2comp)) + (box-num (- (length constants) vm:code-constants-offset)) + (code-obj (%primitive allocate-code-object box-num length)) + (fixups (emit-code-vector (make-code-instruction-stream code-obj) + segment))) + (do-core-fixups code-obj fixups) + + (dolist (entry (ir2-component-entries 2comp)) + (make-function-entry entry code-obj object)) + + (let ((info (debug-info-for-component component))) + (push info (core-object-debug-info object)) + (%primitive set-code-debug-info code-obj info)) + + (dotimes (i box-num) + (let ((const (aref constants (+ i vm:code-constants-offset)))) + (etypecase const + (null) + (constant + (%primitive code-constant-set code-obj i + (constant-value const))) + (list + (ecase (car const) + (:entry + (%primitive code-constant-set code-obj i + (core-function-or-lose (cdr const) object))) + #+nil + (:label + (%primitive header-set code-obj i + (+ (label-location (cdr const)) + clc::i-vector-header-size)))))))))) + (undefined-value)) + + +;;; CORE-CALL-TOP-LEVEL-LAMBDA -- Interface +;;; +;;; Call the top-level lambda function dumped for Entry, returning the +;;; values. +;;; +(defun core-call-top-level-lambda (entry object) + (declare (type clambda entry) (type core-object object)) + (funcall (core-function-or-lose entry object))) + + +;;; FIX-CORE-SOURCE-INFO -- Interface +;;; +;;; Backpatch all the DEBUG-INFOs dumped so far with the specified +;;; SOURCE-INFO list. +;;; +(defun fix-core-source-info (info object) + (declare (type source-info info) (type core-object object)) + (let ((res (debug-source-for-info info))) + (dolist (info (core-object-debug-info object)) + (setf (compiled-debug-info-source info) res)) + (setf (core-object-debug-info object) ())) + (undefined-value)) + + +;;;; Code-instruction-streams + +(defstruct (code-instruction-stream + (:print-function %print-code-inst-stream) + (:include stream + (lisp::sout #'code-inst-stream-sout) + (lisp::misc #'code-inst-stream-misc)) + (:constructor make-code-instruction-stream + (code-object + &aux + (current (truly-the system-area-pointer + (%primitive code-instructions + code-object))) + (end (sap+ current + (* (%primitive code-code-size + code-object) + vm:word-bytes)))))) + code-object + current + end) + +(defun %print-code-inst-stream (code-inst-stream stream depth) + (declare (ignore depth)) + (format stream "#<Code Instruction Stream for ~S>" + (code-instruction-stream-code-object code-inst-stream))) + +(defun code-inst-stream-sout (stream string start end) + (let* ((start (or start 0)) + (end (or end (length string))) + (length (- end start)) + (current (code-instruction-stream-current stream)) + (new (sap+ current length))) + (when (pointer> new (code-instruction-stream-end stream)) + (error "Writing ~D bytes to ~S would cause it to overflow." + length stream)) + (copy-to-system-area string (+ (* start vm:byte-bits) + (* vm:vector-data-offset vm:word-bits)) + current 0 + (* length vm:byte-bits)) + (setf (code-instruction-stream-current stream) new))) + +(defun code-inst-stream-misc (stream method &optional arg1 arg2) + (declare (ignore arg1 arg2)) + (case method + (:close + (lisp::set-closed-flame stream)) + (t + nil)))