Untitled

This is Google&#39;s cache of http://www.pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/. It is a snapshot of the page as it appeared on Mar 16, 2014 00:25:28 GMT. The current page could have changed in the meantime. Learn moreTip: To quickly find your search term on this page, press Ctrl+F or ⌘-F (Mac) and use the find bar.Text-only version
&nbsp;
  SBCL: the ultimate assembly code breadboard - Paul Khuong mostly on Lisp
  <meta name="description" content="Earlier this week, I took another look at the
F18. As usual with Chuck Moore&#8217;s
work, it&#8217;s hard to tell the difference between insanity &hellip;">
    MathJax.Hub.Config({
    TeX: {
      Macros: {
       sp: "^",
       sb: "_"
      }
    }});
 <script type="text/javascript"
         src="http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML">
  Paul Khuong mostly on Lisp
  RSS
  Blog
  Archives
      SBCL: The Ultimate Assembly Code Breadboard
Mar 15th, 2014
Earlier this week, I took another look at the
F18.  As usual with Chuck Moore&#8217;s
work, it&#8217;s hard to tell the difference between insanity and mere
brilliance ;) One thing that struck me is how small the stack is: 10
slots, with no fancy overflow/underflow trap.  The rationale is that,
if you need more slots, you&#8217;re doing it wrong, and that silent
overflow is useful when you know what you&#8217;re doing.  That certainly
jibes with my experience on the HP-41C and with x87.  It also reminds
me of a
post of djb&#8217;s decrying our misuse of x87&#8217;s rotating stack:
his thesis was that, with careful scheduling, the &#8220;free&#8221; FXCH makes
the stack equivalent &#8211; if not superior &#8211; to registers.  The post
ends with a (non-pipelined) loop that wastes no cycle on shuffling
data, thanks to the x87&#8217;s implicit stack rotation.
That lead me to wonder what implementation techniques become available
for stack-based VMs that restrict their stack to, e.g., 8 slots.
Obviously, it would be ideal to keep everything in registers.
However, if we do that naïvely, push and pop become a lot more
complicated; there&#8217;s a reason why Forth engines usually cache only the
top 1-2 elements of the stack.
I decided to mimic the x87 and the F18: pushing/popping doesn&#8217;t cause
any data movement.  Instead, like the drawing below shows, they
decrement/increment a modular counter that points to the top of the
stack (TOS).  That would still be slow in software (most ISAs can&#8217;t
index registers).  The key is that the counter can&#8217;t take too many
values: only 8 values if there are 8 slots in the stack.  Stack VMs
already duplicate primops for performance reasons (e.g., to help the
BTB by spreading out execution of the same primitive between multiple
addresses), so it seems reasonable to specialise primitives for all 8
values the stack counter can take.
In a regular direct threaded VM, most primops would end with a code
sequence that jumps to the next one (NEXT), something like
add rsi, 8  ; increment virtual IP before jumping
jmp [rsi-8] ; jump to the address RSI previously pointed to
where rsi is the virtual instruction pointer, and VM instructions
are simply pointers to the machine code for the relevant primitive.
I&#8217;ll make two changes to this sequence.  I don&#8217;t like hardcoding
addresses in bytecode, and 64 bits per virtual instruction is overly
wasteful.  Instead, I&#8217;ll encode offsets from the primop code block:
mov eax, [rsi]
add rsi, 4
add rax, rdi
jmp rax
where rdi is the base address for primops.
I also need to dispatch based on the new value of the implicit stack
counter.  I decided to make the dispatch as easy as possible by
storing the variants of each primop at regular intervals (e.g. one
page).  I rounded that up to 64 * 67 = 4288 bytes to minimise
aliasing accidents.  NEXT becomes something like
mov eax, [rsi]
add rsi, 4
lea rax, [rax + rdi + variant_offset]
jmp rax
The trick is that variant_offset = 4288 * stack_counter, and the
stack counter is (usually) known when the primitive is compiled.  If
the stack is left as is, so is the counter; pushing a value decrements
the counter and popping one increments it.
That seems reasonable enough.  Let&#8217;s see if we can make it work.
Preliminaries
I want to explore a problem for which I&#8217;ll emit a lot of repetitive
machine code.  SLIME&#8217;s REPL and SBCL&#8217;s assembler are perfect for the
task!  (I hope it&#8217;s clear that I&#8217;m using unsupported internals; if it
breaks, you keep the pieces.)
The basic design of the VM is:
r8-r15: stack slots (32 bits);
rsi: base address for machine code primitives;
rdi: virtual instruction pointer (points at the next instruction);
rax,rbx,rcx,rdx: scratch registers;
rsp: (virtual) return stack pointer .
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
(import '(sb-assem:inst sb-vm::make-ea)) ; we'll use these two a lot
;; The backing store for our stack
(defvar *stack* (make-array 8 :initial-contents (list sb-vm::r8d-tn
                                                      sb-vm::r9d-tn
                                                      sb-vm::r10d-tn
                                                      sb-vm::r11d-tn
                                                      sb-vm::r12d-tn
                                                      sb-vm::r13d-tn
                                                      sb-vm::r14d-tn
                                                      sb-vm::r15d-tn)))
;; The _primop-generation-time_ stack pointer
(defvar *stack-pointer*)
;; (@ 0) returns the (current) register for TOS, (@ 1) returns
;; the one just below, etc.
(defun @ (i)
  (aref *stack* (mod (+ i *stack-pointer*) (length *stack*))))
(defvar *code-base* sb-vm::rsi-tn)
(defvar *virtual-ip* sb-vm::rdi-tn)
(defvar *rax* sb-vm::rax-tn)
(defvar *rbx* sb-vm::rax-tn)
(defvar *rcx* sb-vm::rax-tn)
(defvar *rdx* sb-vm::rax-tn)
;; Variants are *primitive-code-offset* bytes apart
(defvar *primitive-code-offset* (* 64 67))
;; Each *stack-pointer* value gets its own code page
(defstruct code-page
  (alloc 0) ; index of the next free byte.
  (code (make-array *primitive-code-offset* :element-type '(unsigned-byte 8))))
The idea is that we&#8217;ll define functions to emit assembly code for each
primitive; these functions will be implicitly parameterised on
*stack-pointer* thanks to @.  We can then call them as many times
as needed to cover all values of *stack-pointer*.  The only
complication is that code sequences will differ in length, so we must
insert padding to keep everything in sync.  That&#8217;s what emit-code
does:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
(defun emit-code (pages emitter)
  ;; there must be as many code pages as there are stack slots
  (assert (= (length *stack*) (length pages)))
  ;; find the rightmost starting point, and align to 16 bytes
  (let* ((alloc (logandc2 (+ 15 (reduce #'max pages :key #'code-page-alloc))
                          15))
         (bytes (loop for i below (length pages)
                      for page = (elt pages i)
                      collect (let ((segment (sb-assem:make-segment))
                                    (*stack-pointer* i))
                                ;; assemble the variant for this value
                                ;; of *stack-pointer* in a fresh code
                                ;; segment
                                (sb-assem:assemble (segment)
                                  ;; but first, insert padding
                                  (sb-vm::emit-long-nop segment (- alloc (code-page-alloc page)))
                                  (funcall emitter))
                                ;; tidy up any backreference
                                (sb-assem:finalize-segment segment)
                                ;; then get the (position-independent) machine
                                ;; code as a vector of bytes
                                (sb-assem:segment-contents-as-vector segment)))))
    ;; finally, copy each machine code sequence to the right code page
    (map nil (lambda (page bytes)
               (let ((alloc (code-page-alloc page)))
                 (replace (code-page-code page) bytes :start1 alloc)
                 (assert (&lt;= (+ alloc (length bytes)) (length (code-page-code page))))
                 (setf (code-page-alloc page) (+ alloc (length bytes)))))
         pages bytes)
    ;; and return the offset for that code sequence
    alloc))
This function is used by emit-all-code to emit the machine code for
a bunch of primitives, while tracking the start offset for each
primitive.
1
2
3
4
5
6
7
8
9
10
(defun emit-all-code (&rest emitters)
  (let ((pages (loop repeat (length *stack*)
                     for page = (make-code-page)
                     ;; prefill everything with one-byte NOPs
                     do (fill (code-page-code page) #x90)
                     collect page)))
    (values (mapcar (lambda (emitter)
                      (emit-code pages emitter))
                    emitters)
            pages)))
Now, the pièce de résistance:
1
2
3
4
5
6
7
8
9
10
11
12
13
(defun next (&optional offset)
  (setf offset (or offset 0)) ; accommodate primops that frob IP
  (let ((rotation (mod *stack-pointer* (length *stack*))))
    (inst movzx *rax* (make-ea :dword :index *virtual-ip*
                                      :disp offset))
    (unless (= -4 offset)
      (inst add *virtual-ip* (+ 4 offset)))
    (if (zerop rotation)
        (inst add *rax* *code-base*)
        (inst lea *rax* (make-ea :qword :base *code-base*
                                        :index *rax*
                                        :disp (* rotation *primitive-code-offset*))))
    (inst jmp *rax*)))
First steps
Let&#8217;s add a few simple primitives.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
(defun swap ()
  (inst xchg (@ 0) (@ 1)) ; exchange top of stack and stack[1]
  (next))
(defun dup ()
  (decf *stack-pointer*) ; grow stack (which grows down)
  (inst mov (@ 0) (@ 1)) ; and overwrite TOS
  (next))
(defun drop (&optional offset)
  (incf *stack-pointer*) ; just shrink the stack
  (next offset))
(defun add ()
  (inst add (@ 1) (@ 0)) ; second element becomes TOS
  (drop))
(defun sub ()
  (inst sub (@ 1) (@ 0))
  (drop))
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
CL-USER> (setf *print-length* 100)
100
CL-USER> (emit-all-code 'swap 'dup 'drop 'add 'sub)
(0 32 64 96 128)
(#S(CODE-PAGE
    :ALLOC 152
    :CODE #(69 135 193 139 4 61 0 0 0 0 72 131 199 4 72 1 240 255 224 102 15 31
            132 0 0 0 0 0 15 31 64 0 69 139 248 139 4 61 0 0 0 0 72 131 199 4
            72 141 132 6 64 117 0 0 255 224 15 31 132 0 0 0 0 0 139 4 61 0 0 0
            0 72 131 199 4 72 141 132 6 192 16 0 0 255 224 102 15 31 132 0 0 0
            0 0 102 144 69 1 193 139 ...))
 ...)
CL-USER> (defparameter *code0* (code-page-code (first (second /))))
*CODE*
CL-USER> (defparameter *code1* (code-page-code (second (second //))))
*CODE*
The code for swap lives between bytes 0 and 32.  Let&#8217;s take a look
at the version for *stack-pointer* = 0 and *stack-pointer* = 1.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
CL-USER> (sb-sys:with-pinned-objects (*code0*)
           (sb-disassem:disassemble-memory (sb-sys:vector-sap *code0*)
                                           32))
; Size: 32 bytes
; 0669C700:       4587C1           XCHG R8D, R9D
;       03:       8B043D00000000   MOV EAX, [RDI]
;       0A:       4883C704         ADD RDI, 4
;       0E:       4801F0           ADD RAX, RSI
;       11:       FFE0             JMP RAX
;       13:       660F1F840000000000 NOP  ; padding NOPs
;       1C:       0F1F4000         NOP
NIL
CL-USER> (sb-sys:with-pinned-objects (*code1*)
           (sb-disassem:disassemble-memory (sb-sys:vector-sap *code1*)
                                           32))
; Size: 32 bytes
; 0669D810:       4587CA           XCHG R9D, R10D
;       13:       8B043D00000000   MOV EAX, [RDI]
;       1A:       4883C704         ADD RDI, 4
;       1E:       488D8406C0100000 LEA RAX, [RSI+RAX+4288]
;       26:       FFE0             JMP RAX
;       28:       0F1F840000000000 NOP
NIL
dup is at 32-64, and sub at 128-152:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
CL-USER> (sb-sys:with-pinned-objects (*code0*)
           (sb-disassem:disassemble-memory (sb-sys:sap+ (sb-sys:vector-sap *code0*) 32)
                                           32))
; Size: 32 bytes
; 0669C720:       458BF8           MOV R15D, R8D
;       23:       8B043D00000000   MOV EAX, [RDI]
;       2A:       4883C704         ADD RDI, 4
;       2E:       488D840640750000 LEA RAX, [RSI+RAX+30016]
;       36:       FFE0             JMP RAX
;       38:       0F1F840000000000 NOP
NIL
CL-USER> (sb-sys:with-pinned-objects (*code0*)
           (sb-disassem:disassemble-memory (sb-sys:sap+ (sb-sys:vector-sap *code0*) 128)
                                           24))
; Size: 24 bytes
; 0669C780:       4529C1           SUB R9D, R8D
;       83:       8B043D00000000   MOV EAX, [RDI]
;       8A:       4883C704         ADD RDI, 4
;       8E:       488D8406C0100000 LEA RAX, [RSI+RAX+4288]
;       96:       FFE0             JMP RAX
NIL
These are relatively tight.  I certainly like how little data
shuffling there is; the NEXT sequence is a bit hairy, but the
indirect branch is likely its weakest (and least avoidable) point.
Control flow primops
A VM without control flow isn&#8217;t even a toy.  First, unconditional
relative jumps.  These can be encoded as [jmp] [offset], with the 32
bit offset relative to the end of offset.  We just overwrite
*virtual-ip* with the new address.
1
2
3
4
5
(defun jmp ()
  (inst movsx *rax* (make-ea :dword :base *virtual-ip*))
  (inst lea *virtual-ip* (make-ea :dword :base *virtual-ip* :index *rax*
                                         :disp 4))
  (next))
Call and return are at the heart of Forth-like engines.  ret is
easy: just pop from the control stack into *virtual-ip*.
1
2
3
(defun ret ()
  (inst pop *virtual-ip*)
  (next))
Call is a bit more complicated. It&#8217;s like jmp, but pushes the
address of the next instruction to the control stack:
1
2
3
4
5
6
(defun call ()
  (inst movsx *rax* (make-ea :dword :base *virtual-ip*))
  (inst add *virtual-ip* 4)
  (inst push *virtual-ip*)
  (inst add *virtual-ip* *rax*)
  (next))
Let&#8217;s look at the resulting machine code.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
CL-USER> (emit-all-code 'jmp 'ret 'call)
(0 32 64)
(#S(CODE-PAGE
    :ALLOC 91
    :CODE #(72 99 7 72 141 124 7 4 139 4 61 0 0 0 0 72 131 199 4 72 1 240 255
            224 15 31 132 0 0 0 0 0 95 139 4 61 0 0 0 0 72 131 199 4 72 1 240
            255 224 102 15 31 132 0 0 0 0 0 102 15 31 68 0 0 72 99 7 72 131 199
            4 87 72 1 199 139 4 61 0 0 0 0 72 131 199 4 72 1 240 255 224 144
            144 144 144 144 144 144 144 144 ...))
 ...)
CL-USER> (let ((code (code-page-code (first (second /)))))
           (sb-sys:with-pinned-objects (code)
             (sb-disassem:disassemble-memory (sb-sys:vector-sap code) 91)))
; Size: 91 bytes
; 08395200:       486307           MOVSXD RAX, DWORD PTR [RDI] ; jmp
;       03:       488D7C0704       LEA RDI, [RDI+RAX+4]
;       08:       8B043D00000000   MOV EAX, [RDI]
;       0F:       4883C704         ADD RDI, 4
;       13:       4801F0           ADD RAX, RSI
;       16:       FFE0             JMP RAX
;       18:       0F1F840000000000 NOP
;       20:       5F               POP RDI                     ; ret
;       21:       8B043D00000000   MOV EAX, [RDI]
;       28:       4883C704         ADD RDI, 4
;       2C:       4801F0           ADD RAX, RSI
;       2F:       FFE0             JMP RAX
;       31:       660F1F840000000000 NOP
;       3A:       660F1F440000     NOP
;       40:       486307           MOVSXD RAX, DWORD PTR [RDI] ; call
;       43:       4883C704         ADD RDI, 4
;       47:       57               PUSH RDI
;       48:       4801C7           ADD RDI, RAX
;       4B:       8B043D00000000   MOV EAX, [RDI]
;       52:       4883C704         ADD RDI, 4
;       56:       4801F0           ADD RAX, RSI
;       59:       FFE0             JMP RAX
FFI from SBCL
We finally almost have enough for interesting demos.  The only
important thing that&#8217;s still missing is calls from CL into the VM.
I&#8217;ll assume that the caller takes care of saving any important
register, and that the primop (rsi) and virtual IP (rdi) registers
are setup correctly.  The stack will be filled on entry, by copying
values from the buffer rax points to, and written back on exit.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
(defun enter ()
  (inst push sb-vm::rbp-tn)
  (inst mov sb-vm::rbp-tn sb-vm::rsp-tn) ; setup a normal frame
  (inst push *rax*) ; stash rax
  (dotimes (i 8)    ; copy the stack in
    (inst mov (@ i) (make-ea :dword :base *rax* :disp (* 4 i))))
  (next))
(defun leave ()
  ;; restore RAX
  (inst mov *rax* (make-ea :qword :base sb-vm::rbp-tn :disp -8))
  ;; overwrite the output stack
  (dotimes (i 8)
    (inst mov (make-ea :dword :base *rax* :disp (* 4 i))
                   (@ i)))
  ;; and unwind the frame
  (inst mov sb-vm::rsp-tn sb-vm::rbp-tn)
  (inst pop sb-vm::rbp-tn)
  (inst ret))
The CL-side interlocutor of enter follows, as a VOP:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
(sb-c:defknown %enter-vm (system-area-pointer system-area-pointer system-area-pointer) (values)
    (sb-c:any) :overwrite-fndb-silently t)
(in-package "SB-VM")
(sb-vm::define-vop (cl-user::%enter-vm)
  (:translate cl-user::%enter-vm)
  (:policy :fast-safe)
  (:args (stack :scs (sap-reg) :target rax)
         (code :scs (sap-reg) :target rdi)
         (primitives :scs (sap-reg) :target rsi))
  (:arg-types system-area-pointer system-area-pointer system-area-pointer)
  (:results)
  (:temporary (:sc sap-reg :offset rax-offset :from (:argument 0)) rax)
  (:temporary (:sc sap-reg :offset rbx-offset :from :eval) rbx)
  (:temporary (:sc sap-reg :offset rcx-offset :from :eval) rcx)
  (:temporary (:sc sap-reg :offset rdx-offset :from :eval) rdx)
  (:temporary (:sc sap-reg :offset rdi-offset :from (:argument 1)) rdi)
  (:temporary (:sc sap-reg :offset rsi-offset :from (:argument 2)) rsi)
  (:ignore rbx rcx rdx)
  (:generator 0
    (inst push r8-tn)  ;; the stack was just too painful to declare
    (inst push r9-tn)  ;; as temporary... and it overwrites the
    (inst push r10-tn) ;; thread-base TN, which regalloc disregards.
    (inst push r11-tn)
    (inst push r12-tn)
    (inst push r13-tn)
    (inst push r14-tn)
    (inst push r15-tn)
    (move rax stack)
    (move rdi code)
    (move rsi primitives)
    (inst call rsi)   ;; assume the code page starts with ENTER
    (inst pop r15-tn)
    (inst pop r14-tn)
    (inst pop r13-tn)
    (inst pop r12-tn)
    (inst pop r11-tn)
    (inst pop r10-tn)
    (inst pop r9-tn)
    (inst pop r8-tn)))
(in-package "CL-USER")
(defun %enter-vm (stack-sap bytecode-sap primitives-sap)
  (declare (type system-area-pointer stack-sap bytecode-sap primitives-sap))
  (%enter-vm stack-sap bytecode-sap primitives-sap))
(defun vm (stack-designator bytecode primitives)
  (declare (type (simple-array (unsigned-byte 32) 1) bytecode)
           (type system-area-pointer primitives))
  ;; initialise the stack with the designator.
  (let ((stack (make-array 8 :element-type '(unsigned-byte 32)
                             :initial-element 0)))
    (if (typep stack-designator 'sequence)
        (map-into stack (lambda (x)
                          (ldb (byte 32 0) x))
                  stack-designator)
        (fill stack (ldb (byte 32 0) stack-designator)))
    (sb-sys:with-pinned-objects (stack bytecode)
      (time (%enter-vm (sb-sys:vector-sap stack) (sb-sys:vector-sap bytecode)
                       primitives)))
    stack))
The only thing missing is to store the machine code for our primop in
a range of memory that&#8217;s executable.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
;; first, get an executable range of memory
(defvar *code-page* (sb-posix:mmap nil (* (length *stack*) *primitive-code-offset*)
                                   (logior sb-posix:prot-read sb-posix:prot-write sb-posix:prot-exec)
                                   (logior sb-posix:map-anon sb-posix:map-private)
                                   -1 0))
;; our list of primop names
(defvar *primops* '(enter leave
                    swap dup drop
                    add sub
                    jmp
                    call ret))
(defun assemble-primops ()
  (multiple-value-bind (offsets pages)
      (apply 'emit-all-code *primops*)
    (loop for page in pages
          for offset upfrom 0 by *primitive-code-offset*
          do (sb-kernel:copy-ub8-to-system-area
              (code-page-code page) 0
              *code-page* offset
              *primitive-code-offset*))
    (mapcar 'cons *primops* offsets)))
;; this alist maps primop names to offsets
(defparameter *primops-offsets* (assemble-primops))
1
2
3
CL-USER> *primops-offsets*
((ENTER . 0) (LEAVE . 64) (SWAP . 112) (DUP . 144) (DROP . 176) (ADD . 208)
 (SUB . 240) (JMP . 272) (CALL . 304) (RET . 336))
Let&#8217;s execute add sub (and finish with leave).
1
2
3
4
5
6
7
8
9
CL-USER> (vm '(3 2 10) (coerce '(208 240 64) '(simple-array (unsigned-byte 32) 1)) *code-page*)
Evaluation took:
  0.000 seconds of real time
  0.000003 seconds of total run time (0.000002 user, 0.000001 system)
  100.00% CPU
  2,288 processor cycles
  0 bytes consed
#(5 0 0 0 0 0 3 5)
And, indeed, 10 - (3 + 2) = 5.
We should also test function calls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
CL-USER> (vm '(3 2 10) (coerce '(304 8 ; call F
                                 240
                                 64
                                 ;; F:
                                 208
                                 336)
                               '(simple-array (unsigned-byte 32) 1))
             *code-page*)
Evaluation took:
  0.000 seconds of real time
  0.000005 seconds of total run time (0.000003 user, 0.000002 system)
  100.00% CPU
  2,640 processor cycles
  0 bytes consed
#(5 0 0 0 0 0 3 5)
Instead of executing add directly, this bytecode sequence calls to
whatever is 8 bytes (2 dwords) after the call instruction; in our
case, add ret.
Writing bytecode by hand is annoying.  This tiny functions takes care
of the stupid stuff.
1
2
3
4
5
6
7
(defun assemble (opcodes)
  (map '(simple-array (unsigned-byte 32) 1)
       (lambda (opcode)
         (if (integerp opcode)
             (ldb (byte 32 0) opcode)
             (cdr (assoc opcode *primops-offsets*))))
       opcodes))
We can now write
1
2
3
4
5
6
7
CL-USER> (vm '(3 2 10) (assemble '(call 8
                                   sub
                                   leave
                                   add
                                   ret))
             *code-page*)
Conditionals
We can now either write (basically) straightline code or infinite
loops.  We need conditionals.  Their implementation is much like
jmp, with a tiny twist.  Let&#8217;s start with jump if (top of stack is)
non-zero and jump if zero.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
(defun jcc (cc)
  ;; next word is the offset if the condition is met, otherwise,
  ;; fall through.
  (inst movsx *rax* (make-ea :dword :base *virtual-ip*))
  (inst lea *rax* (make-ea :dword :base *virtual-ip* :index *rax*
                                  :disp 4))
  (inst add *virtual-ip* 4)
  (inst test (@ 0) (@ 0))
  ;; update *virtual-ip* only if zero/non-zero
  (inst cmov cc *virtual-ip* *rax*)
  (next))
(defun jnz ()
  (jcc :nz))
(defun jz ()
  (jcc :z))
Immediates
It&#8217;s hard to write programs without immediate values.  Earlier control
flow primitives already encode immediate data in the virtual
instruction stream.  We&#8217;ll do the same for lit, inc, and dec:
1
2
3
4
5
6
7
8
9
10
11
12
(defun lit ()
  (decf *stack-pointer*) ; grow the stack
  (inst mov (@ 0) (make-ea :dword :base *virtual-ip*)) ; load the next word
  (next 4)) ; and skip to the next instruction
(defun inc ()
  (inst add (@ 0) (make-ea :dword :base *virtual-ip*))
  (next 4))
(defun dec ()
  (inst sub (@ 0) (make-ea :dword :base *virtual-ip*))
  (next 4))
My first loop
Finally, we have enough for a decent-looking (if useless) loop.  First,
update the primop code page:
1
2
3
4
5
6
7
8
;; C-M-x to force re-evaluation, or defparameter
(defvar *primops* '(enter leave lit
                    swap dup drop
                    add sub inc dec
                    jmp jnz jz
                    call ret))
(defvar *primops-offsets* (assemble-primops))
1
2
3
4
5
6
7
8
9
10
CL-USER> (vm '(1000000) (assemble '(lit 1 sub jnz -20 leave))
             *code-page*)
Evaluation took:
  0.009 seconds of real time
  0.009464 seconds of total run time (0.009384 user, 0.000080 system)
  100.00% CPU
  14,944,792 processor cycles
  0 bytes consed
#(0 0 0 0 0 0 0 1)
One million iterations of this stupid loop that only decrements a
counter took 15M cycles. 15 cycles/iteration really isn&#8217;t that
bad… especially considering that it executes an indirect jump after
loading 1, after subtracting, and after comparing with 0.
We can do better by fusing lit sub into dec:
1
2
3
4
5
6
7
8
9
10
CL-USER> (vm '(1000000) (assemble '(dec 1 jnz -16 leave))
             *code-page*)
Evaluation took:
  0.007 seconds of real time
  0.006905 seconds of total run time (0.006848 user, 0.000057 system)
  100.00% CPU
  11,111,128 processor cycles
  0 bytes consed
#(0 0 0 0 0 0 0 0)
Fuse all the things!
Decrementing a counter and jumping if non zero is a common operation
(old x86 even implemented that in hardware, with loop).  Let&#8217;s add
decrement and jump if non-zero (djn) to the VM:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
(defun djn ()
  (inst movsx *rax* (make-ea :dword :base *virtual-ip*))
  (inst lea *rax* (make-ea :dword :base *virtual-ip* :index *rax*
                                  :disp 4))
  (inst add *virtual-ip* 4)
  (inst sub (@ 0) 1)
  (inst cmov :nz *virtual-ip* *rax*)
  (next))
(defvar *primops* '(enter leave lit
                    swap dup drop
                    add sub inc dec
                    jmp jnz jz djn
                    call ret))
(defvar *primops-offsets* (assemble-primops))
1
2
3
4
5
6
7
8
9
10
CL-USER> (vm '(1000000) (assemble '(djn -8 leave))
             *code-page*)
Evaluation took:
  0.005 seconds of real time
  0.005575 seconds of total run time (0.005542 user, 0.000033 system)
  120.00% CPU
  8,823,896 processor cycles
  0 bytes consed
#(0 0 0 0 0 0 0 0)
That&#8217;s better… But I&#8217;m really not convinced by the conditional move.
The branch will usually be predictable, so it makes sense to expose
that to the hardware and duplicate the NEXT sequence.
1
2
3
4
5
6
7
8
9
10
(defun djn2 ()
  (sb-assem:assemble ()
    (inst sub (@ 0) 1)
    (inst jmp :z fallthrough)
    (inst movsx *rax* (make-ea :dword :base *virtual-ip*))
    (inst lea *virtual-ip* (make-ea :dword :base *virtual-ip* :index *rax*
                                           :disp 8))
    (next -4) ; might as well pre-increment *virtual-ip*
    fallthrough ; ASSEMBLE parses for labels, like TAGBODY
    (next 4)))
The resulting code isn&#8217;t too large, and the two indirect jumps are 16
bytes apart.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
; Size: 64 bytes
; 00510220:       4183E801         SUB R8D, 1
;       24:       7414             JEQ L0
;       26:       486307           MOVSXD RAX, DWORD PTR [RDI]
;       29:       488D7C0708       LEA RDI, [RDI+RAX+8]
;       2E:       8B043DFCFFFFFF   MOV EAX, [RDI-4]
;       35:       4801F0           ADD RAX, RSI
;       38:       FFE0             JMP RAX
;       3A: L0:   8B043D04000000   MOV EAX, [RDI+4]
;       41:       4883C708         ADD RDI, 8
;       45:       4801F0           ADD RAX, RSI
;       48:       FFE0             JMP RAX
;       4A:       660F1F840000000000 NOP
;       53:       660F1F840000000000 NOP
;       5C:       0F1F4000         NOP
This alternative implementation does work better on our stupid loop.
1
2
3
4
5
6
7
8
9
10
CL-USER> (vm '(1000000) (assemble '(djn2 -8 leave))
             *code-page*)
Evaluation took:
  0.004 seconds of real time
  0.004034 seconds of total run time (0.003913 user, 0.000121 system)
  100.00% CPU
  6,183,488 processor cycles
  0 bytes consed
#(0 0 0 0 0 0 0 0)
Let&#8217;s see how that compares to straight assembly code.
1
2
3
4
5
6
(defun ubench ()
  (sb-assem:assemble ()
    head
    (inst sub (@ 0) 1)
    (inst jmp :nz head)
    (next)))
1
2
3
4
5
6
7
8
9
10
CL-USER> (vm '(1000000) (assemble '(ubench leave))
             *code-page*)
Evaluation took:
  0.000 seconds of real time
  0.000629 seconds of total run time (0.000628 user, 0.000001 system)
  100.00% CPU
  1,001,904 processor cycles
  0 bytes consed
#(0 0 0 0 0 0 0 0)
My slow macbook air gets 1 iteration/cycle on a loop that&#8217;s 100%
control overhead. With djn2, a good implementation of a reasonable
specialised operator, the loop is about 6x as slow as native code.  A
worse implementation of djn is still only 8x as slow as pure native
code, and horribly unspecialised bytecode is 11-15x as slow as native
code.
Verdict
Specialising primops to a virtual stack pointer is feasible in
practice, when the stack is restricted to a small size.  It also seems
to have a reasonable runtime overhead for threaded interpreters.  I&#8217;m
not actually interested in straight stack languages; however, I
believe that a fixed stack VM makes a nice runtime IR makes a nice
runtime IR, when coupled with a mechanism for local variables.  We&#8217;ll
see if I find time to translate a high level language into
superoperators for such a VM.  Fused operators would reduce the
importance of NEXT; in constrast, simpler function calls (because
there&#8217;s less shuffling of items to stack them up in the right
position) would remain as useful.
SBCL has definitely proven itself to be a good companion to explore
the generation of domain-specific machine code. I don&#8217;t know of any
other language implementation with that kind of support for
interactive programming and machine code generation (and inspection).
FWIW, I believe LuaJIT + dynasm will soon be comparable.
Steel Bank Common Lisp: because sometimes C abstracts away too much ;)
Posted by Paul Khuong
Mar 15th, 2014
  Tweet
        &laquo; Reference books I'm bringing across the border
    Comments
    Please enable JavaScript to view the comments powered by Disqus.
  Recent Posts
        SBCL: the ultimate assembly code breadboard
        Reference books I'm bringing across the border
        How bad can 1GB pages be?
        A whirlwind introduction to decomposition methods in discrete optimisation
        So you want to write an LP solver (a.k.a. My Little LP: Cholesky Is Magic)
        The other Robin Hood hashing
        The weaknesses of SBCL's type propagation
        All you need is call/cc
        Bitsets match regular expressions, compactly
        Fresh in SBCL 1.1.8: SSE intrinsics!
  Copyright &copy; 2014 -
    Paul Khuong -
  Powered by Octopress
      var disqus_shortname = 'pvk';
        // var disqus_developer = 1;
        var disqus_identifier = 'http://www.pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/';
        var disqus_url = 'http://www.pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/';
        var disqus_script = 'embed.js';
    (function () {
      var dsq = document.createElement('script'); dsq.type = 'text/javascript'; dsq.async = true;
      dsq.src = 'http://' + disqus_shortname + '.disqus.com/' + disqus_script;
      (document.getElementsByTagName('head')[0] || document.getElementsByTagName('body')[0]).appendChild(dsq);
    }());
    (function(){
      var twitterWidgets = document.createElement('script');
      twitterWidgets.type = 'text/javascript';
      twitterWidgets.async = true;
      twitterWidgets.src = 'http://platform.twitter.com/widgets.js';
      document.getElementsByTagName('head')[0].appendChild(twitterWidgets);
    })();
  (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
  (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
  m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
  })(window,document,'script','//www.google-analytics.com/analytics.js','ga');
  ga('create', 'UA-20468541-1', 'pvk.ca');
  ga('send', 'pageview');