path: root/compiler.scm

(use-modules (ice-9 format)
             (ice-9 popen)
             (ice-9 rdelim)
             (srfi srfi-1))

;; Assuming a 64 bit intel machine here.
(define wordsize 8)
(define fixnum-mask 3)
(define fixnum-shift 2)
(define fixnum-tag 0)
(define char-mask 255)
(define char-shift 8)
(define char-tag 15)
(define boolean-mask 127)
(define boolean-shift 7)
(define boolean-tag 31)
(define empty-list 47) ;; #b00101111

(define (immediate-rep x)
    (cond
     ((integer? x)
      (ash x fixnum-shift))
     ((char? x)
      (logior (ash (char->integer x) char-shift) char-tag))
     ((boolean? x)
      (logior (ash (if x 1 0) boolean-shift) boolean-tag))
     ((null? x)
      empty-list)))

(define (immediate? x)
  (or (integer? x)
      (char? x)
      (boolean? x)
      (null? x)))

(define (variable? x)
  (symbol? x))

(define (let? x)
  (and (pair? x)
       (eq? (first x) 'let)))

(define (primcall? x)
  (and (pair? x)
       (memq (first x)
             '(add1
               sub1
               integer->char
               char->integer
               zero?
               null?
               integer?
               char?
               boolean?
               + - *
               = < <= > >=
               eq? char=?))))

(define (if? x)
  (and (pair? x)
       (eq? (first x) 'if)))

(define (primcall-op x)
  (first x))

(define (primcall-operand1 x)
  (second x))

(define (primcall-operand2 x)
  (third x))

(define (lookup name env)
  (or (assq-ref env name)
      (error "unbound variable:" name)))

(define (extend-env name si env)
  (cons (cons name si) env))

(define (bindings x)
  (second x))

(define (body x)
  (third x))

(define (test x)
  (second x))

(define (consequent x)
  (third x))

(define (alternate x)
  (fourth x))

(define unique-counter (make-parameter 0))

(define (unique-label)
  (let ((n (unique-counter)))
    (unique-counter (+ n 1))
    (format #f "L~a" n)))

(define (register name)
  (format #f "%~a" name))

(define (immediate value)
  (format #f "$~a" value))

(define rax (register "rax"))
(define rsp (register "rsp"))
(define al (register "al"))

(define (offset n register)
  (format #f "~a(~a)" n register))

(define (emit template-string . args)
  (display "        ")
  (apply format #t template-string args)
  (newline))

(define (emit-mov src dest)
  (emit "mov ~a, ~a" src dest))

(define (emit-and mask dest)
  (emit "and ~a, ~a" mask dest))

(define (emit-or addend dest)
  (emit "or ~a, ~a" addend dest))

(define (emit-add addend dest)
  (emit "add ~a, ~a" addend dest))

(define (emit-sub subtrahend dest)
  (emit "sub ~a, ~a" subtrahend dest))

(define (emit-imul multiplicand dest)
  (emit "imul ~a, ~a" multiplicand dest))

(define (emit-sal n dest)
  (emit "sal ~a, ~a" n dest))

(define (emit-shr n dest)
  (emit "shr ~a, ~a" n dest))

(define (emit-cmp a b)
  (emit "cmp ~a, ~a" a b))

(define (emit-setl dest)
  (emit "setl ~a" dest))

(define (emit-setle dest)
  (emit "setle ~a" dest))

(define (emit-setg dest)
  (emit "setg ~a" dest))

(define (emit-setge dest)
  (emit "setge ~a" dest))

(define (emit-sete dest)
  (emit "sete ~a" dest))

(define (emit-je label)
  (emit "je ~a" label))

(define (emit-jmp label)
  (emit "jmp ~a" label))

(define (emit-label label)
  (format #t "~a:\n" label))

(define (emit-tag-check x mask tag si env)
  (emit-expr x si env)
  (emit-and (immediate mask) rax)
  (emit-cmp (immediate tag) rax)
  (emit-mov (immediate 0) rax)
  (emit-sete al)
  (emit-sal (immediate boolean-shift) rax)
  (emit-or (immediate boolean-tag) rax))

(define (emit-comparison x y instruction si env)
  (emit-expr y si env)
  (emit-mov rax (offset si rsp))
  (emit-expr x (- si wordsize) env)
  (emit-cmp (offset si rsp) rax)
  (emit-mov (immediate 0) rax)
  (instruction al)
  (emit-sal (immediate boolean-shift) rax)
  (emit-or (immediate boolean-tag) rax))

(define (emit-primitive-call x si env)
  (case (primcall-op x)
    ((add1)
     (emit-expr (primcall-operand1 x) si env)
     (emit-add (immediate (immediate-rep 1)) rax))
    ((sub1)
     (emit-expr (primcall-operand1 x) si env)
     (emit-sub (immediate (immediate-rep 1)) rax))
    ((integer->char)
     (emit-expr (primcall-operand1 x) si env)
     (emit-sal (immediate (- char-shift fixnum-shift)) rax)
     (emit-or (immediate char-tag) rax))
    ((char->integer)
     (emit-expr (primcall-operand1 x) si env)
     (emit-shr (immediate (- char-shift fixnum-shift)) rax))
    ((zero?)
     (emit-expr (primcall-operand1 x) si env)
     ;; Since the tag of fixnums is 0, we can skip an 'andl'
     ;; instruction that would apply the mask to the immediate
     ;; value.
     (emit-cmp (immediate 0) rax)
     (emit-mov (immediate 0) rax)
     (emit-sete al)
     (emit-sal (immediate boolean-shift) rax)
     (emit-or (immediate boolean-tag) rax))
    ((null?)
     (emit-expr (primcall-operand1 x) si env)
     (emit-cmp (immediate empty-list) rax)
     (emit-mov (immediate 0) rax)
     (emit-sete al)
     (emit-sal (immediate boolean-shift) rax)
     (emit-or (immediate boolean-tag) rax))
    ((integer?)
     (emit-tag-check (primcall-operand1 x) fixnum-mask fixnum-tag si env))
    ((char?)
     (emit-tag-check (primcall-operand1 x) char-mask char-tag si env))
    ((boolean?)
     (emit-tag-check (primcall-operand1 x) boolean-mask boolean-tag si env))
    ((+)
     (emit-expr (primcall-operand2 x) si env)
     (emit-mov rax (offset si rsp))
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit-add (offset si rsp) rax))
    ((-)
     (emit-expr (primcall-operand2 x) si env)
     (emit-mov rax (offset si rsp))
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit-sub (offset si rsp) rax))
    ((*)
     (emit-expr (primcall-operand2 x) si env)
     (emit-mov rax (offset si rsp))
     (emit-expr (primcall-operand1 x) (- si wordsize) env)
     (emit-imul (offset si rsp) rax)
     ;; When two fixnums (which have 2 tag bits) are multiplied, the
     ;; relevant bits for the result are now 4 bytes to the left, so
     ;; we have to shift back 2 bytes.
     (emit-shr (immediate fixnum-shift) rax))
    ((=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env))
    ((<)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setl si env))
    ((<=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setle si env))
    ((>)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setg si env))
    ((>=)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-setge si env))
    ((eq?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env))
    ((char=?)
     (emit-comparison (primcall-operand1 x) (primcall-operand2 x) emit-sete si env))
    (else
     (error "unknown primcall op" (primcall-op x)))))

(define (emit-let bindings body si env)
  (define (lhs b)
    (first b))
  (define (rhs b)
    (second b))
  (let loop ((b* bindings) (new-env env) (si si))
    (if (null? b*)
        (emit-expr body si new-env)
        (let ((b (first b*)))
          (emit-expr (rhs b) si env)
          (emit-mov rax (offset si rsp))
          (loop (cdr b*)
                (extend-env (lhs b) si new-env)
                (- si wordsize))))))

(define (emit-if test conseq altern si env)
  (let ((L0 (unique-label))
        (L1 (unique-label)))
    (emit-expr test si env)
    (emit-cmp (immediate (immediate-rep #f)) rax)
    (emit-je L0)
    (emit-expr conseq si env)
    (emit-jmp L1)
    (emit-label L0)
    (emit-expr altern si env)
    (emit-label L1)))

(define (emit-expr x si env)
  (cond
   ((immediate? x)
    (emit-mov (immediate (immediate-rep x)) rax))
   ((variable? x)
    (emit-mov (offset (lookup x env) rsp) rax))
   ((let? x)
    (emit-let (bindings x) (body x) si env))
   ((primcall? x)
    (emit-primitive-call x si env))
   ((if? x)
    (emit-if (test x) (consequent x) (alternate x) si env))
   (else
    (error "unknown expression" x))))

(define (compile-program x)
  (parameterize ((unique-counter 0))
    (emit-expr x (- wordsize) '())
    (emit "ret")))

(define (compile-and-run x)
  (with-output-to-file "scheme_entry.S"
    (lambda ()
      (display ".text
.p2align 4
.globl	scheme_entry
.type	scheme_entry, @function
scheme_entry:
")
      (compile-program x)))
  (and (zero? (system* "gcc" "-c" "scheme_entry.S"))
       (zero? (system* "gcc" "-c" "test.c"))
       (zero? (system* "gcc" "-o" "test" "scheme_entry.o" "test.o"))
       (let* ((pipe (open-pipe* OPEN_READ "./test"))
              (output (read-line pipe)))
         (close pipe)
         output)))

(define (test-case x expected-output)
  (let ((result (compile-and-run x)))
    (if (string=? result expected-output)
        #t
        (begin
          (display "expected: ")
          (display expected-output)
          (display ", got: ")
          (display result)
          (newline)
          #f))))

(begin
  (test-case 1 "1")
  (test-case #\b "b")
  (test-case #t "#t")
  (test-case #f "#f")
  (test-case '(add1 3) "4")
  (test-case '(sub1 3) "2")
  (test-case '(integer->char 98) "b")
  (test-case '(char->integer #\b) "98")
  (test-case '(zero? 1) "#f")
  (test-case '(zero? 0) "#t")
  (test-case '(null? 1) "#f")
  (test-case '(null? #\b) "#f")
  (test-case '(null? #t) "#f")
  (test-case '(null? #f) "#f")
  (test-case '(null? ()) "#t")
  (test-case '(integer? #\b) "#f")
  (test-case '(integer? #f) "#f")
  (test-case '(integer? 1) "#t")
  (test-case '(char? 1) "#f")
  (test-case '(char? #f) "#f")
  (test-case '(char? #\b) "#t")
  (test-case '(boolean? 1) "#f")
  (test-case '(boolean? #\b) "#f")
  (test-case '(boolean? #f) "#t")
  (test-case '(boolean? #t) "#t")
  (test-case '(+ 1 2) "3")
  (test-case '(- 3 1) "2")
  (test-case '(* 2 3) "6")
  (test-case '(= 1 2) "#f")
  (test-case '(= 1 1) "#t")
  (test-case '(< 2 1) "#f")
  (test-case '(< 1 2) "#t")
  (test-case '(<= 2 1) "#f")
  (test-case '(<= 1 2) "#t")
  (test-case '(<= 2 2) "#t")
  (test-case '(> 1 2) "#f")
  (test-case '(> 2 1) "#t")
  (test-case '(>= 1 2) "#f")
  (test-case '(>= 2 1) "#t")
  (test-case '(>= 2 2) "#t")
  (test-case '(char=? #\a #\b) "#f")
  (test-case '(char=? #\b #\b) "#t")
  (test-case '(let ((x 1)) x) "1")
  (test-case '(let ((x 1) (y 2)) (+ x y)) "3")
  (test-case '(if #t 1 2) "1")
  (test-case '(if #f 1 2) "2"))