asm.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2007 Frode V. Fjeld
   4 ;;;;
   5 ;;;; Description:   Assembly syntax etc.
   6 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   7 ;;;; Distribution:  See the accompanying file COPYING.
   8 ;;;;
   9 ;;;; $Id: asm.lisp,v 1.17 2008/03/06 19:18:51 ffjeld Exp $
  10 ;;;;
  11 ;;;;------------------------------------------------------------------
  12
  13 (defpackage asm
  14   (:use :common-lisp)
  15   (:export #:symbol-reference-p
  16            #:symbol-reference
  17            #:symbol-reference-symbol
  18            #:immediate-p
  19            #:immediate-operand
  20            #:indirect-operand-p
  21            #:indirect-operand
  22            #:indirect-operand-offset
  23            #:instruction-operands
  24            #:instruction-operator
  25            #:register-operand
  26            #:resolve-operand
  27            #:unresolved-symbol
  28            #:retry-symbol-resolve
  29            #:pc-relative-operand
  30            #:assemble-proglist
  31            #:disassemble-proglist
  32            #:*pc*
  33            #:*symtab*
  34            #:*instruction-compute-extra-prefix-map*
  35            #:*position-independent-p*
  36            #:*sub-program-instructions*))
  37
  38 (in-package asm)
  39
  40 (defvar *pc* nil "Current program counter.")
  41 (defvar *symtab* nil "Current symbol table.")
  42 (defvar *instruction-compute-extra-prefix-map* nil)
  43 (defvar *position-independent-p* t)
  44 (defvar *sub-program-instructions* '(:jmp :ret :iretd)
  45   "Instruction operators after which to insert sub-programs.")
  46
  47 (defvar *anonymous-sub-program-identities* nil)
  48
  49 (defun quotep (x)
  50   "Is x a symbol (in any package) named 'quote'?"
  51   ;; This is required because of Movitz package-fiddling.
  52   (and (symbolp x)
  53        (string= x 'quote)))
  54
  55 (deftype simple-symbol-reference ()
  56   '(cons (satisfies quotep) (cons symbol null)))
  57
  58 (deftype sub-program-operand ()
  59   '(cons (satisfies quotep)
  60     (cons
  61      (cons (eql :sub-program))
  62      null)))
  63
  64 (deftype funcall-operand ()
  65   '(cons (satisfies quotep)
  66     (cons
  67      (cons (eql :funcall))
  68      null)))
  69
  70 (deftype symbol-reference ()
  71   '(or simple-symbol-reference sub-program-operand))
  72
  73 (defun sub-program-operand-p (expr)
  74   (typep expr 'sub-program-operand))
  75
  76 (defun sub-program-label (operand)
  77   (let ((x (cadadr operand)))
  78     (if (not (eq '() x))
  79         (car x)
  80         (cdr (or (assoc operand *anonymous-sub-program-identities*)
  81                  (car (push (cons operand (gensym "sub-program-"))
  82                             *anonymous-sub-program-identities*)))))))
  83
  84 (defun sub-program-program (operand)
  85   (cddadr operand))
  86
  87 (defun symbol-reference-symbol (expr)
  88   (etypecase expr
  89     (simple-symbol-reference
  90      (second expr))
  91     (sub-program-operand
  92      (sub-program-label expr))))
  93
  94 (defun funcall-operand-operator (operand)
  95   (cadadr operand))
  96
  97 (defun funcall-operand-operands (operand)
  98   (cddadr operand))
  99
 100 (deftype immediate-operand ()
 101   '(or integer symbol-reference funcall-operand))
 102
 103 (defun immediate-p (expr)
 104   (typep expr 'immediate-operand))
 105
 106 (deftype register-operand ()
 107   'keyword)
 108
 109 (defun register-p (operand)
 110   (typep operand 'register-operand))
 111
 112 (deftype indirect-operand ()
 113   '(and cons (not (cons (satisfies quotep)))))
 114
 115 (defun indirect-operand-p (operand)
 116   (typep operand 'indirect-operand))
 117
 118 (defun indirect-operand-offset (operand)
 119   (check-type operand indirect-operand)
 120   (reduce #'+ operand
 121           :key (lambda (x)
 122                  (if (integerp x) x 0))))
 123
 124 (deftype pc-relative-operand ()
 125   '(cons (eql :pc+)))
 126
 127 (defun pc-relative-operand-p (operand)
 128   (typep operand 'pc-relative-operand))
 129
 130 (defun pc-relative-operand-offset (operand)
 131   (check-type operand pc-relative-operand)
 132   (second operand))
 133
 134 (define-condition unresolved-symbol ()
 135   ((symbol
 136     :initarg :symbol
 137     :reader unresolved-symbol))
 138   (:report (lambda (c s)
 139              (format s "Unresolved symbol ~S." (unresolved-symbol c)))))
 140
 141
 142
 143 (defun resolve-operand (operand)
 144   (typecase operand
 145     (integer
 146      operand)
 147     (symbol-reference
 148      (let ((s (symbol-reference-symbol operand)))
 149        (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
 150                (return (cdr (or (assoc s *symtab*)
 151                                 (error 'unresolved-symbol
 152                                        :symbol s))))))))
 153     (funcall-operand
 154      (apply (funcall-operand-operator operand)
 155             (mapcar #'resolve-operand
 156                     (funcall-operand-operands operand))))
 157     (t operand)))
 158
 159 ;;;;;;;;;;;;
 160
 161 (defun assemble-proglist (proglist &key ((:symtab incoming-symtab) *symtab*) corrections (start-pc 0) (cpu-package '#:asm-x86))
 162   "Encode a proglist, using instruction-encoder in symbol assemble-instruction from cpu-package."
 163   (let ((encoder (find-symbol (string '#:assemble-instruction) cpu-package))
 164         (*pc* start-pc)
 165         (*symtab* (append incoming-symtab corrections))
 166         (*anonymous-sub-program-identities* *anonymous-sub-program-identities*)
 167         (assumptions nil)
 168         (new-corrections nil)
 169         (sub-programs nil))
 170     (flet ((process-instruction (instruction)
 171              (etypecase instruction
 172                ((or symbol integer) ; a label?
 173                 (let ((previous-definition (assoc instruction *symtab*)))
 174                   (cond
 175                     ((null previous-definition)
 176                      (push (cons instruction *pc*)
 177                            *symtab*))
 178                     ((assoc instruction new-corrections)
 179                      (break "prev-def ~S in new-corrections?? new: ~S, old: ~S"
 180                             instruction
 181                             *pc*
 182                             (cdr (assoc instruction new-corrections))))
 183                     ((member previous-definition assumptions)
 184                      (setf (cdr previous-definition) *pc*)
 185                      (setf assumptions (delete previous-definition assumptions))
 186                      (push previous-definition new-corrections))
 187                     ((member previous-definition corrections)
 188                      (cond
 189                        ((> *pc* (cdr previous-definition))
 190                         ;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
 191                         (setf (cdr previous-definition) *pc*)
 192                         (push previous-definition new-corrections))
 193                        ((< *pc* (cdr previous-definition))
 194                         ;;                        (break "Definition for ~S shrunk from ~S to ~S."
 195                         ;;                               instruction
 196                         ;;                               (cdr previous-definition)
 197                         ;;                               *pc*)
 198                         (setf (cdr previous-definition) *pc*)
 199                         (push previous-definition new-corrections))))
 200                     (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
 201                               instruction
 202                               (cdr previous-definition)
 203                               *pc*))))
 204                 nil)
 205                (cons ; a bona fide instruction?
 206                 (let ((code (funcall encoder instruction)))
 207                   (incf *pc* (length code))
 208                   code)))))
 209       (handler-bind
 210           ((unresolved-symbol (lambda (c)
 211                                 (let ((a (cons (unresolved-symbol c) *pc*)))
 212                                   ;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
 213                                   (push a assumptions)
 214                                   (push a *symtab*)
 215                                   (invoke-restart 'retry-symbol-resolve)))))
 216         (let ((code (loop for instruction in proglist
 217                        for operands = (when (consp instruction)
 218                                         instruction)
 219                        for operator = (when (consp instruction)
 220                                         (let ((x (pop operands)))
 221                                           (if (not (listp x)) x (pop operands))))
 222                        append (process-instruction instruction)
 223                        do (loop for operand in operands
 224                              do (when (sub-program-operand-p operand)
 225                                   (push (cons (sub-program-label operand)
 226                                               (sub-program-program operand))
 227                                         sub-programs)))
 228                        when (and (not (null sub-programs))
 229                                  (member operator *sub-program-instructions*))
 230                        append (loop for sub-program in (nreverse sub-programs)
 231                                  append (mapcan #'process-instruction sub-program)
 232                                  finally (setf sub-programs nil)))))
 233           (cond
 234             ((not (null assumptions))
 235              (error "Undefined symbol~P: ~{~S~^, ~}"
 236                     (length assumptions)
 237                     (mapcar #'car assumptions)))
 238             ((not (null new-corrections))
 239              (assemble-proglist proglist
 240                                 :symtab incoming-symtab
 241                                 :start-pc start-pc
 242                                 :cpu-package cpu-package
 243                                 :corrections (nconc new-corrections corrections)))
 244             (t (values code *symtab*))))))))
 245
 246 (defun instruction-operator (instruction)
 247   (if (listp (car instruction)) ; skip any instruction prefixes etc.
 248       (cadr instruction)
 249       (car instruction)))
 250
 251 (defun instruction-operands (instruction)
 252   (if (listp (car instruction)) ; skip any instruction prefixes etc.
 253       (cddr instruction)
 254       (cdr instruction)))
 255
 256 (defun instruction-modifiers (instruction)
 257   (if (listp (car instruction))
 258       (car instruction)
 259       nil))
 260
 261 (defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*) collect-data collect-labels)
 262   "Return a proglist (i.e. a list of instructions), or a list of (cons instruction data) if collect-data is true,
 263 data being the octets corresponding to that instruction. Labels will be included in the proglist if collect-labels is true.
 264 Secondarily, return the symtab."
 265   (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
 266                                                 cpu-package))
 267          (proglist0 (loop while code
 268                        collect pc
 269                        collect (multiple-value-bind (instruction new-code)
 270                                    (funcall instruction-disassembler
 271                                             code)
 272                                  (when (eq code new-code)
 273                                    (loop-finish))
 274                                  (let* ((data (loop until (eq code new-code)
 275                                                  do (incf pc)
 276                                                  collect (pop code)))
 277                                         (operands (instruction-operands instruction)))
 278                                    (cons data
 279                                          (if (notany #'pc-relative-operand-p operands)
 280                                              instruction
 281                                              (nconc (loop until (eq instruction operands)
 282                                                        collect (pop instruction))
 283                                                     (loop for operand in operands
 284                                                        collect (if (not (pc-relative-operand-p operand))
 285                                                                    operand
 286                                                                    (let* ((location (+ pc (pc-relative-operand-offset operand)))
 287                                                                           (entry (or (rassoc location symtab)
 288                                                                                      (car (push (cons (gensym) location)
 289                                                                                                 symtab)))))
 290                                                                      `(quote ,(car entry)))))))))))))
 291     (values (loop for (pc data-instruction) on proglist0 by #'cddr
 292                for (data . instruction) = data-instruction
 293                for label = (when collect-labels
 294                              (rassoc pc symtab))
 295                when label
 296                collect (if (not collect-data)
 297                            (car label)
 298                            (cons nil (car label)))
 299                collect (if (not collect-data)
 300                            instruction
 301                            data-instruction))
 302             symtab)))
 303
 304 (defun disassemble-proglist* (code &key (cpu-package '#:asm-x86) (pc 0))
 305   "Print a human-readable disassembly of code."
 306   (multiple-value-bind (proglist symtab)
 307       (disassemble-proglist code
 308                             :cpu-package cpu-package
 309                             :collect-data t)
 310     (format t "~&~:{~4X: ~20<~{ ~2,'0X~}~;~> ~A~%~}"
 311             (loop with pc = pc
 312                for (data . instruction) in proglist
 313                when (let ((x (find pc symtab :key #'cdr)))
 314                       (when x (list pc (list (format nil "      ~A" (car x))) "")))
 315                collect it
 316                collect (list pc data instruction)
 317                do (incf pc (length data))))))