/[cl-x86-asm]/cl-x86-asm/symbols.lisp
ViewVC logotype

Contents of /cl-x86-asm/symbols.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Mar 7 23:42:19 2008 UTC (6 years, 1 month ago) by jconnors
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +88 -81 lines
Cleaned up indentation, added test cases.
1
2 (in-package :cl-x86-asm)
3
4 ;; -- symbol table handling -----------------------------------------------------
5
6 ;; symbol table maps to cl package for each segment. we maintain a list
7 ;; of packages so that we can iterate over all symbols as needed
8
9 (defparameter *x86-symbol-packages* nil)
10 (defparameter *current-segment-name* nil)
11 (defparameter *current-segment-package* nil)
12
13 ;; segments -----------------------------------------------------
14
15
16 (defclass segment
17 ()
18 ((alignment
19 :initform 2
20 :initarg :alignment
21 :reader alignment-of)
22 (symbol-table
23 :initform nil
24 :accessor symbols-of))
25 (:documentation "Base class for file segments"))
26
27 (defclass data-segment
28 (segment)
29 ((contents
30 :initform (make-array '(4096)
31 :element-type '(unsigned-byte 8)
32 :fill-pointer 0)
33 :accessor contents-of))
34 (:documentation "An ELF segment containing actual data"))
35
36 (defclass bss-segment
37 (segment)
38 ((size :initform 0 :accessor bss-size-of))
39 (:documentation "An ELF segment intialised at run/load time"))
40
41
42
43 (defun x86-symbol-package-name (segment-name)
44 "Given a segment name, return a lisp package name to contain the symbols in the segment,"
45 (concatenate 'string (string segment-name) "-x86-symbol-package"))
46
47 ;; set the current segment context
48 (defun set-current-segment (segment-name)
49 "(set-current-segment segment-name) sets the assembler to emit code
50 or data into the given segement"
51 (setf *current-segment-name* segment-name)
52 (setf *current-segment-package*
53 (find-package (x86-symbol-package-name segment-name))))
54
55 (defun fresh-package (designator)
56 "Return a package if it exists, otherwise create it."
57 (let ((result (find-package designator)))
58 (if result
59 result
60 (make-package designator))))
61
62 ;; create a segment, optionally making it the current segment
63 ;; segment-type must be 'data-segment or 'bss-segment
64 (defun make-segment (segment-name &key set-to-current segment-type)
65 "(make-segment segment-name :set-to-current t/nil segment-type) Creates
66 a segment for our code to be assembled into. It may be a data-segment or bss-segment
67 currently"
68 (assert (member segment-type '(:data-segment :bss-segment)))
69 (let ((segment-package (fresh-package (x86-symbol-package-name segment-name)))
70 (segment-object (make-instance (find-symbol (string segment-type) :cl-x86-asm))))
71 ;; add segment-package to master list
72 (push segment-package *x86-symbol-packages*)
73 ;; add the package to the object slot
74 (setf (symbols-of segment-object) segment-package)
75 ;; bind a symbol in the package to the segment object
76 (setf (symbol-value (intern "segment-object" segment-package)) segment-object)
77 (when set-to-current
78 (set-current-segment segment-name))))
79
80 ;; get the object associated with the current segment
81 (defun get-segment-object ()
82 "(get-segment-object) Every segment has a segment object inside it's package
83 which we assemble actual emitted data to"
84 (symbol-value (intern "segment-object" *current-segment-package*)))
85
86 (defun get-segment-position ()
87 "(get-segment-position)
88 returns the position the next byte will be emitted to in the current segment"
89 (length (contents-of (get-segment-object))))
90
91 ;; symbols
92
93 (defun make-assembler-symbol (symbol-name)
94 "(make-assember-symbol symbol-name) creates a symbol with the given
95 name in the current segments package, and gives it a default value and type"
96 (multiple-value-bind
97 (package-symbol exists)
98 (intern symbol-name *current-segment-package*)
99 (unless exists
100 (setf (symbol-value package-symbol) 0)
101 (setf (get package-symbol 'reference-type) :dword))
102 package-symbol))
103
104 ;; add a symbol reference to a segment
105 (defun add-symbol-reference (symbol-name)
106 "(add-symbol-reference symbol-name)
107 Called when the assembler finds a symbol refrence in the current
108 program. Adds the location of the reference to the symbol plist."
109 (format *debug-io* "Referring to symbol ~A~&" symbol-name)
110 (let* ((package-symbol
111 (make-assembler-symbol symbol-name))
112 (symbol-references
113 (get package-symbol 'reference-list nil)))
114 (setf (get package-symbol 'reference-list)
115 (append symbol-references (get-segment-position)))))
116
117 ;; set the value of a symbol
118 (defun add-symbol-definition (symbol-name &key (symbol-type :dword))
119 "(add-symbol-reference symbol-name)
120 Called when the assembler finds a symbol definition in the current
121 segment. Sets the symbol value to the defined value and the type
122 to the symbol plist"
123 (format *debug-io* "Defining symbol ~A~&" symbol-name)
124 (let* ((package-symbol
125 (make-assembler-symbol symbol-name)))
126 (setf (symbol-value package-symbol) (get-segment-position))
127 (setf (get package-symbol 'reference-type) symbol-type)))
128
129
130 (defun fixup-symbol-reference (sym-value sym-type sym-ref)
131 "(fixup-symbol-reference symbol-name symbol-value symbol-type symbol-reference
132 Fixes up an individual reference in the segment-contents vector"
133 (flet
134 ;; accessors to break up type specifier (car = kind, cadr = size)
135 ((reference-size (ref)
136 (second ref))
137 ;; (reference-kind (ref)
138 ;; (first ref))
139 )
140 ;; transform symbol to sequence
141 (let ((sym-value-seq
142 (decompose-to-n-bytes sym-value (reference-size sym-type))))
143 ;; poke sequence into contents
144 (loop
145 for i from 0 below (length sym-value-seq)
146 do (setf (aref (contents-of (get-segment-object)) (+ sym-ref i))
147 (elt sym-value-seq i))))))
148
149
150 (defun fixup-symbol-references (sym-name)
151 "(fixup-symbol-references (sym-name)
152 Fixes up all references to a symbol in the current segment"
153 (let ((sym-value (symbol-value sym-name))
154 (sym-type (get sym-name 'reference-type))
155 (sym-references (get sym-name 'reference-list)))
156 (mapcar
157 #'(lambda (r) (fixup-symbol-reference sym-value sym-type r))
158 sym-references)))
159
160
161 (defun fixup-segment-symbols ()
162 "(fixup-segment-symbols ()
163 Fixup all symbols in the current segment"
164 (labels ((list-segment-symbols ()
165 (loop
166 for sym being each present-symbol in *current-segment-package*
167 collect (symbol-name sym))))
168 (let ((seg-sym-names (list-segment-symbols)))
169 (mapcar #'fixup-symbol-references seg-sym-names))))
170
171
172 ;; convience function to emit stream of bytes to segment
173 ;; (could be done with below function, but..)
174 (defun emit-bytes-to-segment (data)
175 "(emit-bytes-to-segment data) assemble the sequence data into the current segment
176 as a stream of bytes"
177 (map nil
178 #'(lambda (x) (vector-push-extend x (contents-of (get-segment-object))))
179 data))
180
181 ;; emit data to our current segment
182 (defun emit-data-to-segment (data &key (data-size 4))
183 "(emit-data-to-segment data :data-size n) Emits data to segment as a sequence
184 of bytes, assuming it to be of the size given, if padding or alingmnet is needed"
185 (format *debug-io* "Emitting ~A to current segment~&" data)
186 (labels
187 ((add-to-segment-data (b)
188 (let ((segment-contents
189 (contents-of (get-segment-object))))
190 (ctypecase b
191 (integer
192 (mapcar #'(lambda (x) (vector-push-extend x segment-contents))
193 (decompose-to-n-bytes b data-size)))
194 (character
195 (vector-push-extend (char-code b) segment-contents))
196 (string
197 (map nil #'add-to-segment-data b)
198 (add-to-segment-data 0))))))
199 ;; symbol?
200 (map nil #'add-to-segment-data data)))
201
202 (defun print-segment ()
203 "(print-segment) Diagnostic function that lets us look at the contents of a segment"
204 (let ((segment-object
205 (get-segment-object)))
206 (format t "Segment type ~A~&" (type-of segment-object))
207 (ctypecase segment-object
208 (data-segment
209 (progn
210 (format t "Segment size ~8,'0X bytes~&" (length (contents-of segment-object)))
211 (loop
212 for i = 0 then (1+ i)
213 for bytes across (contents-of segment-object)
214 do
215 (if (zerop (mod i 8))
216 (format t "~&~2,'0X" (aref (contents-of segment-object) i))
217 (format t " ~2,'0X" (aref (contents-of segment-object) i))))))
218 (bss-segment
219 (format t "Bss segment containing ~8,'0X bytes~&" (bss-size-of segment-object))))))
220
221
222 ;; all your bases are belong to us
223 (defun destroy-all-segments ()
224 "(destroy-all-segments) Wipe everything out when we have finished"
225 (loop
226 for package in *x86-symbol-packages*
227 do
228 (delete-package package))
229 (setf *current-segment-package* nil)
230 (setf *current-segment-name* nil)
231 (setf *x86-symbol-packages* nil))
232
233
234
235

  ViewVC Help
Powered by ViewVC 1.1.5