diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp index 379056ad475e93d624c9ff61bcb3614f60779cca..dad9005a56e4d29350f8e413c6f37bd7af3624e7 100644 --- a/compiler/generic/core.lisp +++ b/compiler/generic/core.lisp @@ -7,7 +7,7 @@ ;;; 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.8 1991/02/20 15:17:09 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.9 1991/03/20 03:02:56 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -65,8 +65,7 @@ (entry-info-type entry)) (dolist (patch (gethash entry patch-table)) - (%primitive code-constant-set (car patch) (the index (cdr patch)) - res)) + (setf (code-header-ref (car patch) (the index (cdr patch))) res)) (remhash entry patch-table) (setf (gethash entry (core-object-entry-table object)) res))) (undefined-value)) @@ -112,7 +111,7 @@ (let* ((info (leaf-info fun)) (found (gethash info (core-object-entry-table object)))) (if found - (%primitive code-constant-set code-obj i found) + (setf (code-header-ref code-obj i) found) (push (cons code-obj i) (gethash info (core-object-patch-table object))))) (undefined-value)) @@ -123,17 +122,24 @@ ;;; Dump a component to core. We pass in the assembler fixups, code vector ;;; and node info. ;;; -(defun make-core-component (component segment length object) +(defun make-core-component (component segment length trace-table object) (declare (type component component) (type index length) + (list trace-table) (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))) + (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:word-bits))) + (box-num (- (length constants) vm:code-trace-table-offset-slot)) + (code-obj (%primitive allocate-code-object box-num total-length)) + (inst-stream (make-code-instruction-stream code-obj)) + (fixups (emit-code-vector inst-stream segment))) + (declare (type index box-num total-length)) + (do-core-fixups code-obj fixups) (dolist (entry (ir2-component-entries 2comp)) @@ -141,24 +147,26 @@ (let ((info (debug-info-for-component component))) (push info (core-object-debug-info object)) - (%primitive set-code-debug-info code-obj info)) + (setf (code-header-ref code-obj vm:code-debug-info-slot) info)) - (dotimes (i box-num) - (let ((const (aref constants (+ i vm:code-constants-offset)))) + (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) + (code-instruction-stream-current inst-stream) 0 + trace-table-bits) + + (do ((index vm:code-constants-offset (1+ index))) + ((>= index (length constants))) + (let ((const (aref constants index))) (etypecase const (null) (constant - (%primitive code-constant-set code-obj i - (constant-value const))) + (setf (code-header-ref code-obj index) + (constant-value const))) (list (ecase (car const) (:entry - (reference-core-function code-obj i (cdr const) object)) - #+nil - (:label - (%primitive header-set code-obj i - (+ (label-location (cdr const)) - clc::i-vector-header-size)))))))))) + (reference-core-function code-obj index + (cdr const) object))))))))) (undefined-value)) @@ -202,9 +210,7 @@ (:constructor make-code-instruction-stream (code-object &aux - (current (truly-the system-area-pointer - (%primitive code-instructions - code-object))) + (current (code-instructions code-object)) (end (sap+ current (* (%primitive code-code-size code-object)