cmplr.scm

;;;; bare bones scheme compiler


(define basic-implementation-features '(bones srfi-0 srfi-7 srfi-16 srfi-46))

(define argument-register-count 0)     ; set later
(define primitives '())
(define closures-to-be-translated '())
(define literals-to-be-translated '())
(define string-literals '())
(define symbol-table '())
(define label-counter 0)
(define allocating #f)
(define emit-expr-comments #f)
(define enable-checks #f)
(define enable-pic #f)
(define verbose #f)

(define environment '())
(define locals-counter 0)
(define unused-global-variables '())
(define dropped-global-count 0)


(define (cells n) (* word-size n))
(define (bytes n) (quotient n word-size))

(define default-configuration
  (cond-expand 
    (windows 'default-windows)
    (mac 'default-mac)
    (bsd 'default-bsd)
    (else 'default-linux)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define (compile code . options)
  (set! lambda-id-counter 0)
  (set! dropped-global-count 0)
  (set! argument-register-count (sub1 (length argument-registers)))
  (set! implementation-features
    (append (collect-options 'feature: options)
	    (filter id (list target-arch target-endianness))
	    (list default-configuration)
	    basic-implementation-features))
  (set! file-search-path
    (append (collect-options 'library-path: options)
	    '(".")
	    (let ((lp (get-environment-variable "BONES_LIBRARY_PATH")))
	      (if lp (string-split lp (cond-expand (windows ";") (else ":"))) '()))
	    '("/usr/share/bones" "/usr/local/share/bones")))
  (set! verbose (option 'verbose: options))
  (let ((prg (match code
	       (('begin ('program . _))
		(expand-program (cadr code)))
	       (_ (if (option 'nostdlib: options)
		      code
		      (expand-program
		       `(program (include "base.scm") (code ,code))))))))
    (call/cc
     (lambda (return)
       (define (stop) (return #f))
       (when (option 'dump-features: options)
	 (for-each print implementation-features)
	 (stop))
       (set! enable-pic (memq 'pic implementation-features))
       (expand-syntax (generate-cond-expand implementation-features))
       (when (option 'dump-source: options)
	 (pp prg)
	 (stop))
       (NB "expanding syntax")
       (let* ((code (expand-syntax prg))
	      (_ (when (option 'expand: options) 
		   (pp code)
		   (stop)))
	      (dumpcc (option 'dump-cc: options))
	      (dumpcps (option 'dump-cps: options))
	      (dumpserial (not (option 'dump-nested: options)))
	      (outfile (option 'output-file: options))
	      (_ (NB "canonicalizing"))
	      (code (canonicalize-expression code))
	      (_ (NB "converting to CPS"))
	      (defs code (cps code))
	      (_ (when dumpcps
		   (dump-expressions code dumpserial)
		   (stop)))
	      (_ (NB "propagating constants"))
	      (code (cp code))
	      (_ (NB "detecting unused variables"))
	      (code unused (detect-unused-variables code))
	      (_ (NB "simplification"))
	      (code (simplify code))
	      (_ (cond ((option 'dump-simplified: options)
			(dump-expressions code dumpserial)
			(stop))
		       ((option 'dump-unused: options)
			(for-each 
			 (lambda (var) (write var) (newline))
			 unused)
			(stop))
		       ((option 'dump: options)
			(dump-expressions code dumpserial)
			(stop))))
	      (_ (NB "converting closures"))
	      (ccode (cc code '())))
	 (set! emit-expr-comments (option 'comment: options))
	 (set! enable-checks (memq 'check implementation-features))
	 (when dumpcc
	   (dump-expressions ccode dumpserial)
	   (stop))
	 ;;XXX add pass that assigns closure-id's to target variables, for adding comments in
	 ;;    generated output.
	 (NB "generating code")
	 ((if outfile
	      (lambda (thunk)
		(with-output-to-file outfile thunk))
	      (lambda (thunk) (thunk)))
	  (cut generate-code defs ccode unused))
	 (NB "  dropped " dropped-global-count " global assignments"))))))

(define (compile-file fname . options)
  (apply compile (read-forms fname) options))

(define (NB . args)
  (when verbose
    (let ((out (current-error-port)))
      (for-each (cut display <> out) args)
      (newline out))))


(define (generate-code defs code unused)
  (set! label-counter 0)
  (generate-header (map mangle-feature-name implementation-features))
  (set! literals-to-be-translated '())
  (set! primitives '())
  (set! unused-global-variables unused)
  (generate-closures code)
  (generate-globals defs)
  (generate-literals)
  (generate-primitives)
  (generate-trailer))

(define (generate-globals defs)
  (generate-section ".data")
  (generate-label "globals")
  (for-each 
   (lambda (def)
     (generate-label (mangle-identifier def))
     (generate-defword "undefined"))
   defs)
  (generate-label "endglobals"))

(define (generate-closures top)
  (set! closures-to-be-translated (list top))
  (generate-section ".text")
  (generate-label "toplevel")
  (do ()
      ((null? closures-to-be-translated))
    (translate-closure (pop! closures-to-be-translated))))

(define (generate-literals)
  (set! string-literals '())
  (set! symbol-table '())
  (generate-section ".data")
  (do ()
      ((null? literals-to-be-translated))
    (match-let (((l . c) (pop! literals-to-be-translated)))
      (translate-literal l c)))
  (generate-strings)
  (generate-symbol-table))

(define (typecode type len)
  (bitwise-ior
   (arithmetic-shift
    (case type
      ((NULL) 0)
      ((SYMBOL) 1)
      ((PAIR) 2)
      ((VECTOR) 3)
      ((CHAR) 4)
      ((EOF) 5)
      ((VOID) 6)
      ((BOOLEAN) 7)
      ((PORT) 8)
      ((PROMISE) 9)
      ((RECORD) 10)
      ((FLONUM) #x10)
      ((STRING) #x11)
      ((BYTEVECTOR) #x12)
      ((CLOSURE) #x20)
      (else (error "invalid type" type)))
    56)
   len))

(define (generate-strings)
  (generate-section ".data")
  (for-each
   (match-lambda
     ((l . str)
      (generate-align word-size)
      (generate-label l)
      (generate-defword (typecode 'STRING (string-length str)))
      (when (positive? (string-length str))
	(generate-defstring str))))
   string-literals))

(define (generate-symbol-table)
  (generate-section ".data")
  (generate-label "symbol_literals")
  (for-each
   (lambda (l)
     (generate-defword (cdr l)))
   symbol-table)
  (generate-defword "false"))

(define (fixnum? n)
  (and (number? n) (exact? n) (<= (car fixnum-range) n (cdr fixnum-range))))

(define (register-literal c)
  (let ((l1 (label)))
    (push! (cons l1 c) literals-to-be-translated)
    l1))

(define (label)
  (string-append "L" (number->string (inc! label-counter))))

(define (translate-inline-arguments args)
  (translate/registers args temporary-registers))

(define (translate x t)
  ;;(pp (if (pair? x) (car x) x))
  (when emit-expr-comments
    (generate-expr-comment (fragment x 4)))
  (match x
    (('$closure id cap . _)
     (push! x closures-to-be-translated)
     (set! allocating #t)
     (generate-closure-alloc (length cap) id)
     (do ((lst cap (cdr lst))
	  (off 2 (add1 off)))
	 ((null? lst))
       (translate-store
	(car lst)
	(lambda (reg)
	  (generate-slot-store alloc-register (cells off) reg))))
     (generate-move t alloc-register)
     (generate-add alloc-register (cells (+ 2 (length cap))))
     #t)
    (('let ((vars vals) ...) body)
     (fluid-let ((environment environment)
		 (locals-counter locals-counter)
		 (available-registers available-registers))
       (let ((newenv environment))
	 (for-each
	  (lambda (var val)
	    (cond ((eq? var '$unused)
		   ;; just evaluate but don't bind - must be non-trivial or it would already
		   ;; have been removed
		   (translate val arg-register))
		  ((null? available-registers)
		   ;; evaluate and move into local
		   (translate-store
		    val
		    (lambda (reg)
		      (generate-comment var " = local #" locals-counter)
		      (generate-move-to-local (cells locals-counter) reg)))
		   (push! (cons var locals-counter) newenv)
		   (inc! locals-counter))
		  (else
		   ;; evaluate into target register
		   ;;XXX could eval directly into reg, if reg is not used in the val
		   (let ((reg (car available-registers)))
		     (translate-store
		      val
		      (lambda (reg2)
			(generate-comment var " = " reg)
			(generate-move reg reg2)))
		     (push! (cons var reg) newenv)
		     (pop! available-registers)))))
	  vars vals)
	 (set! environment newenv)
	 (translate body t))))
    (('$global-set! var val)
     (cond ((memq var unused-global-variables)
	    ;; either drop assignment entirely or just evaluate "val"
	    (cond ((pure-expression? val)
		   (inc! dropped-global-count)
		   (generate-immediate-ref t "undefined" "dropped: " var))
		  (else (translate val t))))
	   (else
	    (translate val t)
	    (generate-global-store var (mangle-identifier var) t)))
     #t)
    (('$global-ref var)
     (generate-global-ref t var (mangle-identifier var))
     #t)
    (('$local-ref var)
     (let ((ref (lookup-variable var)))
       (if (symbol? ref)
	   (generate-move t ref)
	   (generate-local-ref t var (cells ref))))
     #t)
    (('$local-set! var val)
     (translate val t)
     (let ((ref (lookup-variable var)))
       (if (symbol? ref)
	   (generate-move ref t)
	   (generate-local-store var (cells ref) t)))
     #t)
    (('if ('$inline-test code cnd args ...) y z)
     (assert (<= (length args) (length temporary-registers)) 
	     "too many arguments to `$inline-test'" args)
     (unless (null? args)
       (translate-inline-arguments args))
     (for-each
      generate-instruction
      (string-split code ";"))
     (cond ((and (simple-expression? y)
		 (simple-expression? z))
	    (match-let (((r1 r2) (translate-inline-arguments (list y z))))
	      (cond ((memq t temporary-registers)
		     (generate-conditional-move/cond cnd r1 r2)
		     (generate-move t r2))
		    (else
		     (generate-move t r2)
		     (generate-conditional-move/cond cnd r1 t)))
	      #t))
	   (else
	    (let ((l1 (label))
		  (l2 (label)))
	      (generate-conditional-branch/cond cnd t l1)
	      (when (translate y t) ; ret-flag must be the same for both branches
		(generate-jump l2))
	      (generate-label l1)
	      (let ((ret (translate z t)))
		(generate-label l2)
		ret)))))
    (('if x y z)
     (cond ((and (simple-expression? y)
		 (simple-expression? z))
	    (match-let (((r1 r2 r3) (translate-inline-arguments (list x y z))))
	      (cond ((memq t temporary-registers)
		     (generate-conditional-move r1 r3 r2)
		     (generate-move t r2))
		    (else
		     (generate-move t r2)
		     (generate-conditional-move r1 r3 t)))
	      #t))
	   (else
	    (translate x t)
	    (let ((l1 (label))
		  (l2 (label)))
	      (generate-conditional-branch t l1)
	      (when (translate y t) ; ret-flag must be the same for both branches
		(generate-jump l2))
	      (generate-label l1)
	      (let ((ret (translate z t)))
		(generate-label l2)
		ret)))))
    (('$primitive (or ('quote name) name))
     (let ((l1 (label)))
       (push! (cons l1 name) primitives)
       (generate-immediate-ref t l1 name)
       #t))
    (('$box val)
     (translate-store
      val
      (lambda (reg)
	(generate-slot-store alloc-register (cells 1) reg)))
     (generate-immediate-ref t "VECTOR | 1")
     (generate-slot-store alloc-register 0 t)
     (generate-move t alloc-register)
     (generate-add alloc-register (cells 2))
     #t)
    (('$box-ref val)
     (translate val t)
     (generate-slot-ref t t (cells 1))
     #t)
    (('$box-set! box val)
     (match-let (((r1 r2) (translate-inline-arguments (list box val))))
       (generate-slot-store r1 (cells 1) r2)
       (generate-move t r2)
       #t))
    (('$inline (or ('quote opr) opr) args ...)
     (assert (<= (length args) (length temporary-registers)) 
	     "too many arguments to `$inline'" args)
     (unless (null? args)
       (translate-inline-arguments args))
     (for-each
      generate-instruction
      (string-split opr ";"))
     (generate-move t arg-register)
     #t)
    (('$inline-test (or ('quote opr) opr) (or ('quote cnd) cnd) args ...)
     (assert (<= (length args) (length temporary-registers)) 
	     "too many arguments to `$inline-test'" args)
     (unless (null? args)
       (translate-inline-arguments args))
     (for-each
      generate-instruction
      (string-split opr ";"))
     (generate-conditional-set cnd t)
     #t)
    (('$allocate (or ('quote type) type) (or ('quote size) size) args ...)
     (assert (<= (length args) (length temporary-registers))
	     "too many arguments to `$allocate'" args)
     (let ((regs (translate-inline-arguments args))
	   (bytevec (not (zero? (bitwise-and type #x10)))))
       (set! allocating #t)
       (unless (zero? (bitwise-and type #x10))
	 (generate-alloc-alignment))
       (do ((regs regs (cdr regs))
	    (off 1 (add1 off)))
	   ((null? regs))
	 (generate-slot-store alloc-register (cells off) (car regs)))
       (generate-immediate-ref
	t
	(bitwise-ior (arithmetic-shift type (* (sub1 word-size) 8)) size)
	type "/" size)
       (generate-slot-store alloc-register 0 t)
       (generate-move t alloc-register)
       (generate-add 
	alloc-register
	(if bytevec
	    (string-append (number->string (cells 1)) " + ALIGNED(" (number->string size) ")")
	    (string-append (number->string (cells (add1 size))))))
       #t))
    (((or '$undefined '$uninitialized))
     (generate-immediate-ref t "undefined")
     #t)
    (('$closure-ref i)
     (generate-slot-ref t self-register (cells (+ i 2)))
     #t)
    (('quote c)
     (cond ((fixnum? c)
	    (generate-immediate-ref t (encode-fixnum c) "'" c))
	   ((eq? #t c)
	    (generate-true-ref t))
	   ((eq? #f c)
	    (generate-move t false-register))
	   ((null? c)
	    (generate-immediate-ref t "null"))
	   (else
	    (let ((l1 (register-literal c)))
	      (generate-immediate-ref t l1))))
     #t)
    (('$call id args ...)
     (translate-call-to-known-target id args)
     #f)
    ((op args ...)
     (translate-call x)
     #f)
    (_ (error "COMPILE: invalid expression" x))))


;; translate store operation on expression, possibly avoiding intermediate
;; register
(define (translate-store exp k)
  (let ((reg (cond ((trivial-register-expression? exp) => id)
		   (else
		    (translate exp arg-register)
		    arg-register))))
    (k reg)))


(define (translate-call x)
  (let ((n (length x)))
    (translate/registers x argument-registers)
    (when enable-checks
      (generate-procedure-check))
    (generate-slot-ref arg-register self-register (cells 1))
    (generate-immediate-ref count-register n)
    (cond (allocating
	   (generate-alloc-check)
	   (generate-tail-call arg-register))
	  (else
	   (generate-tail-call arg-register)))))

(define (translate-call-to-known-target id x)
  (let ((n (length x))
	(lbl (string-append "f_" (number->string id))))
    (translate/registers x argument-registers)
    (cond (allocating
	   (generate-slot-ref arg-register self-register (cells 1))
	   (generate-immediate-ref count-register n)
	   (generate-alloc-check)
	   (generate-direct-tail-call lbl))
	  (else
	   (generate-immediate-ref count-register n)
	   (generate-direct-tail-call lbl)))))

(define (translate-closure exp)
  (match exp
    (('$closure id cap (llists bodies) ...)
     (generate-label (string-append "f_" (number->string id)))
     (do ((i 0 (add1 i))
	  (llists llists (cdr llists))
	  (bodies bodies (cdr bodies)))
	 ((null? llists))
       (let ((vars argc rest (parse-lambda-list (car llists)))
	     (next (string-append "f_c_" (number->string id) "_" (number->string (add1 i)))))
	 (when (or (not rest) (positive? argc)) ; single rest arg doesn't need to be checked
	   (if (null? (cdr llists))
	       (when enable-checks
		 (generate-argc-check (add1 argc) rest next))
	       (generate-argc-check (add1 argc) rest next)))
	 (translate-llist (car llists))
	 (set! allocating #f)
	 (translate (car bodies) arg-register)
	 (if (null? (cdr llists))
	     (when enable-checks
	       (generate-label next)
	       (generate-instruction "CHECK_ARGC_FAILED"))
	     (generate-label next)))))))

(define (translate-llist llist)
  (set! available-registers (cdr argument-registers))
  (set! locals-counter 0)
  (set! environment '())
  (let ((vars argc rest (parse-lambda-list llist))
	(unused '()))
    (for-each
     (lambda (var)
       (cond ((null? available-registers)
	      (unless (eq? var '$unused)
		(push! (cons var locals-counter) environment)
		(inc! locals-counter)))
	     ((eq? var '$unused)
	      ;; this register is not used for arguments but may be later used in "let" bindings
	      (push! (pop! available-registers) unused))
	     (else
	      (let ((reg (pop! available-registers)))
		(push! (cons var reg) environment)))))
     vars)
    ;; add unused argument registers back to available registers
    (set! available-registers (append unused available-registers))
    (generate-comment environment)
    (when (and rest (not (eq? '$unused rest)))
      (let ((rdest (cdr (assq rest environment))))
	(generate-immediate-ref arg-register (add1 argc))
	(generate-call "consrest")
	(if (symbol? rdest)
	    (generate-move rdest arg-register)
	    (generate-move-to-local (cells rdest) arg-register))))))

(define (translate-literal l c)
  (cond ((fixnum? c) (generate-equ l "(" c " << 1) | 1"))
	((number? c)
	 (cond ((= word-size 4)
		(generate-align 4)
		(generate-padding 4))
	       (else (generate-align word-size))) ; assumes word-size == 8
	 (generate-label l)
	 (generate-defword (typecode 'FLONUM (cells 1)))
	 (cond ((nan? c) (generate-defword "0x7ff0000000000001"))
	       ((not (finite? c))
		(generate-defword
		 (if (positive? c)
		     "0x7ff0000000000000"
		     "0xfff0000000000000")))
	       (else (generate-deffloat (exact->inexact c)))))
	((pair? c)
	 (let ((lcar (register-literal (car c)))
	       (lcdr (register-literal (cdr c))))
	   (generate-align word-size)
	   (generate-label l)
	   (for-each generate-defword (list (typecode 'PAIR 2) lcar lcdr))))
	((vector? c)
	 (let ((ls (map register-literal (vector->list c))))
	   (generate-align word-size)
	   (generate-label l)
	   (generate-defword (typecode 'VECTOR (length ls)))
	   (for-each generate-defword ls)))
	((bytevector? c)
	 (generate-align word-size)
	 (generate-label l)
	 (let* ((len (bytevector-length c))
		(str (make-string len)))
	   (do ((i 0 (add1 i)))
	       ((>= i len))
	     (string-set! str i (bytevector-u8-ref c i)))
	   (generate-defword (typecode 'BYTEVECTOR len))
	   (generate-defstring str)))
	((string? c)
	 (push! (cons l c) string-literals))
	((symbol? c)
	 (cond ((assq c symbol-table) =>
		(match-lambda 
		  ((_ . l2) (generate-equ l l2))))
	       (else
		(let ((l1 (register-literal (symbol->string c))))
		  (push! (cons c l) symbol-table)
		  (generate-align word-size)
		  (generate-label l)
		  (generate-defword (typecode 'SYMBOL 1))
		  (generate-defword l1)))))
	((char? c)
	 (generate-align word-size)
	 (generate-label l)
	 (generate-defword (typecode 'CHAR 1))
	 (generate-defword (encode-fixnum (char->integer c))))
	((null? c)
	 (generate-equ l "null"))
	((eq? c #t)
	 (generate-equ l "true"))
	((eq? c #f)
	 (generate-equ l "false"))
	(else (error "bad literal" c))))

(define (encode-fixnum n)
  (bitwise-ior (arithmetic-shift n 1) 1))

(define (lookup-variable var)
  (cond ((assq var environment) =>
	 (match-lambda 
	   ((_ . r) r)))
	(else (error "unknown local variable" var))))