Newer
Older
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.18 1992/08/03 12:44:38 wlott Exp $")
;;; **********************************************************************
;;;
;;;
;;; 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 hashtable translating ENTRY-INFO structures to a list of pairs
;; (<code object> . <offset>) describing the places that need to be
;; backpatched to point to the function for ENTRY-INFO.
(patch-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))
;;; NOTE-FUNCTION -- Internal.
;;;
;;; Note the existance of FUNCTION.
;;;
(defun note-function (info function object)
(declare (type function function)
(type core-object object))
(let ((patch-table (core-object-patch-table object)))
(dolist (patch (gethash info patch-table))
(setf (code-header-ref (car patch) (the index (cdr patch))) function))
(remhash info patch-table))
(setf (gethash info (core-object-entry-table object)) function)
(undefined-value))
;;; 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))
;;; 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)))
(multiple-value-bind
(value found)
(ecase flavor
(:assembly-routine
(assert (symbolp name))
(gethash name lisp::*assembler-routines*))
(:foreign
(assert (stringp name))
(gethash name lisp::*foreign-symbols*)))
(unless found
(error (ecase flavor
(:assembly-routine "Undefined assembler routine: ~S")
(:foreign "Unknown foreign symbol: ~S"))
name))
(vm:fixup-code-object code offset value kind)))))
;;; REFERENCE-CORE-FUNCTION -- Internal
;;;
;;; Stick a reference to the function Fun in Code-Object at index I. If the
;;; function hasn't been compiled yet, make a note in the Patch-Table.
;;;
(defun reference-core-function (code-obj i fun object)
(declare (type core-object object) (type functional fun)
(type index i))
(let* ((info (leaf-info fun))
(found (gethash info (core-object-entry-table object))))
(if found
(setf (code-header-ref code-obj i) found)
(push (cons code-obj i)
(gethash info (core-object-patch-table object)))))
(undefined-value))
;;; 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 trace-table fixups object)
(type core-object object))
(without-gcing
(let* ((2comp (component-info component))
(constants (ir2-component-constants 2comp))
(trace-table (pack-trace-table trace-table))
(trace-table-len (length trace-table))
(trace-table-bits (* trace-table-len bits-per-entry))
(total-length (+ length (ceiling trace-table-bits vm:byte-bits)))
(box-num (- (length constants) vm:code-trace-table-offset-slot))
(code-obj (%primitive allocate-code-object box-num total-length))
(declare (type index box-num total-length))
(new-assem:segment-map-output
segment
#'(lambda (sap amount)
(declare (type system-area-pointer sap)
(type index amount))
(system-area-copy sap 0 fill-ptr 0
(* amount vm:byte-bits))
(setf fill-ptr (sap+ fill-ptr amount))))
(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))
(setf (code-header-ref code-obj vm:code-debug-info-slot) info))
(setf (code-header-ref code-obj vm:code-trace-table-offset-slot) length)
(copy-to-system-area trace-table (* vm:vector-data-offset vm:word-bits)
(do ((index vm:code-constants-offset (1+ index)))
((>= index (length constants)))
(let ((const (aref constants index)))
(setf (code-header-ref code-obj index)
(constant-value const)))
(reference-core-function code-obj index
(cdr const) object))
(:fdefinition
(setf (code-header-ref code-obj index)
(lisp::fdefinition-object (cdr const) t))))))))))
(defun make-core-byte-component (segment constants xeps object)
(declare (type new-assem:segment segment)
(type vector constants)
(type list xeps)
(type core-object object))
(without-gcing
(let* ((num-constants (length constants))
(length (byte-output-length segment))
(code-obj (%primitive allocate-code-object
(the index (1+ num-constants))
length))
(fill-ptr (code-instructions code-obj)))
(declare (type index length)
(type system-area-pointer fill-ptr))
(new-assem:segment-map-output
segment
#'(lambda (sap amount)
(declare (type system-area-pointer sap)
(type index amount))
(system-area-copy sap 0 fill-ptr 0
(* amount vm:byte-bits))
(setf fill-ptr (sap+ fill-ptr amount))))
(dolist (noise xeps)
(let ((xep (cdr noise)))
(setf (byte-xep-component xep) code-obj)
(note-function (lambda-info (car noise))
(make-byte-compiled-function xep)
object)))
(dotimes (index num-constants)
(let ((const (aref constants index))
(code-obj-index (+ index vm:code-constants-offset)))
(etypecase const
(null)
(constant
(setf (code-header-ref code-obj code-obj-index)
(constant-value const)))
(list
(ecase (car const)
(:entry
(reference-core-function code-obj code-obj-index (cdr const)
object))
(:fdefinition
(setf (code-header-ref code-obj code-obj-index)
(lisp::fdefinition-object (cdr const) t)))
(:type-predicate
(setf (code-header-ref code-obj code-obj-index)
(load-type-predicate (type-specifier (cdr const)))))
(:xep
(let ((xep (cdr (assoc (cdr const) xeps :test #'eq))))
(assert xep)
(setf (code-header-ref code-obj code-obj-index) xep))))))))))
(undefined-value))
;;; CORE-CALL-TOP-LEVEL-LAMBDA -- Interface
;;;
;;; Call the top-level lambda function dumped for Entry, returning the
;;; values. Entry may be a :TOP-LEVEL-XEP functional.
(declare (type functional entry) (type core-object object))
(funcall (or (gethash (leaf-info entry)
(core-object-entry-table object))
(error "Unresolved forward reference."))))
;;; FIX-CORE-SOURCE-INFO -- Interface
;;;
;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
;;; SOURCE-INFO list. We also check that there are no outstanding forward
;;; references to functions.
(defun fix-core-source-info (info object source-info)
(assert (zerop (hash-table-count (core-object-patch-table object))))
(dolist (sinfo res)
(setf (debug-source-info sinfo) source-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 (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 (sap> 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-bout (stream byte)
(declare (type code-instruction-stream stream)
(type (unsigned-byte 8) byte))
(let* ((current (code-instruction-stream-current stream))
(new (sap+ current 1)))
(when (sap> new (code-instruction-stream-end stream))
(error "Writing another byte to ~S would cause it to overflow."
stream))
(setf (sap-ref-8 current 0) byte)
(setf (code-instruction-stream-current stream) new)))