Add string type + print instruction

README.md

@@ -5,6 +5,8 @@
 * 64bit only
 * Tagged Pointers for values, 4bit tag, 60bit value
   * 000: Integer
+  * 101: Pair
+  * 110: Pair
   * 111: Hardcoded primitives, #t, #f, '() 
 
 ## Preprocessing

compile.scm

@@ -20,13 +20,12 @@
   (or (fixnum? x)
       (boolean? x)
       (char? x)
+      (symbol? x) ; TODO: This need to be here for "a-normalize" to work with strings
       (null? x)))
 
 (defn atomic? (x)
   (or (immediate? x)
-      (string? x)
-      (symbol? x)
-      (null? x)))
+      (string? x)))
 
 (defn immediate-rep (x)
   (cond
@@ -44,7 +43,9 @@
 ; (include "syntax/derived/or.scm")
 (include "syntax/if.scm")
 (include "syntax/begin.scm")
+(include "syntax/cond.scm")
 (include "syntax/let.scm")
+(include "syntax/string.scm")
 
 (include "preprocessing/syntax-desugar.scm")
 (include "preprocessing/alpha-convert.scm")
@@ -110,6 +111,8 @@
   (cond
     ((immediate? expr)
      (emit-immediate var expr))
+    ((string? expr)
+     (emit-string var expr))
     ((if? expr)
      (emit-if var env expr))
     ((begin? expr)
@@ -156,18 +159,16 @@
   (emit "define i64 @scheme_body() {")
   ; Allocate 10k 64bit cells to use as heap 
   ; and store the pointer to the base in "@heap_base"
-  (emit "  %raw_cells = call i8* @calloc(i32 80000, i32 2)")
-  (emit "  store i8* %raw_cells, i8** @raw_heap_base, align 8")
-  (emit "  %cells = bitcast i8* %raw_cells to i64*")
-  (emit "  store i64* %cells, i64** @heap_base, align 8")
+  (emit "  %cells = call i8* @calloc(i32 10000, i32 8)")
+  (emit "  store i8* %cells, i8** @heap_base, align 8")
 
   (emit "  %res = call i64 @prim_main()")
 
   ; (emit-expr "%res" empty-env expr)
 
   ; Free the heap
-  (emit "  call void @free(i8* %raw_cells)")
-  (emit "  %foo = call i64 @prim_puts(i64 %res)")
+  (emit "  call void @free(i8* %cells)")
+  ; (emit "  %foo = call i64 @prim_inspectn(i64 %res)")
   (emit "  ret i64 %res")
   (emit "}")
   (for-each (fn (expr) (emit-toplevel-expr (preprocess expr)))
@@ -200,14 +201,53 @@
 ;                  (fib (fx- n 2)))))))
 
 ; (emit-program '(
-;   (defn fib (n)
-;         (if (fx<=? n 1)
-;             n
-;             (fx+ (fib (fx- n 1))
-;                  (fib (fx- n 2)))))
+;   (defn display (val)
+;         (cond
+;           ((pair? val)
+;            (putchar 40)
+;            (putchar 32)
+;            (display (fst val))
+;            (putchar 32)
+;            (putchar 46)
+;            (putchar 32)
+;            (display (rst val))
+;            (putchar 32)
+;            (putchar 41))
+;           ((eq? val #t)
+;            (putchar 35)
+;            (putchar 116))
+;           ((eq? val #f)
+;            (putchar 35)
+;            (putchar 102))
+;           (else (print val))))
 ;   (defn main ()
-;     (fib 40))
+;     (display (cons #f #t))
+;     (putchar 10)
+;   )
 ; ))
+
+(emit-program '(
+  (defn main ()
+        (inspect (heap-index))
+        (newline)
+        (print "test")
+        (newline)
+        (inspect (heap-index))
+        (newline)
+        )
+        ; (print "test"))
+        ; (print (heap-index))
+        ; (putchar 46)
+        ; (let ((res "test"))
+        ;      (putchar 46)
+        ;      (print (heap-index))
+        ;      (putchar 46)
+        ;      res))
+))
+
+; (print (list 'puts2 "test"))
+; (print (normalize-term (list 'puts2 "test")))
+
 ; (emit-program '(
 
 ;   (defn fib (n)

helper.scm

@@ -0,0 +1,23 @@
+(define (escape str)
+  (let ((parts (map ->string (string->list (->string str)))))
+    (string-join
+      (cons "prim_"
+        (map
+          (lambda (part)
+            (cond
+              ((equal? part "+") "_plus_")
+              ((equal? part ">") "_greater_")
+              ((equal? part "<") "_less_")
+              ((equal? part "=") "_equal_")
+              ((equal? part "*") "_times_")
+              ((equal? part "?") "_questionmark_")
+              (else part)))
+          parts)))))
+
+(define (tagged-list? expr tag)
+  (and (pair? expr)
+       (eq? (car expr) tag)))
+
+(define (string-join lst) (foldl string-append "" lst))
+(define (show . args) (string-join (map ->string args)))
+

preprocessing/a-normalize.scm

@@ -46,7 +46,7 @@
 
 (defn normalize-name (m k)
   (normalize m (fn (n)
-                 (if (atomic? n)
+                 (if (immediate? n)
                      (k n)
                      (let ((t (gensym)))
                           (make-let (list (list t n))

preprocessing/syntax-desugar.scm

@@ -13,8 +13,10 @@
                  new-body)))
     ((let*? expr)
      (syntax-desugar (let*->nested-lets expr)))
+    ((cond? expr)
+     (syntax-desugar (cond->nested-ifs expr)))
     ((begin? expr)
-     (make-begin
+     (make-sequence
        (map syntax-desugar (begin-expressions expr))))
     ((defn? expr)
      (let* ((name (defn-name expr))

print_ptr.c

@@ -6,6 +6,8 @@
 #define tag_mask 0b111
 #define fixnum_tag 0b000
 #define const_tag 0b111
+#define pair_tag 0b110
+#define string_tag 0b101
 
 #define true_value 0b111
 #define false_value 0b011
@@ -14,7 +16,7 @@
 // all scheme values are of type ptr
 typedef unsigned long ptr;
 
-extern void print_ptr(ptr x, char* heap) {
+extern void print_ptr(ptr x) {
   unsigned long tag = x & tag_mask;
   unsigned long value = x >> 3;
   if (tag == fixnum_tag) {
@@ -29,12 +31,22 @@ extern void print_ptr(ptr x, char* heap) {
     } else {
       printf("Unknown constant: %08x", value);
     }
+  } else if (tag == pair_tag) {
+    ptr* cons = (ptr*)(value << 3);
+
+    /* printf("(\n"); */
+    print_ptr(cons[0]);
+    /* printf(" . "); */
+    /* print_ptr(cons[0]); */
+    /* printf(" . "); */
+    print_ptr(cons[1]);
+    /* printf(")"); */
   } else {
     printf("#<unknown 0x%08x>", x);
   }
 }
 
-extern void puts_ptr(ptr x, char* heap) {
-  print_ptr(x, heap);
+extern void puts_ptr(ptr x) {
+  print_ptr(x);
   printf("\n");
 }

stdlib-ll/boolean.ll

@@ -6,3 +6,12 @@ define i64 @prim_not(i64 %a) {
   false:
     ret i64 31
 }
+
+define i64 @prim_eq_questionmark_(i64 %a, i64 %b) {
+  %tmp = icmp eq i64 %a, %b
+  br i1 %tmp, label %true, label %false
+  true:
+    ret i64 63
+  false:
+    ret i64 31
+}

stdlib-ll/fixnum.ll

@@ -3,7 +3,7 @@ define i64 @prim_fx_plus_(i64 %a, i64 %b) {
   ret i64 %tmp
 }
 
-define i64 @prim_fx_minus_(i64 %a, i64 %b) {
+define i64 @prim_fx-(i64 %a, i64 %b) {
   %tmp = sub i64 %a, %b
   ret i64 %tmp
 }

stdlib-ll/prelude.ll

@@ -1,22 +1,81 @@
 declare i8* @calloc(i32, i32)
 declare void @free(i8*)
-declare void @print_ptr(i64, i8*)
-declare void @puts_ptr(i64, i8*)
+declare i8 @putchar(i8)
 
-@heap_base = global i64* zeroinitializer, align 8
-@raw_heap_base = global i8* zeroinitializer, align 8
+declare void @print_ptr(i64)
+declare void @puts_ptr(i64)
+
+@heap_base = global i8* zeroinitializer, align 8
 @heap_index = global i64 0, align 8
 
-define i64 @prim_print(i64 %a) {
-  %base = load i8*, i8** @raw_heap_base
-  call void @print_ptr(i64 %a, i8* %base)
+define i64 @prim_inspect(i64 %a) {
+  call void @print_ptr(i64 %a)
   ; TODO: Return empty list or undefined
   ret i64 0
 }
 
-define i64 @prim_puts(i64 %a) {
-  %base = load i8*, i8** @raw_heap_base
-  call void @puts_ptr(i64 %a, i8* %base)
+define i64 @prim_newline() {
+  call i8 @putchar(i8 10)
   ; TODO: Return empty list or undefined
   ret i64 0
 }
+
+define i64 @prim_putchar(i64 %a) {
+  %raw_value = lshr i64 %a, 3
+  %char = trunc i64 %raw_value to i8
+
+  %raw_res = call i8 @putchar(i8 %char)
+  %res = zext i8 %raw_res to i64  
+  %res2 = shl i64 %res, 3
+
+  ret i64 %res2
+}
+
+define i64 @internal_heap-store(i64 %val) {
+  %heap_base = load i8*, i8** @heap_base
+  %heap_index = load i64, i64* @heap_index
+
+  %raw_heap_ptr = getelementptr i8, i8* %heap_base, i64 %heap_index
+  %heap_ptr = bitcast i8* %raw_heap_ptr to i64*
+
+  store i64 %val, i64* %heap_ptr
+  %int_ptr = ptrtoint i8* %raw_heap_ptr to i64
+
+  %new_heap_index = add i64 %heap_index, 8
+  store i64 %new_heap_index, i64* @heap_index, align 8
+
+  ret i64 %int_ptr
+}
+
+define i64 @internal_heap-store-byte(i8 %val) {
+  %heap_base = load i8*, i8** @heap_base
+  %heap_index = load i64, i64* @heap_index
+
+  %raw_heap_ptr = getelementptr i8, i8* %heap_base, i64 %heap_index
+
+  store i8 %val, i8* %raw_heap_ptr
+  %int_ptr = ptrtoint i8* %raw_heap_ptr to i64
+
+  %new_heap_index = add i64 %heap_index, 1
+  store i64 %new_heap_index, i64* @heap_index, align 8
+
+  ret i64 %int_ptr
+}
+
+define void @internal_heap-align-index() {
+  %heap_index = load i64, i64* @heap_index
+  ; Get the last 3 bytes of the index
+  %rem = and i64 %heap_index, 7
+  ; If it is a multiple of 8, those bytes are 0b000
+
+  %test = icmp eq i64 %rem, 0
+  br i1 %test, label %true, label %false
+  true:
+  ret void
+
+  false:
+  %tmp = sub i64 %heap_index, %rem
+  %new_heap_index = add i64 %tmp, 8
+  store i64 %new_heap_index, i64* @heap_index, align 8
+  ret void
+}

syntax/begin.scm

@@ -1,6 +1,11 @@
 (defn begin? (expr) (tagged-list? expr 'begin))
 (def begin-expressions rst)
 
+(defn make-sequence (expressions)
+  (if (null? (rst expressions))
+      (fst expressions)
+      (make-begin expressions)))
+
 (defn make-begin (expressions)
   (cons 'begin expressions))
 

syntax/let.scm

@@ -34,20 +34,5 @@
                     (make-let* (rst bindings)
                                body))))))
 
-
 (defn make-let* (bindings body)
   (list 'let* bindings body))
-
-; (def (emit-let* var env expr)
-;   (def (process-let bindings new-env)
-;     (cond
-;       ((null? bindings)
-;        (emit-expr var new-env (let-body expr)))
-;       (else
-;         (let ((b (fst bindings))
-;               (var_ (generate-var)))
-;           (emit-expr var_ new-env (let-binding-value b))
-;           (process-let
-;             (rst bindings)
-;             (extend-env (let-binding-variable b) var_ new-env))))))
-;   (process-let (let-bindings expr) env))

syntax/string.scm

@@ -0,0 +1,15 @@
+(defn emit-string (var str)
+  (let ((len (string-length str))
+        (tmp (generate-var)))
+    (emit (format "  ~A = call i64 @internal_heap-store(i64 ~A)" tmp len))
+    (begin
+      (defn helper (str idx len)
+         (if (< idx len)
+           (let* ((char (string-ref str idx))
+                  (ord (char->integer char)))
+             (emit (format "  call i64 @internal_heap-store-byte(i8 ~A)" ord))
+             (helper str (add1 idx) len))
+           (emit (format "  call i64 @internal_heap-store-byte(i8 0)"))))
+      (helper str 0 len))
+    (emit (format "  call void @internal_heap-align-index()"))
+    (emit (format  "~A = or i64 ~A, 5" var tmp))))

test/runner.scm

@@ -121,10 +121,10 @@
 
 ; Fixnums
 
-; (test-programs
-;   (list 
-;     '((fx+ (fx- 1 2) 3) "2")
-;     '((fx+ 1 (fx+ 2 3)) "6")))
+(test-programs
+  (list 
+    '((fx+ (fx- 1 2) 3) "2")
+    '((fx+ 1 (fx+ 2 3)) "6")))
 
 ; Pairs