Reduce usage of

compatibility.scm

@@ -72,3 +72,10 @@
             (string-append (fst lst) sep)
             (string-join2 (rst lst) sep)))))
 
+(def any->string ->string)
+(def fixnum->string number->string)
+
+(defn string-append* (lst)
+      (if (null? lst)
+          ""
+          (string-append (fst lst) (string-append* (rst lst)))))

compile.scm

@@ -2,6 +2,7 @@
 (include "stdlib.scm")
 (include "environment.scm")
 (include "helper.scm")
+(include "llvm.scm")
 (include "syntax/if.scm")
 (include "syntax/begin.scm")
 (include "syntax/let.scm")
@@ -42,9 +43,9 @@
 
 (defn emit-immediate (var expr)
   (let ((tmp (generate-var)))
-    (print (format "  ~A = alloca i64" tmp))
-    (print (format "  store i64 ~A, i64* ~A" (immediate-rep expr) tmp))
-    (print (format "  ~A = load i64, i64* ~A" var tmp))))
+    (emit-alloca tmp)
+    (emit-store (immediate-rep expr) tmp)
+    (emit-load var tmp)))
 
 (defn defn? (expr) (tagged-list? expr 'defprim))
 (def defn-name frst)
@@ -69,8 +70,8 @@
               (string-join2 (map (fn (a) (string-append "i64 " (rst a))) args-with-vars) ", ")))
        (print (format "define i64 @~A(~A) {" (escape name) args-string))
        (emit-expr "%res" args-with-vars (defn-body expr))
-       (print (format "  ret i64 %res"))
-       (print (format "}"))))
+       (emit-ret "%res")
+       (print "}")))
      (else (error "Invalid toplevel expression: " expr))))
 
 (defn emit-lambda (expr)
@@ -85,9 +86,8 @@
            (string-join2 (map (fn (a) (string-append "i64 " (rst a))) args-with-vars) ", ")))
     (print (format "define i64 @lambda_~A(~A) {" name args-string))
     (emit-expr "%res" args-with-vars prep-body)
-    (print (format "  ret i64 %res"))
-    (print (format "}"))
-    ))
+    (emit-ret "%res")
+    (print "}")))
 
 (defn emit-global-var (var)
       (print (format "@var_~A = weak global i64 0" (escape var))))
@@ -106,16 +106,16 @@
            (name (frst expr))
            (arity (frrst expr))
            (env_ (frrrst expr)))
-       (print (format "  ~A = ptrtoint i64 (~A)* @lambda_~A to i64" tmp1 (arg-str (add1 arity)) name))
+       (print (string-append* (list "  " tmp1 " = ptrtoint i64 (" (arg-str (add1 arity)) ")* @lambda_" (symbol->string name) " to i64")))
        (emit-expr tmp2 env env_)
-       (print (format "  ~A = call i64 @internal_make-closure(i64 ~A, i64 ~A, i64 ~A)" var tmp1 (immediate-rep arity) tmp2))
+       (emit-call3 var "@internal_make-closure" tmp1 (fixnum->string (immediate-rep arity)) tmp2)
        ))
     ((tagged-list? expr 'def)
      (let ((tmp (generate-var))
            (name (frst expr))
            (value (frrst expr)))
        (emit-expr tmp env value)
-       (print (format "store i64 ~A, i64* @var_~A" tmp (escape name)))))
+       (emit-store tmp (string-append "@var_" (escape name)))))
     ((list? expr)
      (let* ((name (fst expr))
             (args (rst expr))
@@ -134,8 +134,8 @@
                  (tmp4 (generate-var))
                  (arity (length args)))
              (emit-variable-ref tmp1 env name)
-             (print (format "  ~A = call i64 @internal_closure-function(i64 ~A)" tmp2 tmp1))
-             (print (format "  ~A = call i64 @prim_closure-env(i64 ~A)" tmp4 tmp1))
+             (emit-call1 tmp2 "@internal_closure-function" tmp1)
+             (emit-call1 tmp4 "@prim_closure-env" tmp1)
              (print (format "  ~A = inttoptr i64 ~A to i64 (~A)*" tmp3 tmp2 (arg-str (add1 arity))))
              (print (format "  ~A = call i64 ~A(i64 ~A, ~A)" var tmp3 tmp4 (string-join2 vars ", "))))))))
     ((variable? expr) (emit-variable-ref var env expr))
