asm/asm.lisp

   1 (in-package :avm2-asm)
   2
   3
   4 ;;; for now just using keywords as opcode names...
   5 ;;; * possibly would be better to use an equal or equal-p hash table and look
   6 ;;;   up opcodes by name instead of symbol?
   7 ;;; * functions have some nice properties also:
   8 ;;;   + arglist hints from slime autodoc
   9 ;;;   + backtraces show specific opcode when we get an error in a opcode
  10 ;;;   + assemble is a bit shorter
  11 ;;;   - name clashes with CL functions make it messier though, so storing
  12 ;;;     opcodes in a hash...
  13 (defparameter *opcodes* (make-hash-table))
  14 (defparameter *disassemble-opcodes* (make-hash-table))
  15
  16 (defparameter +need-args+ #x01)
  17 (defparameter +need-activation+ #x02)
  18 (defparameter +need-rest+ #x04)
  19 (defparameter +has-optional+ #x08)
  20 (defparameter +set-dxns+ #x40)
  21 (defparameter +has-param-names+ #x80)
  22
  23 (defclass method-body ()
  24   ((method-id :initarg method :accessor method-id)
  25    (max-stack :initarg max-stack :accessor max-stack)
  26    (local-count :initarg local-count :accessor local-count)
  27    (init-scope-depth :initarg init-scope-depth :accessor init-scope-depth)
  28    (max-scope-depth :initarg max-scope-depth :accessor max-scope-depth)
  29    (code :initarg code :accessor code)
  30    (exceptions :initform nil :initarg exceptions :accessor exceptions)
  31    (traits :initform nil :initarg traits :accessor traits)
  32    ;; temporaries for tracking values during assembly
  33    (current-stack :initform 0 :accessor current-stack)
  34    (current-scope :initform 2 :initarg current-scope :accessor current-scope)
  35    (flags :initform 0 :accessor flags)
  36    (label :initform () :accessor label)
  37    (fixups :initform () :accessor fixups)))
  38
  39
  40 (defparameter *current-method* nil)
  41 (defparameter *code-offset* 0)
  42
  43 (defun assemble (forms)
  44   "simple assembler, returns sequence of octets containing the
  45   bytecode corresponding to forms, interns stuff as needed, or
  46   optionally uses constant pool indices (with no error checking
  47   currently) when operand is a list of the form (:id ###). "
  48   (let ((*code-offset* 0))
  49     (loop for i in (peephole forms)
  50        for opcode = (gethash (car i) *opcodes*)
  51        for octets = (when opcode (apply opcode (cdr i)))
  52        if opcode
  53        append octets
  54        ;;and do (format t "assemble ~s-> ~s ofs = ~s + ~s ~%"
  55        ;;               i octets *code-offset* (length octets))
  56        and do (incf *code-offset* (length octets))
  57        else do (error "invalid opcode ~s " i))))
  58
  59 (defun assemble-method-body (forms &key (init-scope 0)
  60                              (max-scope 1 max-scope-p)
  61                              (max-stack 1 max-stack-p))
  62   (let ((*current-method* (make-instance 'method-body
  63                                          'local-count 1
  64                                          'max-stack 1
  65                                          'init-scope-depth init-scope
  66                                          'max-scope-depth init-scope
  67                                          'current-scope init-scope)))
  68     (setf (code *current-method*)
  69           (assemble forms))
  70     (when max-stack-p
  71       (setf (max-stack *current-method*) max-stack))
  72     (when max-scope-p
  73       (setf (max-scope-depth *current-method*) (+ init-scope max-scope)))
  74     (when (fixups *current-method*)
  75       ;; fix any fixups
  76       (loop for (label addr base) in (fixups *current-method*)
  77          for dest = (cdr (assoc label (label *current-method*)))
  78          when  dest
  79          do (replace (code *current-method*)
  80                      (u24-to-sequence (- dest base))
  81                      :start1 (+ 1 addr ))
  82          else do (error "!!!!! unknown fixup ~s !!! ~%" label)))
  83     *current-method*))
  84
  85
  86 (defun u16-to-sequence (u16)
  87   (list
  88     (ldb (byte 8 0) u16)
  89     (ldb (byte 8 8) u16)))
  90
  91 (defun u24-to-sequence (u24)
  92   (list
  93     (ldb (byte 8 0) u24)
  94     (ldb (byte 8 8) u24)
  95     (ldb (byte 8 16) u24)))
  96
  97 (defun double-to-sequence (double)
  98   (loop with d =  (ieee-floats::encode-float64 double)
  99      for i from 0 below 64 by 8
 100      collect (ldb (byte 8 i) d)))
 101
 102
 103 (defun counted-s24-to-sequence (seq)
 104   (append
 105    (variable-length-encode (length seq))
 106    (mapcan 'u24-to-sequence seq)))
 107
 108 (defun count+1-s24-to-sequence (seq)
 109   (append
 110    (variable-length-encode (1- (length seq)))
 111    (mapcan 'u24-to-sequence seq)))
 112
 113 (defun variable-length-encode (integer)
 114   (loop
 115    for i = integer then i2
 116    for i2 = (ash i -7)
 117    for b = (ldb (byte 7 0) i)
 118    for done = (or (= i2 0) (= i2 -1))
 119    when (not done)
 120    do (setf b (logior #x80 b))
 121    collect b
 122    until done))
 123
 124 ;;; fixme: these should probably avoid repeated elt calls if seq is a list
 125 (defun decode-u16 (sequence &key (start 0))
 126   (values
 127    (logior (elt sequence start)
 128            (ash (elt sequence (1+ start)) 8))
 129    (+ 2 start)))
 130
 131 (defun decode-u24 (sequence &key (start 0))
 132   (values
 133    (logior (elt sequence start)
 134            (ash (elt sequence (+ 1 start)) 8)
 135            (ash (elt sequence (+ 2 start)) 16))
 136    (+ 3 start)))
 137
 138 (defun decode-variable-length (sequence &key (start 0))
 139   (loop with sum = 0
 140      for i from start
 141      for offset from 0 by 7
 142      for j = (elt sequence i)
 143      do (setf (ldb (byte 7 offset) sum) (ldb (byte 7 0) j))
 144      while (logbitp 7 j)
 145      finally (return (values sum (1+ i)))))
 146
 147 (defun decode-counted-s24 (sequence &key (start 0))
 148   (multiple-value-bind (count start)
 149       (decode-variable-length sequence :start start)
 150     (values
 151      (loop repeat (1+ count)
 152         with value
 153         do (setf (values value start) (decode-u24 sequence :start start))
 154         collect value)
 155      start)))
 156
 157 ;;; new types for automatic interning
 158 ;;; (many of these probably just map to the same qname code, but
 159 ;;;   separating just in case)
 160 ;; string-u30 int-u30 uint-u30 double-u30 namespace-q30 multiname-q30 class-u30
 161 ;; fix runtime-name-count? or just set arg to index after interning
 162 ;;   and before calling arg count stuff?
 163
 164 ;;; todo: figure out if these need handled:
 165 ;;;     method-index arg for :new-function
 166 ;;;     slot-index for :get-slot/:set-slot/etc
 167 ;;;     exception-index for new-catch
 168
 169 ;(decode-u16 (u16-to-sequence 12345))
 170 ;(decode-u24 (u24-to-sequence 12345))
 171 ;(decode-u24 (u24-to-sequence 123456))
 172 ;(decode-variable-length (variable-length-encode 1))
 173 ;(decode-variable-length (variable-length-encode 127))
 174 ;(decode-variable-length (variable-length-encode 128))
 175 ;(decode-variable-length (variable-length-encode 256))
 176 ;(decode-variable-length (variable-length-encode 12345))
 177 ;(decode-variable-length (variable-length-encode 123456789))
 178 ;(decode-counted-s24 (counted-s24-to-sequence '(1 2 3 4 5)))
 179 ;(decode-counted-s24 (counted-s24-to-sequence '(12345 2 345678 4 5)))
 180 (decode-variable-length '(#b10000010 #b1))    ; 130
 181 (decode-variable-length '(#b1))          ; 1
 182 (decode-variable-length '(#b10010110 #b11))
 183
 184 (defun avm2-disassemble (sequence &key (start 0))
 185   (loop
 186      for length = (length sequence)
 187      with op = nil
 188      for byte = (elt sequence start)
 189      for dis = (gethash byte *disassemble-opcodes*)
 190      ;;do (format t "op=~s byte=~s start=~s cur-seq=~{ ~2,'0x~}~%   dis=~s ~%"
 191      ;;           op byte start (coerce
 192      ;;                          (subseq sequence start (min length
 193      ;;                                                      (+ start 8))) 'list) dis)
 194      ;;  (finish-output)
 195      do (incf start)
 196      when dis
 197      do (setf (values op start) (funcall dis sequence :start start))
 198      ;;and do (format t "op -> ~s start -> ~s~%" op start)
 199      and collect op
 200      else do (error "invalid byte ~s at ~d " byte start)
 201      while (< start length)))
 202
 203
 204 ;;; these don't actually work in general, since they don't take
 205 ;;; branching into account, but simplifies things for now...
 206 (defun adjust-stack (pop push)
 207   (when *current-method*
 208     (decf (current-stack *current-method*) pop)
 209     ;;(when (< (current-stack *current-method*) 0)
 210     ;;  (error "assembler error : stack underflow !"))
 211     (incf (current-stack *current-method*) push)
 212     (when (> (current-stack *current-method*)
 213              (max-stack *current-method*))
 214       (setf (max-stack *current-method*)
 215             (current-stack *current-method*)))))
 216
 217 (defun adjust-scope (pop push)
 218   (when *current-method*
 219     (decf (current-scope *current-method*) pop)
 220     ;;(when (< (current-scope *current-method*) 0)
 221     ;;  (error "assembler error : scope underflow !"))
 222     (incf (current-scope *current-method*) push)
 223     (when (> (current-scope *current-method*)
 224              (max-scope-depth *current-method*))
 225       (setf (max-scope-depth *current-method*)
 226             (current-scope *current-method*)))))
 227
 228 (macrolet
 229     ((make-interner (intern-name lookup-name interner pool)
 230        `(progn
 231           (defun ,intern-name (value)
 232             (if (typep value '(cons (eql :id)))
 233                 (second value)
 234                 (,interner value)))
 235           (defun ,lookup-name (value)
 236             (if *assembler-context*
 237                 (aref (,pool *assembler-context*) value)
 238                 (list :id value))))))
 239
 240   (make-interner asm-intern-string lookup-string avm2-string strings)
 241   ;; fixme: avm2-intern-* can break if first thing interned is wrong type
 242   (make-interner asm-intern-int lookup-int avm2-intern-int ints)
 243   (make-interner asm-intern-uint lookup-uint avm2-intern-uint uints)
 244   (make-interner asm-intern-double lookup-double avm2-intern-double doubles)
 245   (make-interner asm-intern-namespace lookup-namespace avm2-ns-intern namespaces))
 246 ;; (asm-intern-string "foo")
 247 ;; (asm-intern-string '(:id 2))
 248 ;; (asm-intern-string :id)
 249 ;; (asm-intern-int 1232)
 250 ;; (asm-intern-int '(:id 3))
 251 ;; x(asm-intern-int :id) ;; should fail even if no ints interned yet, but doesn't
 252
 253
 254 (defun symbol-to-qname-list (name &key init-cap)
 255   ;; just a quick hack for now, doesn't actually try to determine if
 256   ;; there is a valid property or not...
 257   (let ((package (symbol-package name))
 258         (sym (coerce
 259               (loop
 260                  for prev = (if init-cap #\- #\Space) then c
 261                  for c across (symbol-name name)
 262                  when (or (not (alpha-char-p prev)) (char/= c #\-))
 263                  collect (if (char= prev #\-)
 264                              (char-upcase c)
 265                              (char-downcase c)))
 266               'string)))
 267     (if (eql package (find-package :keyword))
 268         (setf package "")
 269         (setf package (string-downcase (or (package-name package) ""))))
 270     (values (list :qname package sym) sym)))
 271
 272 ;; fixme: not sure we want this anymore, instead store a symbol->qname
 273 ;; hash in compiler-context, and use that for lookups?
 274 ;;; --- still used by defun stuff, so keeping for now... not calling automatically any more though, need to actually have a valid *symbol-table*
 275 (defun symbol-to-qname-old (name &key init-cap)
 276   ;; just a quick hack for now, doesn't actually try to determine if
 277   ;; there is a valid property or not...
 278   (let ((package (symbol-package name))
 279         (sym (coerce
 280               (loop
 281                  for prev = (if init-cap #\- #\Space) then c
 282                  for c across (symbol-name name)
 283                  when (or (not (alpha-char-p prev)) (char/= c #\-))
 284                  collect (if (char= prev #\-)
 285                              (char-upcase c)
 286                              (char-downcase c)))
 287               'string)))
 288     (if (eql package (find-package :keyword))
 289         (setf package "")
 290         (setf package (string-downcase (or (package-name package) ""))))
 291     (values (avm2-asm::qname package sym) sym)))
 292
 293 (defun asm-intern-multiname (mn)
 294   (typecase mn
 295     ((cons (eql :qname)) (apply 'qname (cdr mn)))
 296     ((cons (eql :multiname-l)) (apply 'intern-multiname-l +multiname-l+ (cdr mn)))
 297     ;; todo: add other types of multinames
 298     ((cons (eql :id)) (second mn))
 299     (symbol (apply 'qname (cdr (symbol-to-qname-list mn)))) ;; not sure if this is good or not, needed for calling as-yet undefined functions though...
 300     (t (parsed-qname mn))))
 301 ;; (asm-intern-multiname '(:qname "foo" "bar"))
 302 ;; (asm-intern-multiname '(:id 321))
 303 ;; (asm-intern-multiname "foo:bax")
 304 ;; (asm-intern-multiname '(:qname "foo" "bax"))
 305 ;; (asm-intern-multiname '(:qname "foo" "bax"))
 306 ;; x(asm-intern-multiname 'cos) ;; not sure if we should support symbols or not
 307 ;;(intern-multiname +multiname-l+ "" "") (elt (multinames *assembler-context*) 1)
 308
 309
 310 (defparameter *multiname-kinds* (make-hash-table))
 311 (setf (gethash +qname+ *multiname-kinds*) :qname)
 312 (setf (gethash +qname-a+ *multiname-kinds*) :qname-a)
 313 (setf (gethash +rt-qname+ *multiname-kinds*) :rt-qname)
 314 (setf (gethash +rt-qname-a+ *multiname-kinds*) :rt-qname-a)
 315 (setf (gethash +rt-qname-l+ *multiname-kinds*) :rt-qname-l)
 316 (setf (gethash +rt-qname-la+ *multiname-kinds*) :rt-qname-la)
 317 (setf (gethash +multiname+ *multiname-kinds*) :multiname)
 318 (setf (gethash +multiname-a+ *multiname-kinds*) :multiname-a)
 319 (setf (gethash +multiname-l+ *multiname-kinds*) :multiname-l)
 320 (setf (gethash +multiname-la+ *multiname-kinds*) :multiname-la)
 321
 322 (defun lookup-multiname (id)
 323   (if (boundp '*assembler-context*)
 324       (destructuring-bind (kind ns name)
 325           (elt (multinames *assembler-context*) id)
 326         (list (gethash kind *multiname-kinds* kind)
 327               (elt (strings *assembler-context*)
 328                    (second (elt (namespaces *assembler-context*) ns)))
 329               (elt (strings *assembler-context*) name)))
 330       (list :id id)))
 331
 332 (defun label-to-offset (name op)
 333   (let ((dest (gensym "DEST-"))
 334         (here (gensym "HERE-"))
 335         (ofs (if (eq op :lookup-switch) 0 4)))
 336     `(when (symbolp ,name)
 337        (let ((,dest (cdr (assoc ,name (label *current-method*))))
 338              (,here *code-offset*))
 339          (unless ,dest
 340            (push (list ,name ,here (+ ,here ,ofs)) (fixups *current-method*))
 341            (setf ,dest (+ 4 ,here)))
 342          (setf ,name (- ,dest ,here ,ofs))))))
 343
 344 (defun labels-to-offsets (name)
 345   (let ((dest (gensym "DEST-"))
 346         (here (gensym "HERE-"))
 347         (i (gensym "I-"))
 348         (j (gensym "J-")))
 349     `(setf ,name
 350            (loop with ,here = *code-offset*
 351               for ,i in ,name
 352               for ,j from 4 by 4
 353               when (symbolp ,i)
 354               collect
 355                 (let ((,dest (cdr (assoc ,i (label *current-method*)))))
 356                   (unless ,dest
 357                     (push (list ,i (+ ,here ,j) ,here)
 358                           (fixups *current-method*))
 359                     (setf ,dest ,here))
 360                   (- ,dest ,here 0))
 361               else collect ,i
 362               ))))
 363
 364 (defmacro define-ops (&body ops)
 365   (let ((coders
 366          ;; type tag , encoder , optional interner
 367          `((u8  list)
 368            (u16  u16-to-sequence)
 369            (u24  u24-to-sequence)
 370            (s24  u24-to-sequence)
 371            (ofs24  u24-to-sequence) ;; for using labels directly in branches
 372            (u30  variable-length-encode)
 373            (q30  variable-length-encode) ;; hack for name interning
 374            (u32  variable-length-encode)
 375            (s32  variable-length-encode)
 376            (double  double-to-sequence)
 377            (counted-s24  counted-s24-to-sequence)
 378            (counted-ofs24  count+1-s24-to-sequence)
 379
 380            (string-u30    variable-length-encode asm-intern-string)
 381            (int-u30       variable-length-encode asm-intern-int)
 382            (uint-u30      variable-length-encode asm-intern-uint)
 383            (double-u30    variable-length-encode asm-intern-double)
 384            (namespace-q30 variable-length-encode asm-intern-namespace)
 385            (multiname-q30 variable-length-encode asm-intern-multiname)
 386            (class-u30     variable-length-encode asm-intern-class)
 387            ))
 388         (decoders
 389          ;; type tag, decoder, optional constant pool lookup function
 390          `((u8  (lambda (s &key (start 0)) (elt s start)))
 391            (u16  decode-u16)
 392            (u24  decode-u24)
 393            (s24  decode-u24)
 394            (ofs24  decode-u24) ;; for using labels directly in branches
 395            (u30  decode-variable-length)
 396            (q30  decode-variable-length) ;; hack for name interning
 397            (u32  decode-variable-length)
 398            (s32  decode-variable-length)
 399            (double  (lambda (s) (error "not done")))
 400            (counted-s24  decode-counted-s24)
 401            (counted-ofs24  decode-counted-s24) ;; array of ofs24 in lookupswitch
 402
 403            (string-u30    decode-variable-length lookup-string)
 404            (int-u30       decode-variable-length lookup-int)
 405            (uint-u30      decode-variable-length lookup-uint)
 406            (double-u30    decode-variable-length lookup-double)
 407            (namespace-q30 decode-variable-length lookup-namespace)
 408            (multiname-q30 decode-variable-length lookup-multiname)
 409            (class-u30     decode-variable-length lookup-class)
 410 )))
 411     (flet ((defop (name args opcode
 412                         &optional (pop 0) (push 0) (pop-scope 0) (push-scope 0) (local 0) (flag 0))
 413              `(setf (gethash ',name *opcodes*)
 414                     (flet ((,name (,@(mapcar 'car args))
 415                              ,@(when args `((declare (ignorable ,@(mapcar 'car args)))))
 416                              ,@(loop with op-name = name
 417                                   for (name type) in args
 418                                   for interner = (third (assoc type coders))
 419                                   when interner
 420                                   collect `(setf ,name (,interner ,name))
 421                                   when (eq 'ofs24 type)
 422                                   collect (label-to-offset name op-name)
 423                                   when (eq 'counted-ofs24 type)
 424                                   collect (labels-to-offsets name))
 425                              ,@(unless (and (numberp pop) (numberp push) (= 0 pop push))
 426                                        `((adjust-stack ,pop ,push)))
 427                              ,@(unless (and (numberp pop-scope) (numberp push-scope)
 428                                             (= 0 pop-scope push-scope))
 429                                        `((adjust-scope ,pop-scope ,push-scope)))
 430                              ,@(unless (and (numberp local) (zerop local))
 431                                        `((when (and *current-method*
 432                                                     (> ,local (local-count *current-method*)))
 433                                            (setf (local-count *current-method*) ,local))))
 434                              ,@(unless (and (numberp flag) (zerop flag))
 435                                        `((when *current-method*
 436                                            (setf (flags *current-method*)
 437                                                  (logior ,local (flags *current-method*))))))
 438                              ,(if (null args)
 439                                   `(list ,opcode)
 440                                   `(append
 441                                     (list ,opcode)
 442                                     ,@(loop
 443                                          for (name type) in args
 444                                          for encoder = (second (assoc type coders))
 445                                          when encoder
 446                                          collect `(,encoder ,name))))))
 447                       #',name)))
 448            ;; fixme: gensyms
 449            (defop-disasm (name args opcode &rest ignore)
 450              (declare (ignore ignore))
 451              `(setf (gethash ,opcode *disassemble-opcodes*)
 452                     (flet ((,name (sequence &key (start 0))
 453                              (declare (ignorable sequence start))
 454                              (values
 455                                ,(if (null args)
 456                                     `(list ',name)
 457                                     `(let (junk)
 458                                        (list ',name
 459                                              ,@(loop for (name type) in args
 460                                                      for (nil decoder lookup) = (assoc type decoders)
 461                                                      collect`(progn
 462                                                                (setf (values junk start)
 463                                                                      (,decoder sequence :start start))
 464                                                                ,@(when lookup
 465                                                                    `((,lookup junk))))))))
 466                                start)))
 467                       #',name
 468 ))))
 469       `(progn
 470          ,@(loop for op in ops
 471               collect (apply #'defop op)
 472               collect (apply #'defop-disasm op))))))
 473
 474
 475 (defmacro define-asm-macro (name (&rest args) &body body)
 476   `(setf (gethash ',name *opcodes*)
 477          (lambda (,@args)
 478            ,@body)))
 479
 480 ;;; not sure if these should be handled like this or not...
 481 (define-asm-macro :%label (name)
 482   (push (cons name *code-offset*) (label *current-method*))
 483   (assemble `((:label))))
 484
 485
 486 (define-asm-macro :%dlabel (name)
 487   ;; !!!! if this gets moved somewhere before the peephole optimizer, make
 488   ;; !!!! sure it leaves a nop of some sort in the instruction stream so we
 489   ;; !!!! don't combine stuff on either side of a jump target
 490   ;; for forward jumps, just mark the location but don't put a label instr
 491   (push (cons name *code-offset*) (label *current-method*))
 492   nil)
 493
 494
 495 (defmacro with-assembler-context (&body body)
 496   `(let ((*assembler-context* (make-instance 'assembler-context)))
 497      ,@body))
 498
 499 ;;; not sure if this should be asm level or not...
 500 (define-asm-macro :%array-read (index)
 501   (assemble `((:push-int ,index)
 502               (:get-property (:multiname-l "" "")))))