Atomic cps operations (ints lol)

scmvm/assembler.scm

@@ -6,6 +6,8 @@
   #:use-module ((scheme base) #:select (write-bytevector))
   #:export ((make-assembler* . make-assembler)
 	    assembler?
+	    assembler-pos
+	    assembler-buf
 	    assembler-labels
 	    emit-label
 	    emit-instruction

scmvm/language/common.scm

@@ -1,67 +0,0 @@
-(define-module (scmvm language common)
-  #:use-module (srfi srfi-26)
-  #:use-module (srfi srfi-9)
-  #:use-module (rnrs bytevectors)
-  #:export (<assembler>
-	    (make-assembler* . make-assembler)
-	    assembler?
-	    assembler-labels
-	    assembler-pos
-	    assembler-buf
-	    assembler-pos-set!
-	    assembler-buf-set!
-	    assembler-label-add-reference
-	    assembler-label-add-value
-	    write-byte
-	    write-word
-	    emit-label
-	    finalize-references))
-
-(define (make-label) (cons #f '()))
-
-(define-record-type <assembler>
-  (make-assembler pos buf labels)
-  assembler?
-  (pos assembler-pos assembler-pos-set!)
-  (buf assembler-buf assembler-buf-set!)
-  (labels assembler-labels))
-
-(define (make-assembler*)
-  (make-assembler 0 (make-bytevector 1024) (make-hash-table)))
-
-(define (assembler-buf-grow! asm)
-  (let ([buf (make-bytevector (ash (bytevector-length (assembler-buf asm)) -1))])
-    (bytevector-copy! (assembler-buf asm) 0 buf 0 (bytevector-length (assembler-buf asm)))
-    (assembler-buf-set! asm buf)))
-
-(define* (write-word word asm #:optional (pos (assembler-pos asm)))
-  (when (> (+ pos 4) (bytevector-length (assembler-buf asm)))
-    (assembler-buf-grow! asm))
-  (bytevector-u32-native-set! (assembler-buf asm) pos word))
-
-(define* (write-byte byte asm #:optional (pos (assembler-pos asm)))
-  (when (> (+ pos 1) (bytevector-length (assembler-buf asm)))
-    (assembler-buf-grow! asm))
-  (bytevector-u8-set! (assembler-buf asm) pos byte))
-
-(define (assembler-label-add-reference asm name addr)
-  (when (not (hash-ref (assembler-labels asm) name))
-    (hash-set! (assembler-labels asm) name (make-label)))
-  (let ([label (hash-ref (assembler-labels asm) name)])
-    (set-cdr! label (cons addr (cdr label)))))
-
-(define (assembler-label-add-value asm name val)
-  (when (not (hash-ref (assembler-labels asm) name))
-    (hash-set! (assembler-labels asm) name (make-label)))
-  ;; 1+ to fudge for null pointers
-  (set-car! (hash-ref (assembler-labels asm) name) (1+ val)))
-
-(define (finalize-references asm)
-  (define (install-location _name label)
-    (for-each
-     (cute write-word (car label) asm <>)
-     (cdr label)))
-  (hash-for-each install-location (assembler-labels asm)))
-
-(define (emit-label asm name)
-  (assembler-label-add-value asm name (assembler-pos asm)))

scmvm/language/cps.scm

@@ -0,0 +1,14 @@
+(define-module (scmvm language cps)
+  #:use-module (scmvm assembler)
+  #:use-module (ice-9 match)
+  #:export (compile-cps))
+
+(define (compile-atom asm atom)
+  (cond
+   [(number? atom) (emit-literal asm atom)]))
+
+(define (compile-cps asm soup)
+  (when (not (null? soup))
+    (match (car soup)
+      [(? (negate pair?) atom) (compile-atom asm atom)])
+    (compile-cps asm (cdr soup))))

tests.scm

@@ -1,8 +1,9 @@
 (use-modules (d- test)
 	     (scmvm assembler)
-             (scmvm language assembly)
              (scmvm vm)
 	     (scmvm debugger)
+	     (scmvm language assembly)
+	     (scmvm language cps)
              (rnrs bytevectors)
              (rnrs io ports)
              ((scheme base)
@@ -166,3 +167,13 @@
     (debugger-continue my-debugger)
     (assert-equal 23 (vm-pc my-vm)) ;; continue stops stepping
     ))
+
+(define-test-suite "cps"
+  (define-test "atomics"
+    (define asm (make-assembler))
+    (compile-cps asm '(1))
+    (assert-equal 1 (bytevector-u32-native-ref (assembler-buf asm) 0)))
+  (define-test "atomics"
+    (define asm (make-assembler))
+    (compile-cps asm '(1))
+    (assert-equal 1 (bytevector-u32-native-ref (assembler-buf asm) 0))))