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.16 1992/07/22 23:35:36 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))
(trace-table-sap
(cond ((backend-featurep :new-assembler)
(let ((fill-ptr (code-instructions code-obj)))
(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))))
fill-ptr))
(t
(let ((inst-stream (make-code-instruction-stream code-obj)))
(setf fixups (assem:emit-code-vector inst-stream segment))
(code-instruction-stream-current inst-stream))))))
(declare (type index box-num total-length))
(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)
trace-table-sap 0 trace-table-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))))
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
(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)))
(: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)))