x86assembler.lisp

   1
   2
   3 (in-package :cl-x86-asm)
   4
   5 ;; x86 can assemble in one of two modes BITS32 or BITS16
   6 (defparameter *current-bits-size* 32)
   7
   8 ;; switch between modes
   9 (defun switch-bits ()
  10   "(switch-bits) switch assembly mode between 32 bits and 16"
  11   (if (= *current-bits-size* 32)
  12       (setf *current-bits-size* 16)
  13       (setf *current-bits-size* 32)))
  14
  15 ;; -- the actual assembler -----------------------------------------------------
  16
  17
  18
  19 ;; -- the actual assembler -----------------------------------------------------
  20
  21 ;; to do -- lookup across different segments?
  22 ;; to do -- character operands?
  23 (defun operand-value (operand)
  24   "(operand-value operand) - given operand which may be a number or a symbol
  25 then reduce to it's numeric value"
  26   (cond
  27     ((numberp operand)
  28      operand)
  29     ((symbolp operand)
  30      (let ((result
  31             (find-symbol (symbol-name operand)
  32                          *current-segment-package*)))
  33        (if result
  34            (symbol-value result)
  35            (let ((result
  36                   (find-symbol
  37                    (symbol-name operand) 'keyword)))
  38              (if result
  39                  result
  40                  (error "Invalid operand ~A " operand))))))
  41     (t (error "Invalid operand ~A " operand))))
  42
  43 (defun operands-match-types-p (operands types)
  44   "(is-operand-type-p operand-type operand) Given an operand type (eg :reg32)
  45 and an operand (eg :EAX), returns t if that operand is of the correct type"
  46   (labels
  47       ((operand-matches-type-p (op ty)
  48          (funcall
  49           (cadr (assoc ty *operand-type-checkers*))
  50           (operand-value op))))
  51     (reduce
  52      #'(lambda (a b) (and a b))
  53      (mapcar
  54       #'operand-matches-type-p operands types))))
  55
  56 (defun encoding-length (encoding)
  57   "(encoding-length encoding) -- return the 'length' or weight of an encoding
  58   used when disambiguating potentially ambigous encodings"
  59   (+ (length encoding)
  60      (if (eq :ib (first (last encoding))) 1 0)
  61      (if (eq :iw (first (last encoding))) 2 0)
  62      (if (eq :id (first (last encoding))) 4 0)))
  63
  64 (defun one-description-p
  65     (descriptions)
  66   "(one-description-p descriptions-list) Quickie predicate to
  67 check if we have one description left in our candidate list"
  68   (= (length descriptions) 1))
  69
  70 (defun filter-descriptions-by-number (operands descriptions)
  71   "(filter-descriptions-by-number operands descriptions) Given an
  72   operand list and a list of possible descriptions: pairs then
  73   return only those where the number of operands in the
  74   descriptions matches the number of operands given"
  75   (loop
  76      for (types encoding) in descriptions
  77      when (or (= (length types) (length operands))
  78               (and (zerop (length operands)) (eq (first types) :|none|)))
  79      collect (list types encoding)))
  80
  81 (defun filter-descriptions-by-type (operands descriptions)
  82   "(filter-descriptions-by-type operands descriptions) Return
  83 only those descriptions that match the types of the operands"
  84   (loop
  85      for (types encoding) in descriptions
  86      when (operands-match-types-p operands types)
  87      collect (list types encoding)))
  88
  89 (defun filter-descriptions-by-simplicity (operands descriptions)
  90   "(pick-simplest-description descriptions) Look for a description with an operand
  91 type that is a literal register keyword - an automatic win"
  92   (declare (ignore operands) (optimize (debug 3) (safety 1) (compilation-speed 0) (speed 0)))
  93   (if
  94    (loop
  95       for (types encoding) in descriptions
  96       for index = 0 then (1+ index)
  97       when (contains-keyword '(:STO :CX :ECX :DX :CL :AL :AX :EAX)  encoding)
  98       collect (list types encoding))
  99    descriptions)) ;; if we don't find anything, pass along to the next filter
 100
 101
 102 (defun pick-smallest-description (descriptions)
 103   "(filter-descriptions-by-type operands descriptions)
 104 Return the description that is likely to result in the
 105 smallest possible encoding"
 106   (let
 107       ((candidate-index 0))
 108     (loop
 109        for (types encoding) in descriptions
 110        for index = 0 then (1+ index)
 111        when (< (encoding-length encoding)
 112                (encoding-length
 113                 (second (nth index descriptions))))
 114        do
 115        (setf candidate-index index))
 116     (nth candidate-index descriptions)))
 117
 118 ;; to do ? what if we *still* have alternate encodings
 119 ;; adfter going through *those* filters?
 120
 121 (defun find-correct-description (operands
 122                                  candidate-descriptions)
 123   "(find-correct-description operands candidate-descrptions)
 124 Given a list of operands for an instruction and a list of possible
 125 descriptions as a list of (types encoding) pair lists then find
 126 the description which most likely satisfies the operands"
 127   (macrolet ((with-description-filter (filterfn &rest body)
 128                `(let ((candidate-descriptions
 129                        (apply  ,filterfn (list operands candidate-descriptions))))
 130                   (format *debug-io* "Filtered Descriptions ~A~&"
 131                           candidate-descriptions)
 132                   (if (one-description-p candidate-descriptions)
 133                       (first candidate-descriptions)
 134                       ,@body))))
 135     (format *debug-io*
 136             "Operands ~A ~&Possible Descriptions ~A~&"
 137             operands candidate-descriptions)
 138     (with-description-filter
 139         #'filter-descriptions-by-number
 140       (with-description-filter
 141           #'filter-descriptions-by-type
 142         (with-description-filter
 143             #'filter-descriptions-by-simplicity
 144           (first candidate-descriptions))))))
 145
 146
 147 (defun process-opcodes (insn-name operands types encoding instruction)
 148   (format *debug-io* "Processin instruction ~A~&" insn-name)
 149   (format *debug-io* "With operands ~A~&" operands)
 150   (format *debug-io* "Matching types ~A~&" types)
 151   (format *debug-io* "Using encoding ~A~&" encoding)
 152   (loop
 153      for code in encoding
 154      do
 155      (if (numberp code)
 156          (setf (get instruction :opcodes)
 157                (append (get instruction :opcodes) (list code)))
 158          (progn (format *debug-io* "~A~&" (gethash code *opcode-encoder-table*))
 159                 (funcall (gethash code *opcode-encoder-table*)
 160                          insn-name operands types encoding instruction)))))
 161 ;;
 162 ;; turn an encoding into a sequcnce of bytes with no symbols
 163 ;;
 164 (defun process-encoding (insn-name operands description)
 165   "(process-encoding instruction operand operand-description) Given an instruction,
 166  it's operands and it's description produce a stream of bytes for assembly, taking
 167 it's encoding into account"
 168   (let ((result (make-instruction)))
 169     (format *debug-io*
 170             "Processing encoding of instruction ~A w operands ~A using description ~A~&"
 171             insn-name operands description)
 172     (process-opcodes insn-name operands
 173                      (first description) (second description)
 174                      result)
 175     (print-instruction "Resulting " result)
 176     (flatten-instruction result)))
 177
 178 ;; to do -- need to put instructions in keyword package,
 179 ;; hash-table to lookup
 180 (defun assemble-instruction-or-directive (instruction operands)
 181   "(assemble-instruction-or-directive instruction operand) Given the itstruction
 182 and operand portion of an assembler form, assemble it in the current segment"
 183   ;; deal with instruction
 184   (format *debug-io* "Looking up instruction ~A~&" instruction)
 185   (multiple-value-bind (instruction operand-descriptions)
 186       (lookup-instruction instruction)
 187     (when operand-descriptions
 188       (format *debug-io* "Found instruction ~A~&" instruction)
 189       (let ((candidate-description
 190              (find-correct-description operands operand-descriptions)))
 191         (emit-bytes-to-segment
 192          (process-encoding
 193           instruction
 194           operands
 195           candidate-description))))))
 196
 197
 198
 199 (defun assemble-form (form)
 200   "(assemble-form form) -- assemble a single line of assembler code
 201 The form may be one of the following:
 202 a number - a literal to be emitted
 203 a symbol - if it is in the keyword packaage it is an instruction with no operands
 204          - if it is begins with a dot it is a symbol definition
 205          - if does not begin with a dot it is a symbol reference
 206 a list   - it is a list of the above, plus possibly operands"
 207   (labels
 208       ;; remove dot from the front of a symbol
 209       ((remove-dot (x)
 210          (subseq x 1 (length x)))
 211        ;; test to see if a symbol begins with a dot
 212        (begins-with-dot (x)
 213          (char= (char (symbol-name x) 0) #\.)))
 214     (format *debug-io* "--~&Assembling form ~A~%" form)
 215     (ctypecase form
 216       ;; value is supposed to be a literal to be poked in
 217       (number (emit-data-to-segment form))
 218       ;; symbol is supposed to be a reference to a symbol,
 219       ;; or a definition of a symbol unless its a keyword
 220       ;; in which case it's an opcode-less directive
 221       (symbol
 222        (if (symbol-is-in-package form "KEYWORD")
 223            (assemble-instruction-or-directive form nil)
 224            (if (begins-with-dot form)
 225                (add-symbol-definition (remove-dot (symbol-name form)))
 226                (add-symbol-reference (symbol-name form)))))
 227       (list
 228        ;; if the list begins with a keyword, the rest of it
 229        ;; is an instruction
 230        (if (and (symbolp (first form))
 231                 (symbol-is-in-package (first form) "KEYWORD"))
 232            (assemble-instruction-or-directive (first form) (rest form))
 233            (progn
 234              (assemble-form (first form))
 235              (when (rest form)
 236                (assemble-form (rest form)))))))))
 237
 238
 239 (defun assemble-forms (&rest forms)
 240   "(assemble-forms forms)
 241 Assemble a list of forms in the current segment"
 242   (mapcar #'assemble-form forms))
 243
 244
 245
 246 ;; ;; ;; our first test program
 247 ;;(make-instruction-hash-table)
 248
 249 (make-segment "text" :segment-type 'data-segment :set-to-current t)
 250
 251 ;; (assemble-forms
 252 ;;  '((.Entry :ADD :EAX 56)
 253 ;;    (:RET)))
 254
 255
 256
 257 ;; (assemble-forms
 258 ;;  '((:PUSH :EAX)
 259 ;;    (:SUB :EAX #XFFFEA)
 260 ;;    (:MOV :EAX :EBX)
 261 ;;    (:POP :EAX)
 262 ;;    (:PUSH :EAX)
 263 ;;    (:RET)))
 264
 265 ;;(print-segment)
 266
 267 ;; (assemble-forms
 268 ;;   '((.Entry  JMP Exit)
 269 ;;     (:AAD)
 270 ;;     (.Exit :RET)))