implemented npc.lisp

Pascal J. Bourguignon [2013-12-26 21:32]
implemented npc.lisp
Filename
npc.lisp
npvm.lisp
diff --git a/npc.lisp b/npc.lisp
new file mode 100644
index 0000000..c5c5581
--- /dev/null
+++ b/npc.lisp
@@ -0,0 +1,244 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               npc.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Implemented a simple npc compiler  targetting the npvm.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-12-26 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-COMPILER"
+  (:use "COMMON-LISP"
+         "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM")
+  (:export
+   "NP-COMPILE"
+   "PROGN" "<-" "PRINT" "DUMP" "NEG" "+" "*" "-" "/"))
+
+(in-package "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NP-COMPILER")
+
+#-(and)
+'(progn
+  (<- var expr)
+
+  (* expr1 expr2)
+  (+ expr1 expr2)
+  (/ expr1 expr2)
+  (- expr1 expr2)
+
+  (print expr)
+  (neg expr)
+
+  (dump))
+
+(defun generate (program code &rest codes)
+  (assert (every (function numberp) (cons code codes)))
+  (dolist (code (cons code codes))
+    (vector-push-extend code program (length program))))
+
+(defun check-arity (n expr)
+  (unless (= n (length (rest expr)))
+    (error "~S is an operator that takes ~D argument~:*~P; ~S is invalid."
+           (first expr) n expr)))
+
+
+(defun np-generate (expr variables program)
+  (cond
+    ((numberp expr) (generate program +pushi+ expr))
+    ((symbolp expr) (generate program +pushn+ (variable-index variables expr)))
+    ((atom expr) (error "Unexpected atom ~S" expr))
+    (t (case (first expr)
+
+         ((progn)
+          (loop
+            :for expr :in (rest expr)
+            :do (np-generate expr variables program)))
+
+         ((+ * - /)
+          (check-arity 2 expr)
+          (np-generate (second expr) variables program)
+          (np-generate (third  expr) variables program)
+          (generate program (case (first expr)
+                              ((+) +add+)
+                              ((*) +mul+)
+                              ((-) +sub+)
+                              ((/) +div+))))
+
+         ((<-)
+          (check-arity 2 expr)
+          (unless (symbolp (second expr))
+            (error "<- takes a variable as target, not ~S" (second expr)))
+          (np-generate (third  expr) variables program)
+          (np-generate (second expr) variables program)
+          (generate program +store+))
+
+         ((print)
+          (check-arity 1  expr)
+          (np-generate (second expr) variables program)
+          (generate program +print+))
+
+         ((neg)
+          (check-arity 1  expr)
+          (np-generate (second expr) variables program)
+          (generate program +neg+))
+
+         ((dump)
+          (check-arity 0 expr)
+          (generate program +dump+))
+
+         (otherwise
+          (error "Invalid operator in ~S" expr))))))
+
+
+(defun collect-variables (expr)
+  (let ((variables '()))
+    (labels ((collect (expr)
+               (cond
+                 ((symbolp expr) (push expr variables))
+                 ((atom expr))
+                 (t (dolist (subexpr (rest expr))
+                      (collect subexpr))))))
+      (collect expr)
+      (remove-duplicates variables))))
+
+(defun variable-index (variables var)
+  (position var variables))
+
+
+(defun set-equal (a b) (and (subsetp a b) (subsetp b a)))
+(defun test/collect-variables ()
+  (assert (set-equal (collect-variables '(progn
+                                          (<- var (neg expr))
+                                          (* (+ 33 expr2) (/ 42 expr2))
+                                          (print (- expr1 expr2))
+                                          (dump)))
+                     '(expr1 expr2 expr var)))
+  :success)
+(test/collect-variables)
+
+(defun np-compile (expr)
+  (let ((variables (collect-variables expr))
+        (program (make-array 100 :adjustable t :fill-pointer 0)))
+    (when (< +max-variables+ (length variables))
+      (error "~D is too many variables, memory has only ~D slots."
+             (length variables) +max-variables+))
+    (np-generate expr variables program)
+    (generate program +stop+)
+    (values program variables)))
+
+(defun np-disassemble (pgm)
+  (let ((vm (make-vm :program pgm)))
+    (loop
+      :for pc := (vm-disassemble vm 0) :then (vm-disassemble vm pc)
+      :while (< pc (length pgm)))))
+
+(np-disassemble (np-compile
+                 ;; 5 5 + d !
+                 ;; d d * c !
+                 ;; d c * m !
+                 ;; d =
+                 ;; c =
+                 ;; m =
+                 ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+                 '(progn
+                   (<- d (+ 5 5))
+                   (<- c (* d d))
+                   (<- m (* d c))
+                   (print d)
+                   (print c)
+                   (print m)
+                   (<- a (+ 4 (* (+ 6 (* (+ 9 (* (+ 1 (* 0 d)) d)) d)) d)))
+                   (print a))))
+
+ ;;  0: (pushi 5)
+ ;;  2: (pushi 5)
+ ;;  4: (add)
+ ;;  5: (pushn d)
+ ;;  7: (store)
+ ;;  8: (pushn d)
+ ;; 10: (pushn d)
+ ;; 12: (mul)
+ ;; 13: (pushn c)
+ ;; 15: (store)
+ ;; 16: (pushn d)
+ ;; 18: (pushn c)
+ ;; 20: (mul)
+ ;; 21: (pushn b)
+ ;; 23: (store)
+ ;; 24: (pushn d)
+ ;; 26: (print)
+ ;; 27: (pushn c)
+ ;; 29: (print)
+ ;; 30: (pushn b)
+ ;; 32: (print)
+ ;; 33: (pushi 4)
+ ;; 35: (pushi 6)
+ ;; 37: (pushi 9)
+ ;; 39: (pushi 1)
+ ;; 41: (pushi 0)
+ ;; 43: (pushn d)
+ ;; 45: (mul)
+ ;; 46: (add)
+ ;; 47: (pushn d)
+ ;; 49: (mul)
+ ;; 50: (add)
+ ;; 51: (pushn d)
+ ;; 53: (mul)
+ ;; 54: (add)
+ ;; 55: (pushn d)
+ ;; 57: (mul)
+ ;; 58: (add)
+ ;; 59: (pushn a)
+ ;; 61: (store)
+ ;; 62: (pushn a)
+ ;; 64: (print)
+ ;; 65: (stop)
+
+
+(vm-run (make-vm :program (np-compile
+                           ;; 5 5 + d !
+                           ;; d d * c !
+                           ;; d c * m !
+                           ;; d =
+                           ;; c =
+                           ;; m =
+                           ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+                           '(progn
+                             (<- d (+ 5 5))
+                             (<- c (* d d))
+                             (<- m (* d c))
+                             (print d)
+                             (print c)
+                             (print m)
+                             (<- a (+ 4 (* (+ 6 (* (+ 9 (* (+ 1 (* 0 d)) d)) d)) d)))
+                             (print a)))))
+;; prints:
+;; 10
+;; 100
+;; 1000
+;; 1964
+;; --> 66
diff --git a/npvm.lisp b/npvm.lisp
index 3d47a03..4b8de59 100644
--- a/npvm.lisp
+++ b/npvm.lisp
@@ -1,180 +1,247 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               npvm.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    XXX
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2013-12-25 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM"
+  (:use "COMMON-LISP")
+  (:export
+   "+MAX-VARIABLES+"
+
+   "+PUSHI+" "+PUSHN+" "+STORE+" "+NEG+" "+ADD+" "+MUL+" "+SUB+"
+   "+DIV+" "+PRINT+" "+DUMP+" "+STOP+"
+
+   "VM" "MAKE-VM" "VM-P" "COPY-VM" "VM-STACK" "VM-MEMORY" "VM-PROGRAM"
+   "VM-SP" "VM-PC" "VM-RESET" "VM-DUMP" "VM-RUN" "VM-DISASSEMBLE"))
+
+(in-package "COM.INFORMATIMAGO.COMPILER-VS-INTERPRETER.NPVM")
+
+(defconstant +MAX-VARIABLES+ 26)

