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