r1/compile.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 223 646d45b098aa
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.

;; Compile AST to a set of prototype methods and blocks.

(define-record-type compilation-state
  (make-compilation-state* next-literal rev-literals)
  compilation-state?
  (next-literal compilation-state-next-literal)
  (rev-literals compilation-state-rev-literals))

(define (make-compilation-state)
  (make-compilation-state* 0 '()))

(define (push-literal state val)
  (let ((i (compilation-state-next-literal state)))
    (values i
	    (make-compilation-state* (+ i 1)
				     (cons val (compilation-state-rev-literals state))))))

(define (finish-compilation-state state)
  (list->vector (reverse (compilation-state-rev-literals state))))

(define *all-method-code-prologues* '())
(define *invocation-count-decay-half-life* 15) ;; seconds
(define *invocation-count-update-interval* 4) ;; seconds
(define *recompilation-count-limit* 1000)

(define (instruction->code instr is-closure)
  (let ((prologue (vector 0 (if is-closure *true* *false*))))
    (let ((locative (make-weak-locative prologue 0)))
      (push! *all-method-code-prologues* locative))
    (cons prologue instr)))

(define (invocation-count-decay-constant)
  (exp (/ (log 2)
	  (/ *invocation-count-decay-half-life* *invocation-count-update-interval*))))

(define (decay-invocation-counts!)
  (debug 0 "Decaying invocation counts...")
  (let ((decay-constant (invocation-count-decay-constant)))
    (set! *all-method-code-prologues*
	  (filter! (lambda (locative)
		     (let ((prologue (locative->object locative)))
		       (if prologue
			   (vector-set! prologue 0 (/ (vector-ref prologue 0) decay-constant)))
		       prologue))
		   *all-method-code-prologues*))))

(define (bump-invocation-count! prologue method)
  (let ((invocation-count (+ (vector-ref prologue 0) 1)))
    (vector-set! prologue 0 invocation-count)
    (if (>= invocation-count *recompilation-count-limit*)
	(begin
	  (vector-set! prologue 0 0)
	  (recompile-method! method)))))

(define compile-ThiNG
  (let ()
    (define (do-ref cenv state name)
      (let* ((name (string->symbol name)))
	(values (cond ((memq name cenv) `#(local ,name))
		      (else `#(global ,name)))
		state)))

    (define (compile-tuple cenv state exprs)
      (let loop ((exprs exprs)
		 (state state)
		 (acc '()))
	(if (null? exprs)
	    (values (list->vector (reverse acc)) state)
	    (let*-values (((instr state) (compile cenv state (car exprs))))
	      (loop (cdr exprs)
		    state
		    (cons instr acc))))))

    (define (do-send cenv state selector exprs)
      (let-values (((selector) (string->symbol selector))
		   ((instrs state) (compile-tuple cenv state exprs)))
	(values `#(send ,selector ,instrs)
		state)))

    (define (do-block cenv state binders statements)
      (let* ((block (clone-object *block*))
	     (num-formals (length binders))
	     (formals (map string->symbol binders))
	     (formal-cenv (append (cons '_ formals) cenv))
	     (selector (if (zero? num-formals)
			   'do
			   (string->symbol
			    (string-concatenate (cons "applyWith:"
						      (make-list (- num-formals 1) "with:")))))))
	(let*-values (((instr block-state)
		       (compile formal-cenv (make-compilation-state)
				`(scope ,*nil* ,statements)))
		      ((litvec) (finish-compilation-state block-state))
		      ((method) (define-method! selector (cons '_ formals) (list block)
				  (instruction->code instr #t)))
		      ((block-index state) (push-literal state block)))
	  (set-slot! method 'literals litvec)
	  (values `#(closure ,block-index)
		  state))))

    (define (do-scope cenv state name statements)
      (if (eq? *nil* name)
	  (let-values (((instrs state) (compile-statements cenv state statements)))
	    (values `#(begin ,instrs)
		    state))
	  (let*-values (((name) (string->symbol name))
			((instrs state) (compile-statements (cons name cenv) state statements)))
	    (values `#(scope ,name ,instrs)
		    state))))

    (define (do-literal cenv state val)
      (let-values (((index state) (push-literal state val)))
	(values `#(literal ,index)
		state)))

    (define (do-update cenv state template-expr updates)
      (let*-values (((template-instr state) (compile cenv state template-expr))
		    ((updates state)
		     (let loop ((updates updates)
				(state state)
				(acc '()))
		       (if (null? updates)
			   (values (list->vector (reverse acc)) state)
			   (let*-values (((update) (car updates))
					 ((update-instr state)
					  (compile cenv state (caddr update))))
			     (loop (cdr updates)
				   state
				   (cons (vector (car update)
						 (string->symbol (cadr update))
						 update-instr)
					 acc)))))))
	(values `#(update ,template-instr ,updates)
		state)))

    (define (do-tuple cenv state exprs)
      (let-values (((instrs state) (compile-tuple cenv state exprs)))
	(values `#(tuple ,instrs)
		state)))

    (define (do-resend cenv state)
      (values `#(resend)
	      state))

    (define (do-method cenv state pattern statements)
      (let* ((selector (string->symbol (cadr pattern)))
	     (params (caddr pattern))
	     (formals (map (lambda (entry) (string->symbol (or (non-*false*? (car entry))
							       "_")))
			   params)))
	(let*-values (((specializer-instrs state)
		       (compile-tuple cenv state (map (lambda (entry)
							(let ((exp (cadr entry)))
							  (if (non-*false*? exp)
							      exp
							      `(ref "NoRole"))))
						      params)))
		      ((body-instr method-state)
		       (compile formals (make-compilation-state) `(scope ,*nil* ,statements)))
		      ((method-litvec) (finish-compilation-state method-state)))
	  (values `#(method ,selector ,formals ,specializer-instrs
			    ,(instruction->code body-instr #f)
			    ,method-litvec)
		  state))))

    (define (compile-statement cenv state statement)
      (if (and (pair? statement)
	       (eq? (car statement) 'let))
	  (let* ((name (string->symbol (cadr statement)))
		 (expr (caddr statement))
		 (newenv (cons name cenv)))
	    (let-values (((instr state) (compile newenv state expr)))
	      (values `#(bind ,name ,instr)
		      newenv
		      state)))
	  (let-values (((instr state) (compile cenv state statement)))
	    (values instr cenv state))))

    (define (compile-statements cenv state statements)
      (let loop ((cenv cenv)
		 (state state)
		 (statements statements)
		 (acc '()))
	(if (null? statements)
	    (values (list->vector (reverse acc))
		    state)
	    (let-values (((instr cenv state) (compile-statement cenv state (car statements))))
	      (loop cenv
		    state
		    (cdr statements)
		    (cons instr acc))))))

    (define (compile cenv state ast)
      (debug 1 "compile "ast" "cenv)
      (cond
       ((pair? ast)
	(apply (cond
		((assq (car ast) `((ref ,do-ref)
				   (send ,do-send)
				   (block ,do-block)
				   (scope ,do-scope)
				   (string ,do-literal)
				   (symbol ,do-literal)
				   (number ,do-literal)
				   (update ,do-update)
				   (tuple ,do-tuple)
				   (resend ,do-resend)
				   (method ,do-method)
				   )) => cadr)
		(else (error "Unknown ast kind" ast)))
	       cenv state
	       (cdr ast)))
       (else (error "Non-pair ast" ast))))

    (lambda (ast)
      (let-values (((instr state) (compile '() (make-compilation-state) ast)))
	(values instr
		(finish-compilation-state state))))))

(define (instruction-vector-size seed instr-vec)
  (vector-fold (lambda (instr acc) (+ (instruction-size instr) acc)) seed instr-vec))

(define (instruction-size instr)
  (case (vector-ref instr 0)
    ((local global closure literal resend) 1)
    ((send) (instruction-vector-size 1 (vector-ref instr 2)))
    ((begin) (instruction-vector-size 0 (vector-ref instr 1)))
    ((scope) (instruction-vector-size 0 (vector-ref instr 2)))
    ((update) (instruction-vector-size 1 (vector-ref instr 2)))
    ((tuple) (instruction-vector-size 1 (vector-ref instr 1)))
    ((method) 1) ;; not quite correct, but mneh. until the macro is expanded properly, will do.
    (else (error "Illegal instruction in instruction-size" instr))))

(define (recompile-method! method)
  (let ((instr (cdr (get-slot method 'code))))
    (pretty-print `(recompile-method!
		    (size ,(instruction-size instr))
		    (instr ,instr)))))