-(defvar *stack*  (make-array 100 :fill-pointer 0))
-(defvar *memory* (make-array  26 :initial-element 0))
+(defconstant +pushi+ 0)
+(defconstant +pushn+ 1)
+(defconstant +store+ 2)
+(defconstant +neg+   3)
+(defconstant +add+   4)
+(defconstant +mul+   5)
+(defconstant +sub+   6)
+(defconstant +div+   7)
+(defconstant +print+ 8)
+(defconstant +dump+  9)
+(defconstant +stop+ 10)
+
+(defvar *codops* #((pushi i)
+                   (pushn n)
+                   (store)
+                   (neg)
+                   (add)
+                   (mul)
+                   (sub)
+                   (div)
+                   (print)
+                   (dump)
+                   (stop)))
+
+(defstruct vm "Implementation of a simple Stack Virtual Machine"
+           (stack   (make-array 100))
+           (memory  (make-array +MAX-VARIABLES+ :initial-element 0))
+           (program (make-array 1 :initial-element +stop+))
+           (sp 1)
+           (pc 0))

-(defun reset ()
-  (setf *stack*  (make-array 100 :fill-pointer 0)
-        *memory* (make-array  26 :initial-element 0))
+
+(defun vm-reset (vm)
+  (setf (vm-stack  vm) (make-array 100 :fill-pointer 0)
+        (vm-memory vm) (make-array  26 :initial-element 0)
+        (vm-pc vm) 0
+        (vm-sp vm) 0)
   (values))

-(defvar *names*  "abcdefghijklmnopqrstuvwxyz")

+
+(defvar *names*  "abcdefghijklmnopqrstuvwxyz")
 (defun index-to-name (i)
   (aref *names* i))
 (defun index-from-name (name)
   (position name *names*))


-(defun vm-sp ()
-  (fill-pointer *stack*))
-
-(defun test/vm-push ()
-  (let ((old-sp (vm-sp)))
-    (vm-push 42)
-    (assert (= (1+ old-sp) (vm-sp))))
-  :success)
-
-(test/vm-push) ; --> :success
-
-
-(defun dump ()
+(defun vm-dump (vm)
   (loop
-    :for i :below (fill-pointer *stack*)
+    :for i :below (vm-sp vm)
     :initially (format t "--------------------~%")
-    :do (format t "[~3D]: ~10D~%" i (aref *stack* i))
+    :do (format t "[~3D]: ~10D~%" i (aref (vm-stack vm) i))
     :finally  (format t "--------------------~%"))
   (loop
-    :for i :below (length *memory*)
-    :do (format t "[~3D]: ~10D~%" (index-to-name i) (aref *memory* i))
+    :for i :below (length (vm-memory vm))
+    :do (format t "[~3D]: ~10D~%" (index-to-name i) (aref (vm-memory vm) i))
     :finally  (format t "--------------------~%")))

 (defun namep       (x) (consp x))
 (defun wrap-name   (x) (cons 'name x))
 (defun unwrap-name (x) (cdr x))

-(defun vm-push (n)
-  (if (< (fill-pointer *stack*) (array-dimension *stack* 0))
-      (vector-push n *stack*)
-      (error "Stack is full")))
-
-(defun vm-pushv (n)
-  (if (< (fill-pointer *stack*) (array-dimension *stack* 0))
-      (vector-push (wrap-name n) *stack*)
-      (error "Stack is full")))
-
-(defun vm-pop ()
-  (if (plusp (fill-pointer *stack*))
-      (let ((value (vector-pop *stack*)))
-        (if (namep value)
-            (vm-retrieve value)
-            value))
-      (error "Stack is empty")))
-
-(defun vm-popv ()
-  (if (plusp (fill-pointer *stack*))
-      (vector-pop *stack*)
-      (error "Stack is empty")))
-
-(defun vm-store (d x)
-  (if (< -1 (unwrap-name d) (length *memory*))
-      (setf (aref *memory* (unwrap-name d)) x)
+(defun vm-push (vm n)
+  (if (< (vm-sp vm) (array-dimension (vm-stack vm) 0))
+      (setf (aref (vm-stack vm) (vm-sp vm)) n
+            (vm-sp vm) (1+ (vm-sp vm)))
+      (error "Stack is full - vm-push")))
+
+(defun vm-pushv (vm n)
+  (if (< (vm-sp vm) (array-dimension (vm-stack vm) 0))
+      (setf (aref (vm-stack vm) (vm-sp vm))  (wrap-name n)
+            (vm-sp vm) (1+ (vm-sp vm)))
+      (error "Stack is full - vm-pushv")))
+
+(defun vm-pop (vm )
+  (if (plusp (vm-sp vm))
+      (progn
+        (decf (vm-sp vm))
+        (let ((value (aref (vm-stack vm) (vm-sp vm))))
+          (if (namep value)
+              (vm-retrieve vm value)
+              value)))
+      (error "Stack is empty - vm-pop")))
+
+(defun vm-popv (vm)
+  (if (plusp (vm-sp vm))
+      (progn
+        (decf (vm-sp vm))
+        (aref (vm-stack vm) (vm-sp vm)))
+      (error "Stack is empty - vm-popv")))
+
+(defun vm-store (vm d x)
+  (if (< -1 (unwrap-name d) (length (vm-memory vm)))
+      (setf (aref (vm-memory vm) (unwrap-name d)) x)
       (error "Invalid memory address ~D" d)))

-(defun vm-retrieve (d)
-  (if (< -1 (unwrap-name d) (length *memory*))
-      (aref *memory* (unwrap-name d))
+(defun vm-retrieve (vm d)
+  (if (< -1 (unwrap-name d) (length (vm-memory vm)))
+      (aref (vm-memory vm) (unwrap-name d))
       (error "Invalid memory address ~D" d)))


-
-(defconstant +pushi+ 0)
-(defconstant +pushn+ 1)
-(defconstant +store+ 2)
-(defconstant +neg+   3)
-(defconstant +add+   4)
-(defconstant +mul+   5)
-(defconstant +sub+   6)
-(defconstant +div+   7)
-(defconstant +print+ 8)
-(defconstant +dump+  9)
-(defconstant +stop+ 10)
-
-(defvar *codops* #((pushi i)
-                   (pushn n)
-                   (store)
-                   (neg)
-                   (add)
-                   (mul)
-                   (sub)
-                   (div)
-                   (print)
-                   (dump)
-                   (stop)))
-
-(defun vm-disassemble (pgm pc)
+(defun vm-disassemble (vm &optional (pc 0))
   (format t "~3D: " pc)
-  (let ((code (aref pgm (prog1 pc (incf pc)))))
-    (format t "~S~%"
-            (if (< -1 code (length *codops*))
-                (let ((discode (aref *codops* code)))
-                  (if (< 1 (length discode))
-                      (list (first discode)
-                            (ecase (second discode)
-                              ((i) (aref pgm (prog1 pc (incf pc))))
-                              ((n) (intern (string-upcase
-                                            (index-to-name
-                                             (aref pgm (prog1 pc (incf pc)))))))))
-                      discode))
-                `(error ,code)))
-    pc))
-
-
-(defun vm-run (pgm &key (trace nil) (reset t) (pc 0))
-  (when reset (reset))
-  (when trace
-    (let ((*print-pretty* t)
-          (*print-right-margin* 72))
-      (format t "~A~%PC: ~3D~%" pgm pc))
-    (dump))
-  (let ((pc pc))
+  (macrolet ((next-instruction ()
+               `(aref (vm-program vm) (prog1 pc (incf pc)))))
+    (let ((code (next-instruction)))
+      (format t "~(~A~)~%"
+              (if (< -1 code (length *codops*))
+                  (let ((discode (aref *codops* code)))
+                    (if (< 1 (length discode))
+                        (list (first discode)
+                              (ecase (second discode)
+                                ((i) (next-instruction))
+                                ((n) (intern (string-upcase
+                                              (index-to-name
+                                               (next-instruction)))))))
+                        discode))
+                  `(error ,code)))
+      pc)))
+
+
+(defun vm-run (vm &key (trace nil) (reset t) (pc (vm-pc vm)))
+  (when reset
+    (vm-reset vm))
+  (setf (vm-pc vm) pc)
+  (with-accessors ((program vm-program)
+                   (pc vm-pc)) vm
+    (when trace
+      (let ((*print-pretty* t)
+            (*print-right-margin* 72))
+        (format t "~A~%PC: ~3D~%" program pc))
+      (vm-dump vm))
     (handler-case
         (loop
-          (when trace (vm-disassemble pgm pc))
-          (let ((code (aref pgm (prog1 pc (incf pc)))))
-            (case code
-              (#.+pushi+ (vm-push  (aref pgm (prog1 pc (incf pc)))))
-              (#.+pushn+ (vm-pushv (aref pgm (prog1 pc (incf pc)))))
-              (#.+store+ (vm-store (vm-popv) (vm-pop)))
-              (#.+neg+   (vm-push (- (vm-pop))))
-              (#.+add+   (vm-push (+ (vm-pop) (vm-pop))))
-              (#.+mul+   (vm-push (* (vm-pop) (vm-pop))))
-              (#.+sub+   (let ((b (vm-pop))
-                               (a (vm-pop)))
-                           (vm-push (- a b))))
-              (#.+div+   (let ((b (vm-pop))
-                               (a (vm-pop)))
-                           (when (zerop b)
-                             (error 'division-by-zero))
-                           (vm-push (/ a b))))
-              (#.+print+ (format t "~D~%" (vm-pop)))
-              (#.+dump+  (dump))
-              (#.+stop+  (return-from vm-run pc)))))
+          (when trace (vm-disassemble program pc))
+          (macrolet ((next-instruction ()
+                       `(aref program (prog1 pc (incf pc)))))
+            (let ((code (next-instruction)))
+              (case code
+                (#.+pushi+ (vm-push  vm (next-instruction)))
+                (#.+pushn+ (vm-pushv vm (next-instruction)))
+                (#.+store+ (vm-store vm (vm-popv vm) (vm-pop vm)))
+                (#.+neg+   (vm-push vm (- (vm-pop vm))))
+                (#.+add+   (vm-push vm (+ (vm-pop vm) (vm-pop vm))))
+                (#.+mul+   (vm-push vm (* (vm-pop vm) (vm-pop vm))))
+                (#.+sub+   (let ((b (vm-pop vm))
+                                 (a (vm-pop vm)))
+                             (vm-push vm (- a b))))
+                (#.+div+   (let ((b (vm-pop vm))
+                                 (a (vm-pop vm)))
+                             (when (zerop b)
+                               (error 'division-by-zero))
+                             (vm-push vm (/ a b))))
+                (#.+print+ (format t "~D~%" (vm-pop vm)))
+                (#.+dump+  (vm-dump vm))
+                (#.+stop+  (return-from vm-run pc))))))
       (error (err)
         (format *error-output* "PC = ~D~%~A~%" pc err)))))

-;; 5 5 + d !
-;; d d * c !
-;; d c * m !
-;; d =
-;; c =
-;; m =
-;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
-
-(vm-run (vector
-         +pushi+ 5 +pushi+ 5 +add+ +pushn+ 3 +store+ ; +dump+
-         +pushn+ 3 +pushn+ 3 +mul+ +pushn+ 2 +store+ ; +dump+
-         +pushn+ 3 +pushn+ 2 +mul+ +pushn+ 12 +store+ ; +dump+
-         +pushn+ 3 +print+
-         +pushn+ 2 +print+
-         +pushn+ 12 +print+
-         +pushi+ 4 +pushi+ 6 +pushi+ 9 +pushi+ 1 +pushi+ 0
-         +pushn+ 3 +mul+ +add+
-         +pushn+ 3 +mul+ +add+
-         +pushn+ 3 +mul+ +add+
-         +pushn+ 3 +mul+ +add+
-         +pushn+ 0 +store+
-         +pushn+ 0 +print+
-         +stop+)
+
+
+(defun test/vm-push ()
+  (let* ((vm (make-vm))
+         (old-sp (vm-sp vm)))
+    (vm-push vm 42)
+    (assert (= (1+ old-sp) (vm-sp vm))))
+  :success)
+
+(test/vm-push)
+
+
+(vm-run (make-vm :program (vector
+                           ;; 5 5 + d !
+                           ;; d d * c !
+                           ;; d c * m !
+                           ;; d =
+                           ;; c =
+                           ;; m =
+                           ;; 4 6 9 1 0 d*+d*+d*+d*+ a ! a =
+                           +pushi+ 5 +pushi+ 5 +add+ +pushn+ 3 +store+ ; +dump+
+                           +pushn+ 3 +pushn+ 3 +mul+ +pushn+ 2 +store+ ; +dump+
+                           +pushn+ 3 +pushn+ 2 +mul+ +pushn+ 12 +store+ ; +dump+
+                           +pushn+ 3 +print+
+                           +pushn+ 2 +print+
+                           +pushn+ 12 +print+
+                           +pushi+ 4 +pushi+ 6 +pushi+ 9 +pushi+ 1 +pushi+ 0
+                           +pushn+ 3 +mul+ +add+
+                           +pushn+ 3 +mul+ +add+
+                           +pushn+ 3 +mul+ +add+
+                           +pushn+ 3 +mul+ +add+
+                           +pushn+ 0 +store+
+                           +pushn+ 0 +print+
+                           +stop+))
         :trace nil)

 ;; prints:
ViewGit