"Fossies" - the Fresh Open Source Software Archive

Member "txr-217/share/txr/stdlib/asm.tl" (10 Jun 2019, 27935 Bytes) of package /linux/misc/txr-217.tar.bz2:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "asm.tl": 216_vs_217.

    1 ;; Copyright 2018-2019
    2 ;; Kaz Kylheku <kaz@kylheku.com>
    3 ;; Vancouver, Canada
    4 ;; All rights reserved.
    5 ;;
    6 ;; Redistribution and use in source and binary forms, with or without
    7 ;; modification, are permitted provided that the following conditions are met:
    8 ;;
    9 ;; 1. Redistributions of source code must retain the above copyright notice, this
   10 ;;    list of conditions and the following disclaimer.
   11 ;;
   12 ;; 2. Redistributions in binary form must reproduce the above copyright notice,
   13 ;;    this list of conditions and the following disclaimer in the documentation
   14 ;;    and/or other materials provided with the distribution.
   15 ;;
   16 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
   17 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
   18 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
   19 ;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
   20 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
   21 ;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
   22 ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   23 ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
   24 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
   25 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   26 
   27 (load "vm-param")
   28 
   29 (defstruct oc-base nil
   30   (:method synerr (me fmt . args)
   31     (error `opcode @{me.symbol}: @fmt` . args))
   32 
   33   (:method chk-arg-count (me n syntax)
   34     (when (neq (length (rest syntax)) n)
   35       me.(synerr "~s arguments required; ~s is invalid"
   36                  n syntax)))
   37 
   38   (:method chk-arg-count-min (me n syntax)
   39     (when (< (length (rest syntax)) n)
   40       me.(synerr "~s arguments required; ~s is invalid"
   41                  n syntax)))
   42 
   43   (:method backpatch (me asm at offs)
   44     (asm-error `@{me.symbol} doesn't backpatch`)))
   45 
   46 (compile-only
   47   (defstruct assembler nil
   48     buf
   49     bstr
   50     (max-treg 0)
   51     (labdef (hash))
   52     (labref (hash))
   53     (:static imm-width (relate '(si mi bi) '(10 16 32)))
   54     (:static sign-bits (relate '(fixnum bignum chr) '(1 1 0)))
   55     (:static operand-name (relate '(si mi bi l r rs d ds n o)
   56                                   '("small immediate"
   57                                     "medium immediate"
   58                                     "big immediate"
   59                                     "label"
   60                                     "register operand"
   61                                     "register small operand"
   62                                     "register destination operand"
   63                                     "register small destination operand"
   64                                     "integer"
   65                                     "any object")))))
   66 
   67 (defmeth assembler :postinit (me)
   68   (cond
   69     (me.buf (set me.bstr (make-buf-stream me.buf)))
   70     (me.bstr (set me.buf (get-buf-from-stream me.bstr)))
   71     (t (set me.bstr (make-buf-stream)
   72             me.buf (get-buf-from-stream me.bstr)))))
   73 
   74 (defmeth assembler cur-pos (me)
   75   (seek-stream me.bstr 0 :from-current))
   76 
   77 (defmeth assembler set-pos (me pos)
   78   (seek-stream me.bstr pos :from-start))
   79 
   80 (defmeth assembler lookup-label (me sym oc)
   81   (condlet
   82     (((n [me.labdef sym])) n)
   83     (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym])
   84        0)))
   85 
   86 (defmeth assembler define-label (me sym)
   87   (let* ((pos me.(cur-pos))
   88          (ins (trunc pos 4)))
   89     (set [me.labdef sym] ins)
   90     (each ((entry (del [me.labref sym])))
   91       (tree-bind (oc . offs) entry
   92         me.(set-pos (* 4 offs))
   93         oc.(backpatch me (* 4 offs) ins)))
   94     me.(set-pos pos)
   95     ins))
   96 
   97 (defmeth assembler read-buf (me bytes)
   98   (let ((buf (make-buf bytes)))
   99     (when (neql (fill-buf buf 0 me.bstr) bytes)
  100       (asm-error "read past instruction block"))
  101     buf))
  102 
  103 (defmeth assembler put-word (me word)
  104   (let* ((buf (make-buf 0)))
  105     (buf-put-u32 buf 0 word)
  106     (put-buf buf 0 me.bstr)))
  107 
  108 (defmeth assembler put-insn (me code extension operand)
  109   (let ((word (logior (ash code 26) (ash extension 16) operand))
  110         (buf (make-buf 0)))
  111     (buf-put-u32 buf 0 word)
  112     (put-buf buf 0 me.bstr)))
  113 
  114 (defmeth assembler put-pair (me op1 op2)
  115   (let ((word (logior (ash op1 16) op2))
  116         (buf (make-buf 0)))
  117     (buf-put-u32 buf 0 word)
  118     (put-buf buf 0 me.bstr)))
  119 
  120 (defmeth assembler get-word (me)
  121   (let* ((buf me.(read-buf (sizeof uint32))))
  122     (buf-get-u32 buf 0)))
  123 
  124 (defmeth assembler get-insn (me)
  125   (let* ((buf me.(read-buf (sizeof uint32)))
  126          (word (buf-get-u32 buf 0)))
  127     (list (ash word -26)
  128           (logtrunc (ash word -16) 10)
  129           (logtrunc word 16))))
  130 
  131 (defmeth assembler get-pair (me)
  132   (let* ((buf me.(read-buf (sizeof uint32)))
  133          (word (buf-get-u32 buf 0)))
  134     (list (ash word -16) (logtrunc word 16))))
  135 
  136 (defmeth assembler immediate-fits-type (me arg operand-type)
  137   (and (member (typeof arg)
  138                '(fixnum chr))
  139        (<= (+ (width arg)
  140               [me.sign-bits (typeof arg)]
  141               2)
  142            [me.imm-width operand-type])))
  143 
  144 (defmeth assembler parse-args (me oc syntax pattern)
  145   (mapcar (lambda (type arg n)
  146             (let ((parg (caseql type
  147                           ((si mi bi)
  148                            (when me.(immediate-fits-type arg type)
  149                              arg))
  150                           (l (cond
  151                                ((is-label arg) me.(lookup-label arg oc))
  152                                ((integerp arg) arg)))
  153                           (n (if (integerp arg) arg))
  154                           (o arg)
  155                           ((r rs d ds)
  156                            (cond
  157                              ((null arg) 0)
  158                              ((consp arg)
  159                               (parse-compound-operand arg))
  160                              ((symbolp arg)
  161                               (parse-operand (symbol-name arg)))))
  162                           (t (asm-error "invalid arg type spec ~s" type)))))
  163               (unless (or parg (eq type 'o))
  164                 oc.(synerr "argument ~a of ~s invalid; ~a expected"
  165                            n syntax [me.operand-name type]))
  166               (when (and (member type '(d ds))
  167                          (or (zerop parg)))
  168                 oc.(synerr "argument ~a of ~s cannot be destination"
  169                            n syntax))
  170               (when (and (member type '(rs ds))
  171                          (not (small-op-p parg)))
  172                 oc.(synerr "argument ~a of ~s isn't a small register"
  173                            n syntax))
  174               (when (and (member type '(r rs d ds)) (< parg %lev-size%))
  175                 (set me.max-treg (max parg me.max-treg)))
  176               parg))
  177           pattern (rest syntax) (range 1)))
  178 
  179 (defmeth assembler asm-one (me syntax)
  180   (let ((oc (cond
  181               ((is-label syntax) [%oc-hash% 'label])
  182               ((consp syntax) [%oc-hash% (car syntax)]))))
  183     (unless oc
  184       (asm-error "invalid instruction ~s" syntax))
  185     oc.(asm me syntax)))
  186 
  187 (defmeth assembler asm (me insns)
  188   (each ((i insns))
  189     me.(asm-one i))
  190   (unless (empty me.labref)
  191     (asm-error "dangling label references"))
  192   (whenlet ((n (cdr [find-max me.labdef : cdr])))
  193     (unless (< -1 n (len me.buf))
  194       (asm-error "labels outside of code"))))
  195 
  196 (defmeth assembler dis-one (me)
  197   (tree-bind (code extension operand) me.(get-insn)
  198     (let ((oc [%oc-hash% code]))
  199       oc.(dis me extension operand))))
  200 
  201 (defmeth assembler dis (me)
  202   me.(set-pos 0)
  203   (build
  204     (while (< me.(cur-pos) (len me.buf))
  205       (add me.(dis-one)))))
  206 
  207 (defmeth assembler dis-listing (me : (stream *stdout*))
  208   (let ((p 0)
  209         (c 0)
  210         (l (len me.buf)))
  211     me.(set-pos p)
  212     (while (< p l)
  213       (let* ((dis me.(dis-one))
  214              (dis-txt (cat-str [mapcar tostringp dis] " "))
  215              (q me.(cur-pos)))
  216         (inc c)
  217         me.(set-pos p)
  218         (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt)
  219         (while (< (inc p 4) q)
  220           (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word)))
  221         me.(set-pos q)
  222         (set p q)))
  223     c))
  224 
  225 (defvarl %oc-list-builder% (new list-builder))
  226 
  227 (defvarl %oc-hash% (hash))
  228 
  229 (defparml %oc-code% 0)
  230 
  231 (defun asm-error (msg . args)
  232   (error `~s: @msg` 'assembler . args))
  233 
  234 (defun register-opcode (oc)
  235   %oc-list-builder%.(add oc)
  236   (set [%oc-hash% oc.symbol] oc)
  237   (set [%oc-hash% oc.code] oc))
  238 
  239 (defun is-label (obj)
  240   (or (keywordp obj)
  241       (and (symbolp obj)
  242            (not (symbol-package obj)))))
  243 
  244 (defun parse-compound-operand (cons)
  245   (tree-case cons
  246     ((sym arg)
  247      (when (< -1 arg %lev-size%)
  248        (caseq sym
  249          ((t) arg)
  250          (d (+ arg %lev-size%)))))
  251     ((sym arg1 arg2)
  252      (when (and (<= 0 arg1 %max-v-lev%)
  253                 (<= 0 arg2 %max-lev-idx%))
  254        (caseq sym
  255          (v (+ (* (ssucc arg1) %lev-size%) arg2)))))))
  256 
  257 (defun parse-operand (str)
  258   (cond
  259     ((r^$ #/t[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str)
  260      (int-str [str 1..:] 16))
  261     ((r^$ #/d[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str)
  262      (+ %lev-size% (int-str [str 1..:] 16)))
  263     ((r^$ #/v[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]/ str)
  264        (let ((lv (int-str [`0@{str[1..:]}` -5..-3] 16))
  265              (ix (int-str [str -3..:] 16)))
  266          (+ (* %lev-size% (ssucc lv)) ix)))))
  267 
  268 (defmacro with-lev-idx ((lev-var idx-var) val-expr . body)
  269   (with-gensyms (val-var)
  270     ^(let* ((,val-var ,val-expr)
  271             (,lev-var (ash ,val-var (macro-time (- %lev-bits%))))
  272             (,idx-var (logtrunc ,val-var %lev-bits%)))
  273        ,*body)))
  274 
  275 (defun operand-to-sym (val)
  276   (with-lev-idx (lv ix) val
  277     (caseql lv
  278       (0 (if (zerop ix)
  279            nil
  280            (intern (fmt "t~,03X" ix))))
  281       (1 (intern (fmt "d~,03X" ix)))
  282       (t (intern (fmt "v~,02X~,03X" (ppred lv) ix))))))
  283 
  284 (defun operand-to-exp (val)
  285   (with-lev-idx (lv ix) val
  286     (caseql lv
  287       (0 (if (zerop ix)
  288            nil
  289            ^(t ,ix)))
  290       (1 ^(d ,ix))
  291       (t ^(v ,(ppred lv) ,ix)))))
  292 
  293 (defun bits-to-obj (bits width)
  294   (let ((tag (logtrunc bits 2))
  295         (val (ash bits -2)))
  296     (caseq tag
  297       (1 (sign-extend val (- width 2)))
  298       (2 (chr-int val))
  299       (t (error "~s: bad immediate operand: ~x" 'assembler bits)))))
  300 
  301 (defun small-op-p (val)
  302   (with-lev-idx (lv ix) val
  303     (and (<= 0 ix %max-sm-lev-idx%)
  304          (<= 0 lv %max-sm-lev%))))
  305 
  306 (defun enc-small-op (val)
  307   (with-lev-idx (lv ix) val
  308     (logior (ash lv %sm-lev-bits%) ix)))
  309 
  310 (defun small-op-to-sym (sval)
  311   (let ((lv (ash sval (- %sm-lev-bits%)))
  312         (ix (logtrunc sval %sm-lev-bits%)))
  313     (operand-to-sym (+ (* lv %lev-size%) ix))))
  314 
  315 (defstruct backpatch-low16 nil
  316   (:method backpatch (me asm at offs)
  317     (tree-bind (hi lo) asm.(get-pair)
  318       asm.(set-pos at)
  319       asm.(put-pair hi offs))))
  320 
  321 (defstruct backpatch-high16 nil
  322   (:method backpatch (me asm at offs)
  323     (tree-bind (hi lo) asm.(get-pair)
  324       asm.(set-pos at)
  325       asm.(put-pair offs lo))))
  326 
  327 (defvarl %backpatch-low16% (new backpatch-low16))
  328 (defvarl %backpatch-high16% (new backpatch-high16))
  329 
  330 (defmacro defopcode (class symbol code . slot-defs)
  331   ^(symacrolet ((auto (pinc %oc-code%)))
  332      (defstruct ,class oc-base
  333        (:static symbol ',symbol)
  334        (:static code ,code)
  335        ,*slot-defs)
  336      (register-opcode (new ,class))))
  337 
  338 (defmacro defopcode-derived (class symbol code orig-class)
  339   ^(symacrolet ((auto (pinc %oc-code%)))
  340      (defstruct ,class ,orig-class
  341        (:static symbol ',symbol)
  342        (:static code ,code))
  343      (register-opcode (new ,class))))
  344 
  345 (defopcode op-label label nil
  346   (:method asm (me asm syntax)
  347     (unless (is-label syntax)
  348       asm.(synerr "label must be keyword or gensym"))
  349     asm.(define-label syntax))
  350 
  351   (:method dis (me asm extension operand)))
  352 
  353 (defopcode op-noop noop auto
  354   (:method asm (me asm syntax)
  355     me.(chk-arg-count 0 syntax)
  356     asm.(put-insn me.code 0 0))
  357 
  358   (:method dis (me asm extension operand)
  359     ^(,me.symbol)))
  360 
  361 (defopcode op-frame frame auto
  362   (:method asm (me asm syntax)
  363     me.(chk-arg-count 2 syntax)
  364     (tree-bind (lev size) asm.(parse-args me syntax '(n n))
  365       (unless (<= 2 lev %max-v-lev%)
  366         me.(synerr "level must range from 2 to ~a"
  367                    %max-v-lev%))
  368       (unless (<= 0 size %lev-size%)
  369         me.(synerr "size must range from 0 to ~a"
  370                    %lev-size%))
  371       asm.(put-insn me.code lev size)))
  372   (:method dis (me asm lev size)
  373     ^(,me.symbol ,lev ,size)))
  374 
  375 (defopcode-derived op-sframe sframe auto op-frame)
  376 
  377 (defopcode-derived op-dframe dframe auto op-frame)
  378 
  379 (defopcode op-end end auto
  380   (:method asm (me asm syntax)
  381     me.(chk-arg-count 1 syntax)
  382     (let ((res (car asm.(parse-args me syntax '(r)))))
  383       asm.(put-insn me.code 0 res)))
  384   (:method dis (me asm extension res)
  385     ^(,me.symbol ,(operand-to-sym res))))
  386 
  387 (defopcode-derived op-fin fin auto op-end)
  388 
  389 (defopcode-derived op-prof prof auto op-fin)
  390 
  391 (defopcode op-call call auto
  392   (:method asm (me asm syntax)
  393     me.(chk-arg-count-min 2 syntax)
  394     (let* ((nargs (pred (len syntax)))
  395            (syn-pat (repeat '(r) (succ nargs)))
  396            (funargs (ppred nargs))
  397            (args asm.(parse-args me syntax syn-pat)))
  398       asm.(put-insn me.code funargs (pop args))
  399       (while args
  400         (let ((x (pop args))
  401               (y (or (pop args) 0)))
  402           asm.(put-pair y x)))))
  403 
  404   (:method dis (me asm funargs arg0)
  405     (build
  406       (add me.symbol)
  407       (add (operand-to-sym arg0))
  408       (inc funargs 1)
  409       (while (> funargs 0)
  410         (dec funargs 2)
  411         (tree-bind (y x) asm.(get-pair)
  412           (add (operand-to-sym x))
  413           (unless (minusp funargs)
  414             (add (operand-to-sym y))))))))
  415 
  416 (defopcode-derived op-apply apply auto op-call)
  417 
  418 (defopcode op-gcall gcall auto
  419   (:method asm (me asm syntax)
  420     me.(chk-arg-count-min 2 syntax)
  421     (let* ((nargs (pred (len syntax)))
  422            (syn-pat (list* 'r 'n (repeat '(r) (sssucc nargs))))
  423            (funargs (ppred nargs))
  424            (args asm.(parse-args me syntax syn-pat)))
  425       asm.(put-insn me.code funargs (pop args))
  426       (while args
  427         (let ((x (pop args))
  428               (y (or (pop args) 0)))
  429           asm.(put-pair y x)))))
  430 
  431   (:method dis (me asm funargs arg0)
  432     (let ((first t))
  433       (build
  434         (add me.symbol)
  435         (add (operand-to-sym arg0))
  436         (inc funargs 1)
  437         (while (> funargs 0)
  438           (dec funargs 2)
  439           (tree-bind (y x) asm.(get-pair)
  440             (add (if (zap first) x (operand-to-sym x)))
  441             (unless (minusp funargs)
  442               (add (operand-to-sym y)))))))))
  443 
  444 (defopcode-derived op-gapply gapply auto op-gcall)
  445 
  446 (defopcode op-movrs movrs auto
  447   (:method asm (me asm syntax)
  448     me.(chk-arg-count 2 syntax)
  449     (tree-bind (dst src) asm.(parse-args me syntax '(d rs))
  450       asm.(put-insn me.code (enc-small-op src) dst)))
  451 
  452   (:method dis (me asm src dst)
  453     ^(,me.symbol ,(operand-to-sym dst) ,(small-op-to-sym src))))
  454 
  455 (defopcode op-movsr movsr auto
  456   (:method asm (me asm syntax)
  457     me.(chk-arg-count 2 syntax)
  458     (tree-bind (dst src) asm.(parse-args me syntax '(ds r))
  459       asm.(put-insn me.code (enc-small-op dst) src)))
  460 
  461   (:method dis (me asm dst src)
  462     ^(,me.symbol ,(small-op-to-sym dst) ,(operand-to-sym src))))
  463 
  464 (defopcode op-movrr movrr auto
  465   (:method asm (me asm syntax)
  466     me.(chk-arg-count 2 syntax)
  467     (tree-bind (dst src) asm.(parse-args me syntax '(d r))
  468       asm.(put-insn me.code 0 dst)
  469       asm.(put-pair 0 src)))
  470 
  471   (:method dis (me asm extension dst)
  472     (let ((src (cadr asm.(get-pair))))
  473       ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src)))))
  474 
  475 (defopcode op-mov-pseudo mov nil
  476   (:method asm (me asm syntax)
  477     (tree-bind (dst src) asm.(parse-args me syntax '(d r))
  478       (let ((real [%oc-hash% (cond
  479                                ((small-op-p dst) 'movsr)
  480                                ((small-op-p src) 'movrs)
  481                                (t 'movrr))]))
  482         real.(asm asm syntax)))))
  483 
  484 (defopcode op-movrsi movrsi auto
  485   (:method asm (me asm syntax)
  486     me.(chk-arg-count 2 syntax)
  487     (tree-bind (dst imm) asm.(parse-args me syntax '(d si))
  488       asm.(put-insn me.code (logtrunc (sys:bits imm) 10) dst)))
  489 
  490   (:method dis (me asm imm dst)
  491     ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 10))))
  492 
  493 (defopcode op-movsmi movsmi auto
  494   (:method asm (me asm syntax)
  495     me.(chk-arg-count 2 syntax)
  496     (tree-bind (dst imm) asm.(parse-args me syntax '(ds mi))
  497       asm.(put-insn me.code (enc-small-op dst)
  498                     (logtrunc (sys:bits imm) 16))))
  499 
  500   (:method dis (me asm dst imm )
  501     ^(,me.symbol ,(small-op-to-sym dst) ,(bits-to-obj imm 16))))
  502 
  503 (defopcode op-movrbi movrbi auto
  504   (:method asm (me asm syntax)
  505     me.(chk-arg-count 2 syntax)
  506     (tree-bind (dst imm) asm.(parse-args me syntax '(d bi))
  507       asm.(put-insn me.code 0 dst)
  508       asm.(put-word (logtrunc (sys:bits imm) 32))))
  509 
  510   (:method dis (me asm extension dst)
  511     (let ((imm asm.(get-word)))
  512       ^(,me.symbol ,(operand-to-sym dst) ,(bits-to-obj imm 32)))))
  513 
  514 (defopcode op-movi-pseudo movi nil
  515   (:method asm (me asm syntax)
  516     (tree-bind (dst src) asm.(parse-args me syntax '(d bi))
  517       (let ((real [%oc-hash% (cond
  518                                (asm.(immediate-fits-type src 'si) 'movrsi)
  519                                ((and asm.(immediate-fits-type src 'si)
  520                                      (small-op-p dst)) 'movsmi)
  521                                (t 'movrbi))]))
  522         real.(asm asm syntax)))))
  523 
  524 (defopcode op-jmp jmp auto
  525   (:method asm (me asm syntax)
  526     me.(chk-arg-count 1 syntax)
  527     (let ((dst (car asm.(parse-args me syntax '(l)))))
  528       asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))))
  529 
  530   (:method backpatch (me asm at dst)
  531     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
  532 
  533   (:method dis (me asm high16 low16)
  534     ^(,me.symbol ,(logior (ash high16 16) low16))))
  535 
  536 (defopcode op-if if auto
  537   (:method asm (me asm syntax)
  538     me.(chk-arg-count 2 syntax)
  539     (tree-bind (reg dst) asm.(parse-args me syntax '(r l))
  540       asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
  541       asm.(put-pair 0 reg)))
  542 
  543   (:method backpatch (me asm at dst)
  544     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
  545 
  546   (:method dis (me asm high16 low16)
  547     (let ((dst (logior (ash high16 16) low16))
  548           (reg (cadr asm.(get-pair))))
  549       ^(,me.symbol ,(operand-to-sym reg) ,dst))))
  550 
  551 (defopcode op-ifq ifq auto
  552   (:method asm (me asm syntax)
  553     me.(chk-arg-count 3 syntax)
  554     (tree-bind (lreg rreg dst) asm.(parse-args me syntax '(r r l))
  555       asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
  556       asm.(put-pair lreg rreg)))
  557 
  558   (:method backpatch (me asm at dst)
  559     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
  560 
  561   (:method dis (me asm high16 low16)
  562     (let ((dst (logior (ash high16 16) low16)))
  563       (tree-bind (lreg rreg) asm.(get-pair)
  564       ^(,me.symbol ,(operand-to-sym lreg) ,(operand-to-sym rreg) ,dst)))))
  565 
  566 (defopcode-derived op-ifql ifql auto op-ifq)
  567 
  568 (defopcode op-swtch swtch auto
  569   (:method asm (me asm syntax)
  570     me.(chk-arg-count-min 1 syntax)
  571     (let* ((args asm.(parse-args me syntax '(r)))
  572            (lbls (cddr syntax))
  573            (tblsz (len lbls)))
  574       asm.(put-insn me.code tblsz (car args))
  575       (while lbls
  576         (let ((x asm.(lookup-label (pop lbls) %backpatch-low16%))
  577               (y (if lbls
  578                    asm.(lookup-label (pop lbls) %backpatch-high16%)
  579                    0)))
  580           asm.(put-pair y x)))))
  581 
  582   (:method dis (me asm tblsz switch-val)
  583     (build
  584       (add me.symbol)
  585       (add (operand-to-sym switch-val))
  586       (while (> tblsz 0)
  587         (dec tblsz 2)
  588         (tree-bind (y x) asm.(get-pair)
  589           (add x)
  590           (unless (minusp tblsz)
  591             (add y)))))))
  592 
  593 (defopcode-derived op-uwprot uwprot auto op-jmp)
  594 
  595 (defopcode op-block block auto
  596   (:method asm (me asm syntax)
  597     me.(chk-arg-count 3 syntax)
  598     (tree-bind (outreg blname exitpt) asm.(parse-args me syntax '(d r l))
  599       asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16))
  600       asm.(put-pair outreg blname)))
  601 
  602   (:method backpatch (me asm at exitpt)
  603     asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16)))
  604 
  605  (:method dis (me asm high16 low16)
  606    (let ((exitpt (logior (ash high16 16) low16)))
  607      (tree-bind (outreg blname) asm.(get-pair)
  608        ^(,me.symbol ,(operand-to-sym outreg) ,(operand-to-sym blname)
  609                     ,exitpt)))))
  610 
  611 (defopcode op-retsr retsr auto
  612   (:method asm (me asm syntax)
  613     me.(chk-arg-count 2 syntax)
  614     (tree-bind (name reg) asm.(parse-args me syntax '(rs r))
  615       asm.(put-insn me.code (enc-small-op name) reg)))
  616 
  617   (:method dis (me asm name reg)
  618     ^(,me.symbol ,(small-op-to-sym name) ,(operand-to-sym reg))))
  619 
  620 (defopcode op-retrs retrs auto
  621   (:method asm (me asm syntax)
  622     me.(chk-arg-count 2 syntax)
  623     (tree-bind (name reg) asm.(parse-args me syntax '(r rs))
  624       asm.(put-insn me.code (enc-small-op reg) name)))
  625 
  626   (:method dis (me asm reg name)
  627     ^(,me.symbol ,(operand-to-sym name) ,(small-op-to-sym reg))))
  628 
  629 (defopcode op-retrr retrr auto
  630   (:method asm (me asm syntax)
  631     me.(chk-arg-count 2 syntax)
  632     (tree-bind (name reg) asm.(parse-args me syntax '(r r))
  633       asm.(put-insn me.code 0 reg)
  634       asm.(put-pair 0 name)))
  635 
  636   (:method dis (me asm extension reg)
  637     (let ((name (cadr asm.(get-pair))))
  638       ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg)))))
  639 
  640 (defopcode op-ret-pseudo ret nil
  641   (:method asm (me asm syntax)
  642     me.(chk-arg-count 2 syntax)
  643     (tree-bind (name reg) asm.(parse-args me syntax '(r r))
  644       (let ((real [%oc-hash% (cond
  645                                ((small-op-p name) 'retsr)
  646                                ((small-op-p reg) 'retrs)
  647                                (t 'retrr))]))
  648         real.(asm asm syntax)))))
  649 
  650 (defopcode-derived op-abscsr abscsr auto op-retsr)
  651 
  652 (defopcode op-catch catch auto
  653   (:method asm (me asm syntax)
  654     me.(chk-arg-count 5 syntax)
  655     (tree-bind (sym args catch-syms desc dst)
  656                asm.(parse-args me syntax '(d d r r l))
  657       asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
  658       asm.(put-pair sym args)
  659       asm.(put-pair desc catch-syms)))
  660 
  661   (:method backpatch (me asm at dst)
  662     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
  663 
  664  (:method dis (me asm high16 low16)
  665    (let ((dst (logior (ash high16 16) low16)))
  666      (tree-bind (sym args) asm.(get-pair)
  667        (tree-bind (desc catch-syms) asm.(get-pair)
  668          ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args)
  669                       ,(operand-to-sym catch-syms)
  670                       ,(operand-to-sym desc) ,dst))))))
  671 
  672 (defopcode op-handle handle auto
  673   (:method asm (me asm syntax)
  674     me.(chk-arg-count 2 syntax)
  675     (tree-bind (fun handle-syms) asm.(parse-args me syntax '(r r))
  676       asm.(put-insn me.code 0 fun)
  677       asm.(put-pair fun handle-syms)))
  678 
  679  (:method dis (me asm extension fun)
  680      (let ((handle-syms (cadr asm.(get-pair))))
  681        ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms)))))
  682 
  683 (defopcode op-getv getv auto
  684   (:method asm (me asm syntax)
  685     me.(chk-arg-count 2 syntax)
  686     (tree-bind (reg name) asm.(parse-args me syntax '(d r))
  687       (unless (small-op-p name)
  688         asm.(asm-one ^(mov (t 1) ,(operand-to-exp name)))
  689         (set name 1))
  690       asm.(put-insn me.code (enc-small-op name) reg)))
  691   (:method dis (me asm name reg)
  692     ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name))))
  693 
  694 (defopcode-derived op-oldgetf oldgetf auto op-getv)
  695 
  696 (defopcode-derived op-getl1 getl1 auto op-getv)
  697 
  698 (defopcode-derived op-getvb getvb auto op-getv)
  699 
  700 (defopcode-derived op-getfb getfb auto op-getv)
  701 
  702 (defopcode-derived op-getl1b getl1b auto op-getv)
  703 
  704 (defopcode op-setv setv auto
  705   (:method asm (me asm syntax)
  706     me.(chk-arg-count 2 syntax)
  707     (tree-bind (reg name) asm.(parse-args me syntax '(r r))
  708       (unless (small-op-p name)
  709         asm.(asm-one ^(mov (t 1) ,(operand-to-exp name)))
  710         (set name 1))
  711       asm.(put-insn me.code (enc-small-op name) reg)))
  712   (:method dis (me asm name reg)
  713     ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name))))
  714 
  715 (defopcode-derived op-setl1 setl1 auto op-setv)
  716 
  717 (defopcode-derived op-bindv bindv auto op-setv)
  718 
  719 (defopcode op-close close auto
  720   (:method asm (me asm syntax)
  721     me.(chk-arg-count-min 6 syntax)
  722     (let* ((syn-pat (repeat '(d) (- (length syntax) 7))))
  723       (tree-bind (reg frsize dst fix req vari . regs)
  724                  asm.(parse-args me syntax ^(d n l n n o ,*syn-pat))
  725         (unless (<= 0 frsize %lev-size%)
  726           me.(synerr "frame size must be 0 to ~a" %lev-size%))
  727         asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
  728         asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg)
  729         asm.(put-pair req fix)
  730         (unless (eql fix (- (len regs) (if vari 1 0)))
  731           me.(synerr "wrong number of registers"))
  732         (while regs
  733           (let ((x (pop regs))
  734                 (y (or (pop regs) 0)))
  735             asm.(put-pair y x))))))
  736 
  737   (:method backpatch (me asm at dst)
  738     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
  739 
  740   (:method dis (me asm high16 low16)
  741     (let ((dst (logior (ash high16 16) low16)))
  742       (tree-bind (vari-frsize reg) asm.(get-pair)
  743         (let ((vari (bit vari-frsize %lev-bits%)))
  744           (tree-bind (req fix) asm.(get-pair)
  745             (build
  746               (add me.symbol (operand-to-sym reg)
  747                    (logtrunc vari-frsize %lev-bits%)
  748                    dst fix req vari)
  749               (when vari
  750                 (inc fix))
  751               (while (> fix 0)
  752                 (dec fix 2)
  753                 (tree-bind (y x) asm.(get-pair)
  754                   (add (operand-to-sym x))
  755                   (unless (minusp fix)
  756                     (add (operand-to-sym y))))))))))))
  757 
  758 (defopcode op-getlx getlx auto
  759   (:method asm (me asm syntax)
  760     me.(chk-arg-count 2 syntax)
  761     (tree-bind (dst idx) asm.(parse-args me syntax '(d n))
  762       (cond
  763         ((small-op-p dst)
  764          asm.(put-insn me.code (enc-small-op dst) idx))
  765         (t asm.(put-insn me.code (enc-small-op 1) idx)
  766            asm.(asm-one ^(mov ,(operand-to-exp dst) t1))))))
  767   (:method dis (me asm dst idx)
  768     ^(,me.symbol ,(small-op-to-sym dst) ,idx)))
  769 
  770 (defopcode op-setlx setlx auto
  771   (:method asm (me asm syntax)
  772     me.(chk-arg-count 2 syntax)
  773     (tree-bind (src idx) asm.(parse-args me syntax '(r n))
  774       (cond
  775         ((small-op-p src)
  776          asm.(put-insn me.code (enc-small-op src) idx))
  777         (t asm.(asm-one ^(mov t1 ,(operand-to-exp src)))
  778            asm.(put-insn me.code (enc-small-op 1) idx)))))
  779   (:method dis (me asm src idx)
  780     ^(,me.symbol ,(small-op-to-sym src) ,idx)))
  781 
  782 (defopcode-derived op-getf getf auto op-getlx)
  783 
  784 (defun disassemble-cdf (code data funv *stdout*)
  785   (let ((asm (new assembler buf code)))
  786     (put-line "data:")
  787     (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) data)
  788     (put-line "syms:")
  789     (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) funv)
  790     (put-line "code:")
  791     (let ((ninsn asm.(dis-listing)))
  792       (put-line "instruction count:")
  793       (format t "~5d\n" ninsn))))
  794 
  795 (defun disassemble (obj : (stream *stdout*))
  796   (symacrolet ((self 'vm-disassemble-obj))
  797     (typecase obj
  798       (vm-desc (disassemble-cdf (vm-desc-bytecode obj)
  799                                 (vm-desc-datavec obj)
  800                                 (vm-desc-symvec obj)
  801                                 stream))
  802       (fun (unless (vm-fun-p obj)
  803              (error "~s: not a vm function: ~s" self obj))
  804            (let* ((clo (func-get-env obj))
  805                   (desc (sys:vm-closure-desc clo))
  806                   (ip (sys:vm-closure-entry clo)))
  807              (disassemble desc stream)
  808              (put-line "entry point:")
  809              (format stream "~5d\n" ip)))
  810       (t (iflet ((fun (symbol-function obj)))
  811            (disassemble fun stream)
  812            (error "~s: not a compiled object: ~s" self obj))))
  813     obj))