read.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2000-2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      read.lisp
   7 ;;;; Description:   Functions for reading assembly expressions.
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Mon Jul 31 13:54:27 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: read.lisp,v 1.8 2004/11/10 15:36:15 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package #:ia-x86)
  17
  18 ;;; Implements the following assembly syntax:
  19 ;;;
  20 ;;;       program ::= (<sexpr>*)
  21 ;;;
  22 ;;;         sexpr ::= ( <expr> ) | <label> | (% <inline-data> %) | (:include . <program>)
  23 ;;;          expr ::= <instro> | ( { <prefix> } ) <instro>
  24 ;;;        instro ::= <instruction> { <operand> }
  25 ;;;
  26 ;;;       operand ::= <concrete> | <abstract>
  27 ;;;
  28 ;;;      concrete ::= <immediate> | <register> | <indirect>
  29 ;;;     immediate ::= <number>
  30 ;;;      register ::= eax | ecx | ...
  31 ;;;      indirect ::= ( iexpr )
  32 ;;;         iexpr ::=   <address>
  33 ;;;                   | (quote <label>)
  34 ;;;                   | <segment> <address>
  35 ;;;                   | pc+ <offset>
  36 ;;;                   | pc  <address>
  37 ;;;                   | { (quote <label>) } <offset> <scaled-register> <register>
  38 ;;;     scaled-register ::= <register> | ( <register> <scale> )
  39 ;;;               scale ::= 1 | 2 | 4 | 8
  40 ;;;             address ::= <number>
  41 ;;;              offset ::= <signed-number>
  42 ;;;
  43 ;;;      abstract ::= (quote <absexpr>)
  44 ;;;       absexpr ::= <label> | <number> | append-prg
  45 ;;;    append-prg ::= program
  46 ;;;
  47 ;;;        prefix ::= <segment-override> | (:size <size>)
  48 ;;;
  49 ;;;
  50 ;;; Instructions are recognized by symbol-name, so there should be no
  51 ;;; need to worry about packages etc.
  52
  53 (defparameter +all-registers+
  54     '(:eax :ecx :edx :ebx :esp :ebp :esi :edi
  55       :ax :cx :dx :bx :sp :bp :si :di
  56       :al :cl :dl :bl :ah :ch :dh :bh
  57       :cs :ds :es :fs :gs :ss
  58       :dr0 :dr1 :dr2 :dr3 :dr4 :dr5 :dr6 :dr7
  59       :cr0 :cr2 :cr3 :cr4
  60       :mm0 :mm1 :mm2 :mm3 :mm4 :mm5 :mm6 :mm7
  61       :xmm0 :xmm1 :xmm2 :xmm3 :xmm4 :xmm5 :xmm6 :xmm7
  62       ))
  63
  64 (defun read-register-symbol (spec)
  65   (assert (member spec +all-registers+)
  66       (spec)
  67     "Expected a register: ~A" spec)
  68   (find-symbol (symbol-name spec) '#:ia-x86))
  69
  70 (defun is-register-p (spec)
  71   (and (symbolp spec)
  72        (member spec +all-registers+)))
  73
  74 (defun is-address-p (spec)
  75   (typecase spec
  76     ((integer 0 *) t)
  77     (t nil)))
  78
  79 (defun is-offset-p (spec)
  80   (typecase spec
  81     (integer t)
  82     (symbol t)
  83     (t nil)))
  84
  85 (defun is-pc-relative-p (iexpr)
  86   (and (<= 2 (length iexpr))
  87        (symbolp (first iexpr))
  88        (string= :pc+ (first iexpr))
  89        (is-offset-p (second iexpr))))
  90
  91 (defun extract-label-ref (expr)
  92   "Return NIL if expr is not a label reference, otherwise
  93 returns the symbol/label that is referenced."
  94   (and (listp expr)
  95        (= 2 (length expr))
  96        (symbolp (first expr))
  97        (string= 'quote (first expr))
  98        (symbolp (second expr))
  99        (second expr)))
 100
 101 (defun read-indirect-operand (iexpr)
 102   (cond
 103    ((and (= 1 (length iexpr))           ; simple direct memory reference
 104          (is-address-p (car iexpr)))
 105     (make-instance 'operand-direct
 106       'address (car iexpr)))
 107    ((and (= 1 (length iexpr))           ; abstract simple direct memory reference
 108          (extract-label-ref (first iexpr)))
 109     (make-instance 'operand-direct
 110       'address (extract-label-ref (first iexpr))))
 111    ((and (= 2 (length iexpr))           ; segmented indirect address
 112          (integerp (first iexpr))
 113          (integerp (second iexpr)))
 114     (make-instance 'operand-direct
 115       'address (second iexpr)
 116       'segment (first iexpr)))
 117    ((is-pc-relative-p iexpr)            ; PC-relative address
 118     (make-instance 'operand-rel-pointer
 119       'offset (second iexpr)))
 120    (t (let (register register2 (offset 0) symbolic-offsets scale) ; indirect register(s)
 121         (loop for s in iexpr
 122             do (cond
 123                 ((integerp s)           ; an offset
 124                  (incf offset s))
 125                 ((and (listp s)         ; an abstract offset
 126                       (= 2 (length s))
 127                       (symbolp (first s))
 128                       (string= 'quote (first s))
 129                       (symbolp (second s)))
 130                  (push (second s) symbolic-offsets))
 131                 ((and (is-register-p s) ; register number one
 132                       (null register))
 133                  (setf register (read-register-symbol s)))
 134                 ((and (is-register-p s) ; a register number two
 135                       (null register2))
 136                  (setf register2 (read-register-symbol s)))
 137                 ((and (listp s)         ; a scaled register
 138                       (is-register-p (first s))
 139                       (integerp (second s))
 140                       (null register))
 141                  (setf register (read-register-symbol (first s))
 142                        scale (second s)))
 143                 ((and (listp s)         ; a scaled register after a non-scaled register
 144                       (is-register-p (first s))
 145                       (integerp (second s))
 146                       (null register2)
 147                       (symbolp register))
 148                  (setf register2 register
 149                        register (read-register-symbol (first s))
 150                        scale (second s)))
 151                 (t (error "Can't read indirect operand ~A [~A]" iexpr s))))
 152         (make-instance 'operand-indirect-register
 153           'register register
 154           'register2 register2
 155           'offset (if (null symbolic-offsets)
 156                       offset
 157                     `(+ ,offset ,@symbolic-offsets))
 158           'scale (or scale 1))))))
 159
 160 (defun read-abstract-operand (spec)
 161   (etypecase (first spec)
 162     (symbol
 163      (assert (not (null (first spec))) (spec)
 164        "NIL is an illegal assembly label: ~S" spec)
 165      (make-instance 'operand-label
 166        'label (first spec)
 167        'user-size (second spec)))
 168     (list
 169      (let ((type (caar spec))           ; (<type> &rest <datum>)
 170            (datum (cdar spec)))
 171        (ecase type
 172          (:sub-program
 173           (let* ((options (car datum))
 174                  (sub-program (cdr datum)))
 175             (destructuring-bind (&optional (label (gensym "sub-program-label-")))
 176                 options
 177               (declare (special *programs-to-append*))
 178               (pushnew (cons label sub-program) *programs-to-append*
 179                        :test #'equal)
 180               (make-instance 'operand-label
 181                 'label label))))
 182          (:funcall
 183           (make-instance 'calculated-operand
 184             :calculation (coerce (car datum) 'function)
 185             :sub-operands (mapcar #'read-operand (cdr datum)))))))
 186     (integer
 187      (make-instance 'operand-number
 188        'number (first spec)))))
 189
 190
 191 (defun read-operand (spec)
 192   (cond
 193    ((integerp spec)
 194     (make-instance 'operand-immediate
 195       'value spec))
 196    ((and (symbolp spec)
 197          (is-register-p spec))
 198     (make-instance 'operand-register
 199       'register (read-register-symbol spec)))
 200    ((null spec)
 201     (error "Operand was NIL."))
 202    ((and (listp spec)
 203          (symbolp (first spec))
 204          (string= 'quote (first spec)))
 205     (read-abstract-operand (rest spec)))
 206    ((listp spec)
 207     (read-indirect-operand spec))
 208    (t (error "Can't read operand ~S" spec))))
 209
 210 (defun read-prefixes (prefix-spec)
 211   (loop with user-size = nil with user-finalizer = nil
 212       for p in prefix-spec
 213       if (symbolp p)
 214       collect (let ((ps (find-symbol (symbol-name p) '#:ia-x86)))
 215                 (if (decode-set +prefix-opcode-map+ ps :errorp nil)
 216                     ps
 217                   (error "No such prefix: ~A" p)))
 218       into prefixes
 219       else do
 220            (check-type p list)
 221            (ecase (car p)
 222              (:size
 223               (let ((size (second p)))
 224                 (check-type size integer)
 225                 (setf user-size size)))
 226              (:finalize                 ; XXX
 227               (let ((finalizer (second p)))
 228                 (check-type finalizer symbol "a function name")
 229                 (setf user-finalizer finalizer))))
 230       finally (return (values prefixes user-size user-finalizer))))
 231
 232 (defvar *find-instruction-cache* (make-hash-table :test #'eq))
 233
 234 (defun read-instruction (sexpr)
 235   "Parse a list into an assembly instruction."
 236   (let (prefix-list user-size user-finalizer instr-name operand-list)
 237     (if (listp (first sexpr))
 238         (setf (values prefix-list user-size user-finalizer) (read-prefixes (first sexpr))
 239               instr-name (second sexpr)
 240               operand-list (nthcdr 2 sexpr))
 241       (setf prefix-list nil
 242             user-size nil
 243             instr-name (first sexpr)
 244             operand-list (nthcdr 1 sexpr)))
 245     (case instr-name
 246       (:align
 247        (make-instance 'alignment :type operand-list))
 248       ((nil)
 249        (mapcar #'read-operand operand-list)
 250        nil)
 251       (t (make-instance (or (gethash instr-name *find-instruction-cache*)
 252                             (setf (gethash instr-name *find-instruction-cache*)
 253                               (multiple-value-bind (instr-symbol instr-symbol-status)
 254                                   (find-symbol (string instr-name) '#:ia-x86-instr)
 255                                 (unless instr-symbol-status
 256                                   (error "No instruction named ~A." (string instr-name)))
 257                                 instr-symbol)))
 258            :prefixes prefix-list
 259            :user-size user-size
 260            :user-finalizer user-finalizer
 261            :operands (mapcar #'read-operand operand-list))))))
 262
 263
 264 (defun inline-data-p (expr)
 265   (and (listp expr)
 266        (symbolp (first expr))
 267        (string= '% (first expr))))
 268
 269 (defun read-proglist (program &rest args)
 270   (when program
 271     (let ((*programs-to-append* ())
 272           (*already-appended* 0))
 273       (declare (special *programs-to-append* *already-appended*))
 274       (apply #'read-proglist-internal program args))))
 275
 276 (defun read-proglist-internal (program &key no-warning (do-append-programs t)
 277                                             (append-after-type 'ia-x86-instr::unconditional-branch))
 278   "Read a symbolic assembly program (a list with the syntax described in BNF in this file) into
 279 a proglist: A list of INSTRUCTION objects."
 280   (declare (special *programs-to-append* *already-appended*))
 281   (loop for expr in program
 282       if (null expr)
 283       do (error "Illegal NIL expr in program: ~S" program)
 284       else if (or (symbolp expr) (integerp expr))
 285       collect expr                      ; a label, collect it.
 286       else if (inline-data-p expr)
 287       collect (read-inline-data expr)   ; inline data, read it.
 288       else if (and (consp expr) (eq :include (car expr)))
 289       append (read-proglist (cdr expr)
 290                             :do-append-programs do-append-programs
 291                             :no-warning no-warning)
 292       else
 293       append (let ((i (read-instruction expr))) ; an instruction, read it, possibly append
 294                (if (and do-append-programs
 295                         *programs-to-append*
 296                         (typep i append-after-type))
 297                    ;; auto-insert *programs-to-append* here:
 298                    (let ((sub-programs (reduce #'append
 299                                                (nreverse
 300                                                 (subseq *programs-to-append* 0
 301                                                         (- (length *programs-to-append*)
 302                                                            *already-appended*))))))
 303                      (setf *already-appended* (length *programs-to-append*))
 304                      (list* i (read-proglist-internal sub-programs
 305                                                       :do-append-programs do-append-programs)))
 306                  ;; nothing to insert other than i itself..
 307                  (when i (list i))))
 308       finally (assert (= (length *programs-to-append*)
 309                          *already-appended*) ()
 310                 "Dangling sub-programs to append: ~S"
 311                 (nreverse (subseq *programs-to-append*
 312                                   0 (- (length
 313                                         *programs-to-append*)
 314                                        *already-appended*))))))
 315
 316
 317 (defmacro asm (&rest spec)
 318   `(instruction-encode (read-instruction ',spec) nil))