symbols.lisp

   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