@@ -146,17 +146,16 @@
   (let ((var_ (lookup-or expr #f env)))
     (if var_
       (let ((tmp (generate-var)))
-        (print (format "  ~A = alloca i64" tmp))
-        (print (format "  store i64 ~A, i64* ~A" var_ tmp))
-        (print (format "  ~A = load i64, i64* ~A" var tmp)))
+        (emit-alloca tmp)
+        (emit-store var_ tmp)
+        (emit-load var tmp))
       (let ((tmp (generate-var)))
-        (print (format "  ~A = load i64, i64* @var_~A" var (escape expr)))))))
-      ; (error "Reference to unbound variable: " var))))
+        (emit-load var (string-append "@var_" (escape expr)))))))
 
 (defn emit-symbol (var expr)
   (let ((tmp (generate-var)))
     (emit-string tmp (symbol->string expr))
-    (print (format "  ~A = call i64 @prim_string-_greater_symbol(i64 ~A)" var tmp))))
+    (emit-call1 var "@prim_string-_greater_symbol" tmp)))
 
 (defn emit-program (exprs)
   (let ((preprocessed (map (fn (expr) (pipe expr syntax-desugar alpha-convert-expr closure-convert normalize-term))
@@ -165,7 +164,7 @@
     (for-each emit-lambda lambdas)
     (print "define i64 @prim_main() {")
     (for-each (fn (expr) (emit-expr (generate-var) empty-env expr)) preprocessed)
-    (print "  ret i64 0")
+    (emit-ret (fixnum->string 0))
     (print "}")
 ))
 

helper.scm

@@ -2,7 +2,8 @@
 (defn generate-var ()
   (begin
     (set! var-counter (add1 var-counter))
-    (format "%tmp~A" (sub1 var-counter))))
+    (string-append "%tmp"
+                   (fixnum->string var-counter))))
 
 (def label-count 0)
 (defn unique-label (name)

syntax/if.scm

@@ -15,19 +15,19 @@
         (res-var1 (generate-var))
         (res-var2 (generate-var)))
     (emit-expr test-var env (if-test expr))
-    (print (format "  ~A = icmp eq i64 ~A, ~A" test-res-var test-var (immediate-rep #t)))
-    (print (format "  ~A = alloca i64, align 8" res-var))
-    (print (format "  br i1 ~A, label %~A, label %~A" test-res-var true-label false-label))
+    (print (string-append* (list "  " test-res-var " = icmp eq i64 " test-var ", " (fixnum->string (immediate-rep #t)))))
+    (emit-alloca res-var)
+    (print (string-append* (list "  br i1 " test-res-var ", label %" true-label ", label %" false-label)))
 
-    (print (format "~A:" true-label))
+    (emit-label true-label)
     (emit-expr res-var1 env (if-consequent expr))
-    (print (format "  store i64 ~A, i64* ~A, align 8" res-var1 res-var))
-    (print (format "  br label %~A" end-label))
+    (emit-store res-var1 res-var)
+    (emit-br1 end-label)
 
-    (print (format "~A:" false-label))
+    (emit-label false-label)
     (emit-expr res-var2 env (if-alternative expr))
-    (print (format "  store i64 ~A, i64* ~A, align 8" res-var2 res-var))
-    (print (format "  br label %~A" end-label))
+    (emit-store res-var2 res-var)
+    (emit-br1 end-label)
 
-    (print (format "~A:" end-label))
-    (print (format "  ~A = load i64, i64* ~A, align 8" var res-var))))
+    (emit-label end-label)
+    (emit-load var res-var)))

syntax/string.scm

@@ -1,14 +1,16 @@
 (defn emit-string (var str)
   (let ((len (string-length str))
         (tmp (generate-var)))
-    (print (format "  ~A = call i64 @internal_heap-current-pointer()" tmp))
+    (emit-call0 tmp "@internal_heap-current-pointer")
     (emit-string_ str 0 len)
-    (print (format "  call i64 @internal_heap-store-byte(i8 0)"))
-    (print (format "  call void @internal_heap-align-index()"))
-    (print (format "  ~A = or i64 ~A, 5" var tmp))))
+    (print "  call i64 @internal_heap-store-byte(i8 0)")
+    (print "  call void @internal_heap-align-index()")
+    (print (string-append* (list "  " var " = or i64 " tmp ", 5")))))
 
 (defn emit-string_ (str idx len)
   (if (< idx len)
       (begin
-        (print (format "  call i64 @internal_heap-store-byte(i8 ~A)" (char->integer (string-ref str idx))))
+        (print (string-append* (list "  call i64 @internal_heap-store-byte(i8 "
+                                     (fixnum->string (char->integer (string-ref str idx)))
+                                     ")")))
         (emit-string_ str (add1 idx) len))))