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.14 2008/02/18 22:30:45 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            #:register-operand
  23            #:resolve-operand
  24            #:unresolved-symbol
  25            #:retry-symbol-resolve
  26            #:pc-relative-operand
  27            #:assemble-proglist
  28            #:disassemble-proglist
  29            #:*pc*
  30            #:*symtab*
  31            #:*instruction-compute-extra-prefix-map*
  32            #:*position-independent-p*
  33            #:*sub-program-instructions*))
  34
  35 (in-package asm)
  36
  37 (defvar *pc* nil "Current program counter.")
  38 (defvar *symtab* nil "Current symbol table.")
  39 (defvar *instruction-compute-extra-prefix-map* nil)
  40 (defvar *position-independent-p* t)
  41 (defvar *sub-program-instructions* '(:jmp :ret :iretd)
  42   "Instruction operators after which to insert sub-programs.")
  43
  44 (defvar *anonymous-sub-program-identities* nil)
  45
  46 (defun quotep (x)
  47   "Is x a symbol (in any package) named 'quote'?"
  48   ;; This is required because of Movitz package-fiddling.
  49   (and (symbolp x)
  50        (string= x 'quote)))
  51
  52 (deftype simple-symbol-reference ()
  53   '(cons (satisfies quotep) (cons symbol null)))
  54
  55 (deftype sub-program-operand ()
  56   '(cons (satisfies quotep)
  57     (cons
  58      (cons (eql :sub-program))
  59      null)))
  60
  61 (deftype funcall-operand ()
  62   '(cons (satisfies quotep)
  63     (cons
  64      (cons (eql :funcall))
  65      null)))
  66
  67 (deftype symbol-reference ()
  68   '(or simple-symbol-reference sub-program-operand))
  69
  70 (defun sub-program-operand-p (expr)
  71   (typep expr 'sub-program-operand))
  72
  73 (defun sub-program-label (operand)
  74   (let ((x (cadadr operand)))
  75     (if (not (eq '() x))
  76         (car x)
  77         (cdr (or (assoc operand *anonymous-sub-program-identities*)
  78                  (car (push (cons operand (gensym "sub-program-"))
  79                             *anonymous-sub-program-identities*)))))))
  80
  81 (defun sub-program-program (operand)
  82   (cddadr operand))
  83
  84 (defun symbol-reference-symbol (expr)
  85   (etypecase expr
  86     (simple-symbol-reference
  87      (second expr))
  88     (sub-program-operand
  89      (sub-program-label expr))))
  90
  91 (defun funcall-operand-operator (operand)
  92   (cadadr operand))
  93
  94 (defun funcall-operand-operands (operand)
  95   (cddadr operand))
  96
  97 (deftype immediate-operand ()
  98   '(or integer symbol-reference funcall-operand))
  99
 100 (defun immediate-p (expr)
 101   (typep expr 'immediate-operand))
 102
 103 (deftype register-operand ()
 104   'keyword)
 105
 106 (defun register-p (operand)
 107   (typep operand 'register-operand))
 108
 109 (deftype indirect-operand ()
 110   '(and cons (not (cons (satisfies quotep)))))
 111
 112 (defun indirect-operand-p (operand)
 113   (typep operand 'indirect-operand))
 114
 115 (deftype pc-relative-operand ()
 116   '(cons (eql :pc+)))
 117
 118 (defun pc-relative-operand-p (operand)
 119   (typep operand 'pc-relative-operand))
 120
 121 (defun pc-relative-operand-offset (operand)
 122   (check-type operand pc-relative-operand)
 123   (second operand))
 124
 125 (define-condition unresolved-symbol ()
 126   ((symbol
 127     :initarg :symbol
 128     :reader unresolved-symbol))
 129   (:report (lambda (c s)
 130              (format s "Unresolved symbol ~S." (unresolved-symbol c)))))
 131
 132
 133
 134 (defun resolve-operand (operand)
 135   (typecase operand
 136     (integer
 137      operand)
 138     (symbol-reference
 139      (let ((s (symbol-reference-symbol operand)))
 140        (loop (with-simple-restart (retry-symbol-resolve "Retry resolving ~S." s)
 141                (return (cdr (or (assoc s *symtab*)
 142                                 (error 'unresolved-symbol
 143                                        :symbol s))))))))
 144     (funcall-operand
 145      (apply (funcall-operand-operator operand)
 146             (mapcar #'resolve-operand
 147                     (funcall-operand-operands operand))))
 148     (t operand)))
 149
 150 ;;;;;;;;;;;;
 151
 152 (defun assemble-proglist (proglist &key ((:symtab incoming-symtab) *symtab*) corrections (start-pc 0) (cpu-package '#:asm-x86))
 153   "Encode a proglist, using instruction-encoder in symbol assemble-instruction from cpu-package."
 154   (let ((encoder (find-symbol (string '#:assemble-instruction) cpu-package))
 155         (*pc* start-pc)
 156         (*symtab* (append incoming-symtab corrections))
 157         (*anonymous-sub-program-identities* *anonymous-sub-program-identities*)
 158         (assumptions nil)
 159         (new-corrections nil)
 160         (sub-programs nil))
 161     (flet ((process-instruction (instruction)
 162              (etypecase instruction
 163                ((or symbol integer) ; a label?
 164                 (let ((previous-definition (assoc instruction *symtab*)))
 165                   (cond
 166                     ((null previous-definition)
 167                      (push (cons instruction *pc*)
 168                            *symtab*))
 169                     ((assoc instruction new-corrections)
 170                      (break "prev-def ~S in new-corrections?? new: ~S, old: ~S"
 171                             instruction
 172                             *pc*
 173                             (cdr (assoc instruction new-corrections))))
 174                     ((member previous-definition assumptions)
 175                      (setf (cdr previous-definition) *pc*)
 176                      (setf assumptions (delete previous-definition assumptions))
 177                      (push previous-definition new-corrections))
 178                     ((member previous-definition corrections)
 179                      (cond
 180                        ((> *pc* (cdr previous-definition))
 181                         ;; (warn "correcting ~S from ~D to ~D" instruction (cdr previous-definition) *pc*)
 182                         (setf (cdr previous-definition) *pc*)
 183                         (push previous-definition new-corrections))
 184                        ((< *pc* (cdr previous-definition))
 185                         ;;                        (break "Definition for ~S shrunk from ~S to ~S."
 186                         ;;                               instruction
 187                         ;;                               (cdr previous-definition)
 188                         ;;                               *pc*)
 189                         (setf (cdr previous-definition) *pc*)
 190                         (push previous-definition new-corrections))))
 191                     (t (error "Label ~S doubly defined. Old value: ~S, new value: ~S"
 192                               instruction
 193                               (cdr previous-definition)
 194                               *pc*))))
 195                 nil)
 196                (cons ; a bona fide instruction?
 197                 (let ((code (funcall encoder instruction)))
 198                   (incf *pc* (length code))
 199                   code)))))
 200       (handler-bind
 201           ((unresolved-symbol (lambda (c)
 202                                 (let ((a (cons (unresolved-symbol c) *pc*)))
 203                                   ;; (warn "assuming ~S for ~S" (unresolved-symbol c) *pc*)
 204                                   (push a assumptions)
 205                                   (push a *symtab*)
 206                                   (invoke-restart 'retry-symbol-resolve)))))
 207         (let ((code (loop for instruction in proglist
 208                        for operands = (when (consp instruction)
 209                                         instruction)
 210                        for operator = (when (consp instruction)
 211                                         (let ((x (pop operands)))
 212                                           (if (not (listp x)) x (pop operands))))
 213                        append (process-instruction instruction)
 214                        do (loop for operand in operands
 215                              do (when (sub-program-operand-p operand)
 216                                   (push (cons (sub-program-label operand)
 217                                               (sub-program-program operand))
 218                                         sub-programs)))
 219                        when (and (not (null sub-programs))
 220                                  (member operator *sub-program-instructions*))
 221                        append (loop for sub-program in (nreverse sub-programs)
 222                                  append (mapcan #'process-instruction sub-program)
 223                                  finally (setf sub-programs nil)))))
 224           (cond
 225             ((not (null assumptions))
 226              (error "Undefined symbol~P: ~{~S~^, ~}"
 227                     (length assumptions)
 228                     (mapcar #'car assumptions)))
 229             ((not (null new-corrections))
 230              (assemble-proglist proglist
 231                                 :symtab incoming-symtab
 232                                 :start-pc start-pc
 233                                 :cpu-package cpu-package
 234                                 :corrections (nconc new-corrections corrections)))
 235             (t (values code *symtab*))))))))
 236
 237 (defun instruction-operands (instruction)
 238   (if (listp (car instruction)) ; skip any instruction prefixes etc.
 239       (cddr instruction)
 240       (cdr instruction)))
 241
 242
 243 (defun disassemble-proglist (code &key (cpu-package '#:asm-x86) (pc (or *pc* 0)) (symtab *symtab*))
 244   (let* ((instruction-disassembler (find-symbol (string '#:disassemble-instruction)
 245                                                 cpu-package))
 246          (proglist0 (loop while code
 247                        collect pc
 248                        collect (multiple-value-bind (instruction new-code)
 249                                    (funcall instruction-disassembler
 250                                             code)
 251                                  (when (eq code new-code)
 252                                    (loop-finish))
 253                                  (loop until (eq code new-code)
 254                                     do (incf pc)
 255                                     (setf code (cdr code)))
 256                                  (let ((operands (instruction-operands instruction)))
 257                                    (if (notany #'pc-relative-operand-p operands)
 258                                        instruction
 259                                        (nconc (loop until (eq instruction operands)
 260                                                  collect (pop instruction))
 261                                               (loop for operand in operands
 262                                                  collect (if (not (pc-relative-operand-p operand))
 263                                                              operand
 264                                                              (let* ((location (+ pc (pc-relative-operand-offset operand)))
 265                                                                     (entry (or (rassoc location symtab)
 266                                                                                (car (push (cons (gensym) location)
 267                                                                                           symtab)))))
 268                                                                `(quote ,(car entry))))))))))))
 269     (values (loop for (pc instruction) on proglist0 by #'cddr
 270                when (car (rassoc pc symtab))
 271                collect it
 272                collect instruction)
 273             symtab)))