Skip to content
Snippets Groups Projects
core.lisp 7.33 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- 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.
;;;
wlott's avatar
wlott committed
(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.
;;;
wlott's avatar
wlott committed
(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.
;;;
wlott's avatar
wlott committed
(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.
;;;
wlott's avatar
wlott committed
(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.
;;;
wlott's avatar
wlott committed
(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.
;;;
wlott's avatar
wlott committed
(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

wlott's avatar
wlott committed
(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)

wlott's avatar
wlott committed
(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)))

wlott's avatar
wlott committed
(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)))

wlott's avatar
wlott committed
(defun code-inst-stream-misc (stream method &optional arg1 arg2)
  (declare (ignore arg1 arg2))
  (case method
    (:close
     (lisp::set-closed-flame stream))
    (t
     nil)))