Basic block compiler for a simple virtual machine

compiler.lisp

;; Instructions

;; SET A B    (set mem[a] to immediate value B)
;; XOR A B    (set mem[a] to mem[b] XOR mem[b])
;; AND A B    (set mem[a] to (and mem[a] mem[b]))
;; OR  A B    (set mem[a] to (or mem[a] mem[b]))
;; RANDOM A   (set mem[a] to 0 or 1)
;; JMP A      (jump to instruction A)
;; JZ A B     (jump to instruction A if memory slot B is zero)
;; HALT       (halt program)

(defun read-program (&optional (stream *standard-input*))
  (loop for pc below (parse-integer (read-line stream)) collect
       (read-from-string (concatenate 'string "(" (read-line stream) ")"))))



(defun comp (program)
  (let ((jump-targets (make-hash-table :test 'eq)))
    (loop for instruction in program
       for pc from 0 do
         (destructuring-bind (opcode &rest operands) instruction
           (case opcode
             (jz  (setf (gethash (car operands) jump-targets) (gensym))
                  (setf (gethash (1+ pc) jump-targets) (gensym)))
             (jmp (setf (gethash (car operands) jump-targets) (gensym))
                  (setf (gethash (1+ pc) jump-targets) (gensym))))))
    (setf (gethash 0 jump-targets) (gensym))

    (let ((current-block '())
          (blocks '()))
      (loop for instruction in program
         for pc from 0
         for start-pc from 0 do

           (when (null current-block)
             (setf start-pc pc))
           
           (push instruction current-block)
           
           (when (gethash (1+ pc) jump-targets)
             (push (list :name (gethash (- pc (1- (length current-block))) jump-targets)
                         :next-name (gethash (1+ pc) jump-targets)
                         :code (reverse current-block)) blocks)
             (setf current-block nil)))
      
      (when current-block
        (push (list :name (gethash (- (length program)
                                      (length current-block)) jump-targets)
                    :code (reverse current-block)) blocks))


       (let ((blocks (reverse blocks))
             (prog-name (gensym)))
         (labels ((compile-instruction (instruction &optional end-target)
                    (destructuring-bind (opcode &optional op-a op-b) instruction
                      (ecase opcode
                        (jz `(if (zerop (the bit (aref mem ,op-b)))
                                 (,(gethash op-a jump-targets) mem)
                                 (,end-target mem)))
                        (jmp `(,(gethash op-a jump-targets) mem))
                        (set `(setf (aref mem ,op-a) (the bit ,op-b)))
                        (random `(setf (aref mem ,op-a) (the bit (random 2))))
                        (halt `(return-from ,prog-name (values :halted count)))
                        (xor `(setf (aref mem ,op-a)
                                    (the bit (logxor (the bit (aref mem ,op-a))
                                                     (the bit (aref mem ,op-b))))))))))
        
        
           
           (compile nil
                    `(lambda ()
                       (declare (optimize (speed 3) (safety 0) (debug 0)))
                       (block ,prog-name
                         (let ((count 0))
                           (declare (type fixnum count))
                           (labels
                               (,@(mapcar
                                   (lambda (block)
                                     (destructuring-bind (&key name next-name
                                                               code) block
                                       
                                       (let* ((last-opcode (caar (last (getf block :code))))
                                              (jump-p (or (eq 'jz last-opcode)
                                                          (eq 'jmp last-opcode))))
                                         ;; create local function declaration
                                         `(,name
                                           (mem)
                                           (declare (ignorable mem)
                                                    (type (simple-array fixnum (32)) mem))
                                           (incf count ,(length code))
                                           ;; compile instructions
                                           ,@(mapcar (lambda (code) (compile-instruction code (when jump-p next-name))) code)
                                           
                                           ;; call next block unless we end with a jump,
                                           ;; in which case either drop the call,
                                           ;; (unconditional jump)
                                           ;; or merge it into a conditional
                                           ;; (if zero (call A) (call b))
                                           ,@(unless jump-p
                                                     `((,next-name mem)))))))
                                   (butlast blocks))
                                
                                ,(destructuring-bind
                                  (&key name code) (car (last blocks))
                                  `(,name (mem)
                                          (declare (ignorable mem))
                                          ,@(mapcar #'compile-instruction code))))
                             
                             (,(gethash 0 jump-targets) (make-array 32 :element-type 'fixnum :initial-element 0))))))))))))


;; usage
(comp (read-program))
5           ;; 5 instructions (this isn't really needed, but it was in the spec)
SET 0 1     ;; 0 - set memory slot 0 to 1
JZ 4 0      ;; 1 - if memory slot 0 is 0, jump to instruction 4 
RANDOM 0    ;; 2 - set memory slot 0 to 0 or 1, equal probability
JMP 1       ;; 3 - jump to instruction 1
HALT        ;; 4 - halt program

=> <lambda ... >   ;; compiled function

(time (funcall *))

Evaluation took:
  0.000 seconds of real time
  0.000002 seconds of total run time (0.000002 user, 0.000000 system)
  100.00% CPU
  2,897 processor cycles
  0 bytes consed
  
:HALTED
5         ;; returns number of instructions






;; the compiled code for the sample program looks like this 
(LAMBDA ()
 ;; wrap in a block to return from by name
 (BLOCK #:G4357
    (LET ((COUNT 0))
      (DECLARE (TYPE FIXNUM COUNT))
      ;; declare some local functions
      (LABELS ((#:G4356 (MEM)
                 (DECLARE (IGNORABLE MEM)
                          (TYPE (SIMPLE-ARRAY FIXNUM (32)) MEM))
                 (INCF COUNT 1)
                 (SETF (AREF MEM 0) (THE BIT 1))
                 (#:G4354 MEM))
               (#:G4354 (MEM)
                 (DECLARE (IGNORABLE MEM)
                          (TYPE (SIMPLE-ARRAY FIXNUM (32)) MEM))
                 (INCF COUNT 1)
                 (IF (ZEROP (THE BIT (AREF MEM 0)))
                     (#:G4355 MEM)
                     (#:G4353 MEM)))
               (#:G4353 (MEM)
                 (DECLARE (IGNORABLE MEM)
                          (TYPE (SIMPLE-ARRAY FIXNUM (32)) MEM))
                 (INCF COUNT 2)
                 (SETF (AREF MEM 0) (THE BIT (RANDOM 2)))
                 (#:G4354 MEM))
               (#:G4355 (MEM)
                 (DECLARE (IGNORABLE MEM))
                ;; halt program, return number of executed instructions
                 (RETURN-FROM #:G4357 (VALUES :HALTED COUNT))))

        ;; call the function corresponding to the first basic block
        (#:G4356 (MAKE-ARRAY 32 :ELEMENT-TYPE 'FIXNUM :INITIAL-ELEMENT 0)))))))