asm/junk.lisp

   1
   2
   3 ;;; using functions for opcodes lets SLIME autodoc give arglist hints,
   4 ;;; but we get conflicts with CL function names, so just using symbols
   5 ;;; for now...
   6
   7 (defun assemble (forms)
   8   "simple assembler, returns sequence of octets containing the
   9   bytecode corresponding to forms, doesn't currently do any interning,
  10   so pass indices into constant pool instead of actual values"
  11   (format t "assembling :~%---------~% ~s~%-------~%" forms)
  12   (let ((*code-offset* 0))
  13     (loop for i in (peephole forms)
  14        for octets = (apply #'funcall i)
  15        append octets
  16        do (format t "assemble ~s-> ~s ofs = ~s + ~s ~%"
  17                       i octets *code-offset* (length octets))
  18        do (incf *code-offset* (length octets)))))
  19
  20 (defmacro define-ops (&body ops)
  21   (let ((coders
  22          `((u8 . list)
  23            (u16 . u16-to-sequence)
  24            (u24 . u24-to-sequence)
  25            (s24 . u24-to-sequence)
  26            (ofs24 . u24-to-sequence) ;; for using labels directly in branches
  27            (u30 . variable-length-encode)
  28            (q30 . variable-length-encode) ;; hack for name interning
  29            (u32 . variable-length-encode)
  30            (s32 . variable-length-encode)
  31            (double . double-to-sequence)
  32            (counted-s24 . counted-s24-to-sequence))))
  33     (flet ((defop (name args opcode
  34                         &optional (pop 0) (push 0) (pop-scope 0) (push-scope 0) (local 0) (flag 0))
  35              `(defun ,name ,(mapcar 'car args)
  36                 ,@(when args `((declare (ignorable ,@(mapcar 'car args)))))
  37                 ;;(format t "assemble ~a ~%" ',name)
  38                 ,@(loop
  39                      for (name type) in args
  40                      when (eq 'q30 type)
  41                      collect `(when (and (consp ,name)
  42                                          (eql 'qname (car ,name)))
  43                                 (setf ,name (apply 'qname (rest ,name))))
  44                      when (eq 'ofs24 type)
  45                      collect
  46                      (let ((dest (gensym "DEST-"))
  47                            (here (gensym "HERE-")))
  48                        `(when (symbolp ,name)
  49                           (let ((,dest (cdr (assoc ,name (label *current-method*))))
  50                                 (,here *code-offset*))
  51                             (unless ,dest
  52                               (push (cons ,name ,here) (fixups *current-method*))
  53                               (setf ,dest (+ 4 ,here)))
  54                             (setf ,name (- ,dest ,here 4))
  55                             #+ (or) (format t ">>>set ~s to ~s" ',name ,name)))))
  56                 ,@(unless (and (numberp pop) (numberp push) (= 0 pop push))
  57                           `((adjust-stack ,pop ,push)))
  58                 ,@(unless (and (numberp pop-scope) (numberp push-scope)
  59                                (= 0 pop-scope push-scope))
  60                           `((adjust-scope ,pop-scope ,push-scope)))
  61                 ,@(unless (and (numberp local) (zerop local))
  62                           `((when (and *current-method*
  63                                        (> ,local (local-count *current-method*)))
  64                               (setf (local-count *current-method*) ,local))))
  65                 ,@(unless (and (numberp flag) (zerop flag))
  66                           `((when *current-method*
  67                               (setf (flags *current-method*)
  68                                     (logior ,local (flags *current-method*))))))
  69                 ,(if (null args)
  70                      `(list ,opcode)
  71                      `(append
  72                        (list ,opcode)
  73                        ,@(loop
  74                             for (name type) in args
  75                             for encoder = (cdr (assoc type coders))
  76                             when encoder
  77                             collect `(,encoder ,name)))))))
  78       `(progn
  79          ,@(loop for op in ops
  80               collect (apply #'defop op))))))