Newer
Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
;;; -*- 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.
;;;
#+new-compiler
(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.
;;;
#+new-compiler
(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.
;;;
#+new-compiler
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(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.
;;;
#+new-compiler
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
(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.
;;;
#+new-compiler
(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.
;;;
#+new-compiler
(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
#+new-compiler
(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)
#+new-compiler
(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)))
#+new-compiler
(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)))
#+new-compiler