proglist.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 20012000, 2002, 2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway
   5 ;;;;
   6 ;;;; Filename:      proglist.lisp
   7 ;;;; Description:
   8 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
   9 ;;;; Created at:    Mon May 15 13:43:55 2000
  10 ;;;; Distribution:  See the accompanying file COPYING.
  11 ;;;;
  12 ;;;; $Id: proglist.lisp,v 1.6 2004/10/12 09:37:24 ffjeld Exp $
  13 ;;;;
  14 ;;;;------------------------------------------------------------------
  15
  16 (in-package #:ia-x86)
  17
  18 (defvar *label-counter* 0)
  19 (defun make-label ()
  20   (intern (format nil "~A-~D"
  21                   'label
  22                   (incf *label-counter*))))
  23
  24 (defun labelize-proglist (proglist &optional (start-address 0))
  25   "Destructively modifies the instruction-objects in proglist."
  26   (let ((end-address (+ start-address
  27                         (loop for i in proglist
  28                             summing (imagpart (instruction-original-datum i)))))
  29         (label-hash (make-hash-table :test #'eql :size 19)))
  30     (loop for i in proglist
  31         with pc = start-address
  32         do (incf pc (imagpart (instruction-original-datum i)))
  33         do (loop for operands on (instruction-operands i)
  34                when (typep (car operands) 'operand-rel-pointer)
  35                do (let ((address (+ pc (slot-value (car operands) 'offset))))
  36                     (if (<= start-address address end-address)
  37                         (let ((label (or (gethash address label-hash)
  38                                          (setf (gethash address label-hash)
  39                                            (make-label)))))
  40                           (setf (car operands)
  41                             (make-instance 'operand-label 'label label)))
  42                       (setf (car operands)
  43                         (make-instance 'operand-number 'number address))))))
  44     (loop for i in proglist
  45         with pc = start-address
  46         when (gethash pc label-hash)
  47         collect (gethash pc label-hash)
  48         collect i
  49         do (incf pc (imagpart (instruction-original-datum i))))))
  50
  51 (defclass forward-reference ()
  52   ((labels           :initarg labels :reader forward-reference-labels)
  53    (referring-pc     :initarg referring-pc)
  54    (placeholder-cons :initarg placeholder-cons)
  55    (assumed-length   :initarg assumed-length
  56                      :accessor forward-reference-assumed-length)))
  57
  58 (defclass forward-reference-instruction (forward-reference)
  59   ((instruction :initarg instruction)))
  60
  61 (defclass forward-reference-inline-data (forward-reference)
  62   ((inline-data :initarg inline-data)))
  63
  64 (defmethod print-object ((obj forward-reference) stream)
  65   (format stream "<unresolved: ~A>" (forward-reference-labels obj)))
  66
  67 (define-condition assumption-failed ()
  68   ((forward-reference :initarg forward-reference
  69                       :reader assumption-failed-forward-reference)
  70    (actual-symtab :initarg actual-symtab
  71                   :reader assumption-failed-actual-symtab)
  72    (actual-length :initarg actual-length
  73                   :reader assumption-failed-actual-length))
  74   (:report
  75    (lambda (condition stream)
  76      (with-slots (forward-reference actual-symtab assumed-length actual-length)
  77          condition
  78        (with-slots (referring-pc assumed-length)
  79            forward-reference
  80          (format stream
  81                  "Assumption failed when ~A implied length ~A while ~A was assumed."
  82                  actual-symtab actual-length assumed-length))))))
  83
  84 (defun try-resolve-forward-reference (fwd-to-resolve env optimize-teo)
  85   (if (notevery #'(lambda (label)
  86                     (symtab-try-lookup-label (assemble-env-symtab env) label))
  87                 (forward-reference-labels fwd-to-resolve))
  88       nil                               ; this label doesn't (completely) resolve this fwd.
  89     (prog1 t (resolve-forward-reference fwd-to-resolve env optimize-teo))))
  90
  91 (defmethod resolve-forward-reference ((fwd-to-resolve forward-reference-instruction) env optimize-teo)
  92   (with-slots (labels instruction referring-pc
  93                       placeholder-cons assumed-length)
  94       fwd-to-resolve
  95 ;;;    (warn "Resolving at ~D from ~D: ~S" referring-pc (assemble-env-current-pc env)
  96 ;;;       (mapcar #'(lambda (l)
  97 ;;;                   (cons l (format nil "~D" (symtab-lookup-label (assemble-env-symtab env) l))))
  98 ;;;               labels))
  99     (let ((cdatum (instruction-encode instruction
 100                                       (make-assemble-env :symtab (assemble-env-symtab env)
 101                                                          :current-pc referring-pc)
 102                                       optimize-teo)))
 103       (when (< (imagpart cdatum) assumed-length)
 104         (setf cdatum
 105           (instruction-encode instruction
 106                               (make-assemble-env :symtab (assemble-env-symtab env)
 107                                                  :current-pc referring-pc)
 108                               #'(lambda (teo-list instr env)
 109                                   (or (find-if #'(lambda (teo)
 110                                                (= assumed-length
 111                                                   (template-instr-and-prefix-length
 112                                                    (teo-template teo)
 113                                                    instr env)))
 114                                                teo-list)
 115                                       (error "Unable to find encoding matching size ~D for ~S"
 116                                              assumed-length instr))))))
 117       (unless (= (imagpart cdatum) assumed-length)
 118         (error 'assumption-failed
 119                'forward-reference fwd-to-resolve
 120                'actual-symtab (mapcar #'(lambda (label)
 121                                           (cons label
 122                                                 (symtab-lookup-label (assemble-env-symtab env)
 123                                                                      label)))
 124                                       labels)
 125                'actual-length (imagpart cdatum)))
 126       (setf (car placeholder-cons) cdatum))))
 127
 128 (defmethod resolve-forward-reference ((fwd-to-resolve forward-reference-inline-data) env optimize-teo)
 129   (declare (ignore optimize-teo))
 130   (with-slots (labels inline-data referring-pc placeholder-cons assumed-length)
 131       fwd-to-resolve
 132     (let* ((cdatums (reverse (inline-data-encode inline-data env)))
 133            (total-length (loop for cd in cdatums summing (imagpart cd))))
 134       (unless (= total-length assumed-length)
 135         (error 'assumption-failed
 136                'forward-reference fwd-to-resolve
 137                'actual-symtab (mapcar #'(lambda (label)
 138                                           (cons label
 139                                                 (symtab-lookup-label (assemble-env-symtab env) label)))
 140                                       labels)
 141                'actual-length total-length))
 142       ;; splice in the cdatums list
 143       (setf (car placeholder-cons) (car cdatums)
 144             (cdr (last cdatums)) (cdr placeholder-cons)
 145             (cdr placeholder-cons) (cdr cdatums)))))
 146
 147
 148 (defun guess-next-instruction-length (expr missing-labels program-rest env)
 149   (declare (special *proglist-minimum-expr-size*))
 150   ;; (let ((minimum-size (max previous-length (gethash expr *proglist-minimum-expr-size*))))
 151   (or (instruction-user-size expr)
 152       (car (or (gethash expr *proglist-minimum-expr-size*)
 153                (setf (gethash expr *proglist-minimum-expr-size*)
 154                  (typecase expr
 155                    ((or ia-x86-instr::jmp #+ignore ia-x86-instr::jcc)
 156                     ;; educated guess for jumps..
 157                     (assert (= 1 (length missing-labels)))
 158                     (let ((instruction-offset (position (first missing-labels) program-rest)))
 159                       (assert instruction-offset ()
 160                         "Can't find label ~S for instruction ~S." (first missing-labels) expr)
 161                       (etypecase expr
 162                         (ia-x86-instr::jmp
 163                          (if (>= instruction-offset 60)
 164                              '(5 2 4)
 165                            '(2 5 4)))
 166                         #+ignore (ia-x86-instr::jcc
 167                                   (if (>= instruction-offset 50)
 168                                       (if (eq *cpu-mode* :32-bit) '(6 2 4 5) '(4 2 6 5))
 169                                     (if (eq *cpu-mode* :32-bit) '(2 6 4) '(2 4 6)))))))
 170                    (t (loop with guesses = nil
 171                           for template in (templates-lookup-by-class-name (type-of expr))
 172                           when (template-match-by-operand-classes template (instruction-operands expr))
 173                           do (let ((l (template-instr-and-prefix-length template expr env)))
 174                                (unless (member l guesses)
 175                                  (setf guesses
 176                                    (merge 'list guesses (list l) #'<))))
 177                           finally (return guesses)))))))))
 178
 179 (defun proglist-encode-internal (prog-list env forward-references encoded-proglist-reverse
 180                                  optimize-teo)
 181
 182   (declare (special *proglist-minimum-expr-size*))
 183   (loop for expr-rest on prog-list
 184       do (let ((expr (first expr-rest)))
 185            (etypecase expr
 186              ((or SYMBOL integer)
 187               (setf (assemble-env-symtab env)
 188                 (symtab-def-label (assemble-env-symtab env)
 189                                   expr
 190                                   (assemble-env-current-pc env)))
 191               (loop for fwd in forward-references
 192                   when (try-resolve-forward-reference fwd env optimize-teo)
 193                   collect fwd into resolved-forwards
 194                   finally (setf forward-references
 195                             (set-difference forward-references resolved-forwards))))
 196              (ALIGNMENT
 197               (loop for cbyte in (create-alignment expr (assemble-env-current-pc env))
 198                   do (push cbyte encoded-proglist-reverse)
 199                   do (incf (assemble-env-current-pc env)
 200                            (imagpart cbyte))))
 201              (INLINE-DATA
 202               ;; this follows pretty much the same structure as the INSTRUCTION case.
 203               (handler-case
 204                   (loop for cbyte in (inline-data-encode expr env)
 205                       do (push cbyte encoded-proglist-reverse)
 206                       do (incf (assemble-env-current-pc env)
 207                                (imagpart cbyte)))
 208                 (unresolved-labels (ul-condition)
 209                   (push 'unresolved-inline-data-forward-reference encoded-proglist-reverse)
 210                   (let* ((assumed-length (inline-data-guess-sizeof expr env))
 211                          (fwd (make-instance 'forward-reference-inline-data
 212                                 'labels (unresolved-labels-labels ul-condition)
 213                                 'inline-data expr
 214                                 'referring-pc (assemble-env-current-pc env)
 215                                 'assumed-length assumed-length
 216                                 'placeholder-cons encoded-proglist-reverse)))
 217                     (loop
 218                       (handler-case
 219                           (return-from proglist-encode-internal
 220                             (proglist-encode-internal (rest expr-rest)
 221                                                       (make-assemble-env
 222                                                        :symtab (symtab-add-frame (assemble-env-symtab env))
 223                                                        :current-pc (+ (assemble-env-current-pc env)
 224                                                                       (forward-reference-assumed-length fwd)))
 225                                                       (cons fwd forward-references)
 226                                                       encoded-proglist-reverse
 227                                                       optimize-teo))
 228                         (assumption-failed (af-condition)
 229                           (unless (eq fwd (assumption-failed-forward-reference af-condition))
 230                             (error af-condition)) ; decline
 231                           ;; (warn af-condition)
 232                           (setf (forward-reference-assumed-length fwd)
 233                             (assumption-failed-actual-length af-condition))
 234                           ;; The assumption failed, we'll retry with the length found at the
 235                           ;; time the label was actually resolved.
 236                           (values))))))))
 237              (INSTRUCTION
 238               (handler-case
 239                   (let ((datum (instruction-encode expr env optimize-teo)))
 240                     (push datum encoded-proglist-reverse)
 241                     (incf (assemble-env-current-pc env)
 242                           (imagpart datum)))
 243                 (unresolved-labels (ul-condition)
 244                   ;; we stumbled upon a label-reference that wasn't immediately
 245                   ;; resolvable. We assume it's a forward reference.
 246                   ;; First, reserve a cons-cell for this instruction to be encoded later
 247                   (push 'unresolved-forward-reference encoded-proglist-reverse)
 248                   ;; Now loop over the possible octet-lengths for this instruction.
 249                   ;; For each iteration, assume that octet-length, and if no exception is
 250                   ;; raised, the assumption holds and we break out of the loop with
 251                   ;; the RETURN-FROM form.
 252                   (loop for assumed-instr-length =
 253                         (guess-next-instruction-length expr
 254                                                        (unresolved-labels-labels ul-condition)
 255                                                        (rest expr-rest)
 256                                                        env)
 257                       do
 258                         #+ignore (warn "Trying for ~A at ~D with ~A octets.."
 259                                        expr (assemble-env-current-pc env) assumed-instr-length)
 260                         (let ((fwd (make-instance 'forward-reference-instruction
 261                                      'labels (unresolved-labels-labels ul-condition)
 262                                      'instruction expr
 263                                      'referring-pc (assemble-env-current-pc env)
 264                                      'assumed-length assumed-instr-length
 265                                      'placeholder-cons encoded-proglist-reverse)))
 266                           (handler-case
 267                               ;; if assumption holds, break out of the loop
 268                               (return-from proglist-encode-internal
 269                                 (proglist-encode-internal ; attempt to continue by recursion
 270                                  (rest expr-rest)
 271                                  (make-assemble-env
 272                                   :symtab (symtab-add-frame (assemble-env-symtab env))
 273                                   :current-pc (+ (assemble-env-current-pc env)
 274                                                  assumed-instr-length))
 275                                  (cons fwd forward-references)
 276                                  encoded-proglist-reverse
 277                                  optimize-teo))
 278                             (assumption-failed (af-condition)
 279                               (unless (eq fwd (assumption-failed-forward-reference af-condition))
 280                                 (error af-condition)) ; decline
 281                               ;; (warn "~A" af-condition)
 282                               ;; pop this length off the list of instr-length guesses
 283                               (assert (gethash expr *proglist-minimum-expr-size*) (expr)
 284                                 "Unable to encode ~A. Is the label too far away?" expr)
 285                               (pop (gethash expr *proglist-minimum-expr-size*))
 286                               ;; the assumption failed.
 287                               ;; now continue the dolist loop
 288                               (values)))))
 289                   (error "Unable to encode ~A. Is the label too far away? ~
 290                           [Should _really_ never get here!!]"
 291                          expr)))))))
 292   ;; When we get here, the whole proglist is encoded.
 293   (unless (null forward-references)
 294     (error "There were unresolved forward references: ~A"
 295            (mapcar #'forward-reference-labels
 296                    forward-references)))
 297   ;; success, return.
 298   (values (nreverse encoded-proglist-reverse)
 299           (assemble-env-symtab env)))
 300
 301
 302 (defun cbyte-to-octet-list (cbyte)
 303   (loop
 304       with value = (realpart cbyte)
 305       for i from (1- (imagpart cbyte)) downto 0
 306       collect (ldb (byte 8 (* 8 i)) value)))
 307
 308 (defun proglist-encode (result-type cpu-mode start-addr prog-list
 309                         &key (optimize-teo #'optimize-teo-smallest-no16)
 310                              (symtab-lookup nil))
 311   (let ((*cpu-mode* cpu-mode)
 312         (*symtab-lookup* symtab-lookup)
 313         (*proglist-minimum-expr-size* (make-hash-table :test #'eq)))
 314     (declare (special *symtab-lookup* *proglist-minimum-expr-size*))
 315     (multiple-value-bind (encoded-proglist symtab)
 316         (proglist-encode-internal prog-list
 317                                   (make-assemble-env :current-pc start-addr
 318                                                      :symtab (make-symtab))
 319                                   nil nil optimize-teo)
 320       (ecase result-type
 321         ((:cbytes)
 322          (values encoded-proglist symtab))
 323         ((:octet-list)
 324          (values (mapcan #'cbyte-to-octet-list encoded-proglist)
 325                  symtab))
 326         ((:octet-vector)
 327          (let* ((ep-size (loop for cbyte in encoded-proglist
 328                              summing (imagpart cbyte)))
 329                 (ep-vector (make-array ep-size
 330                                        :element-type '(unsigned-byte 8)
 331                                        :fill-pointer t)))
 332            (loop
 333                for cbyte in encoded-proglist
 334                with i = 0
 335                do (loop for bp from (1- (imagpart cbyte)) downto 0
 336                       do (setf (aref ep-vector i)
 337                            (ldb (byte 8 (* 8 bp)) (realpart cbyte)))
 338                       do (incf i))
 339                finally (return (values ep-vector symtab)))))))))
 340
 341
 342 (defun print-encoded-proglist (epl &optional (base-addr 0))
 343   (loop for cbyte in epl
 344       and counter from 0 by 1
 345       with pc = base-addr
 346       do (format t "~8,'0X: ~22<~{ ~2,'0X~}~;~> ~4D ~A~%"
 347                  pc
 348                  (cbyte-to-octet-list cbyte)
 349                  counter
 350                  (apply #'decode-octet-list (cbyte-to-octet-list cbyte)))
 351       do (incf pc (imagpart cbyte))))
 352
 353 (defun octet-list-to-bioctets (octet-list)
 354   (loop for oc on octet-list by #'cddr
 355       collect (let ((msb (first oc))
 356                     (lsb (or (second oc) 0)))
 357                 (dpb lsb (byte 8 8) msb))))