compiler.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;This program is distributed under the terms of the       ;;;
;;;GNU General Public License.                              ;;;
;;;Copyright (C) 2011 David Joseph Stith                    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Just-In-Time Compilation ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; VAL is (environment . (formals . body))
;; (formals . body) is to be replaced with #(ASSEMBLY QUOTATION ...)
;; UNEV is (formals . body)
(let ()
  (define (check-space)
    (cmp (@ 'freedictend) edi)
    (jael 'compiler_gc))
  (define (emit-bytes . x)
    (cond
      ((pair? x)
       (movb (car x) VAL)
       (stosb)
       (apply emit-bytes (cdr x)))
      (else
       (check-space))))
  (define (emit-tetra x)
    (mov x VAL)
    (stos)
    (check-space))
  (define (emit-address x)
    (mov x VAL)
    (sub ARGL VAL)
    (sub 4 VAL)
    (stos)
    (check-space))
  (define (emit-call x)
    (emit-bytes #xe8)
    (emit-address x))
  (define (emit-deferred . x)
    (apply emit-bytes x)
    (push ARGL) ;where address will go
    (emit-tetra 0)) ;for now.  This clears VAL as well.
  (define (emit-deferred-jel)
    (emit-deferred #x0f #x84))
  (define (fix-deferred)
    (pop TEMP)
    (mov ARGL (@ TEMP)))
  (define (fix-deferred-relative)
    (pop TEMP)
    (mov ARGL (@ TEMP))
    (sub TEMP (@ TEMP))
    (sub 4 (@ TEMP)))
  (define (emit-continuation)
    (emit-deferred #x68))
  (define (emit-ret)
    (emit-bytes #xc3))
  (define (emit-jmpl x)
    (emit-bytes #xe9)
    (emit-address x))
  (define (emit-jnzl x)
    (emit-bytes #x0f #x85)
    (emit-address x))

  (define (make-set-freedict)
    (new-additional-primitive "sys-gc-lambda")
    (insure-no-more-args ARGL)
   (: 'set_freedict)
    (call 'gc_sans_strings)
    (push 'false) ;flag indicating that more room was found
    (mov (@ 'lambda_list) EXP)
   (: 'set_freedict_loop)
    (mov (@ 'lambda_list) ARGL) ;iterator
    (mov 'dictionarylimit VAL) ;candidate for neighboring lambda
    (jmp 'set_freedict_neighbor_loop_begin)
   (: 'set_freedict_neighbor_loop)
    (mov (@ 4 ARGL) ARGL)
   (: 'set_freedict_neighbor_loop_begin)
    (test ARGL ARGL)
    (ifnz
      (begin
        (cmp VAL ARGL)
        (ja 'set_freedict_neighbor_loop)
        (cmp EXP ARGL)
        (jbe 'set_freedict_neighbor_loop)
        (mov ARGL VAL)
        (jmp 'set_freedict_neighbor_loop)))
    (mov (@ EXP) TEMP) ;beginning of free space
    (sub VAL TEMP) ;negative space
    (add (@ 'freedictend) TEMP)
    (cmp (@ 'freedict) TEMP)
    (ifb
      (begin
        (mov 'true (@ esp)) ;more room was found! :-)
        (mov (@ EXP) TEMP)
        (mov TEMP (@ 'freedict))
        (mov VAL (@ 'freedictend))))
    (mov (@ 4 EXP) EXP)
    (test EXP EXP)
    (jnz 'set_freedict_loop)
    (pop VAL)
    (clear EXP ARGL)
    (ret))

  (define (make-compiler)
   (: 'compiler_gc)
    (clear VAL ARGL)
    (call 'set_freedict)
    (cmp 'false VAL)
    (jel 'error_out_of_memory)
   (: 'compiler_restart)
    (mov (@ 4 UNEV) UNEV) ;(INTEGER . root)
    (mov (@ UNEV) TEMP) ;INTEGER
    (mov (@ 4 TEMP) esp)
    (mov (@ 4 UNEV) TEMP) ;root
    (mov TEMP (@ 'root))
    (mov (@ 4 TEMP) TEMP) ;((formals . body) ...)
    (mov (@ TEMP) UNEV)
    (mov 0 (@ ENV))
    (jmp 'compiler_reentry)
   (: 'compiler) ;environment in ENV
    (save UNEV) ;(formals . body)
     (save ARGL) ;arguments
   (: 'compiler_reentry)
      (add 8 (@ 'freedict)) ;make space for length and link to next
      (make-create-data-vector)
      (save VAL) ;((ASSEMBLY) . (esp . root))
       (mov (@ 4 UNEV) EXP) ;EXP <- body
       (mov (@ UNEV) UNEV)  ;UNEV <- formals
       (mov (@ 'freedict) ARGL)
       (make-compile-argument-binders)
      (restore UNEV) ;((ASSEMBLY) . (esp . root))
      (push ARGL) ;So that we will 'return' to here
      (emit-ret) ;temporarily
     (restore ARGL)
     (clear VAL)
     (save EXP)
      (calln (@ 'freedict)) ;bind arguments
     (restore EXP) ;body
     (mov (@ ENV) ARGL) ;bound arguments
     (save ARGL)
      (mov (@ esp) ARGL) ;freedict
      (call 'compile_begin_start)
      (mov (@ 'freedict) VAL)
      (mov ARGL (@ -8 VAL))
      (mov ARGL (@ 'freedict))
      (clear VAL)
     (restore ARGL) ;bound arguments
     (mov ARGL (@ ENV)) ;prepare to redefine inner definitions
     (mov (@ UNEV) ARGL) ;(QUOTATION ... ASSEMBLY)
     (call 'reverse)
     (mov (@ VAL) ARGL) ;ASSEMBLY
     (mov (@ 4 VAL) VAL) ;(QUOTATION ...)
     (call 'list_to_vector)
     (mov VAL UNEV) ;#(QUOTATION ...)
    (restore VAL) ;(formals . body)
    (mov ARGL (@ VAL)) ;ASSEMBLY (use from now on)
    (mov UNEV (@ 4 VAL)) ;#(QUOTATION ...)
    (ret))      ;Execute body

  (define (make-create-data-vector) ;UNEV untouched, VAL <- ((ASSEMBLY) . (esp . root))
    (mov ASSEMBLY (@ FREE))
    (mov (@ 'freedict) TEMP)
    (mov TEMP (@ 4 FREE))
    (mov FREE VAL)
    (call 'advance_free)
    (mov VAL (@ FREE))
    (mov 0 (@ 4 FREE))
    (mov FREE VAL)
    (call 'advance_free) ;VAL <- (ASSEMBLY)
    (mov (object INTEGER esp) ARGL)
    (call 'advance_free)
    (mov (@ 'root) TEMP)
    (mov (object ARGL TEMP) ARGL)
    (call 'advance_free)
    (mov (object VAL ARGL) VAL)
    (call 'advance_free)
    (mov 0 (@ 'data_index)))
    
  (define (make-compile-argument-binders)
   (: 'compile_extend_loop)
    (test UNEV UNEV)
    (ifnzl
      (begin
        (emit-bytes #xc7 #x03) ;;(mov TETRA (@ FREE))
        (test 1 (@ UNEV))
        (ifz 
          (begin
            (emit-tetra (@ UNEV))
            (emit-call 'define_formal)
            (mov (@ 4 UNEV) UNEV) ;UNEV <- (cdr formals)
            (jmp 'compile_extend_loop)))
        ;;UNEV is a symbol to be bound to the rest
        (emit-tetra UNEV)
        (emit-bytes #x89 #x7b #x04) ;;(mov ARGL (@ 4 FREE))
        (emit-call 'define_extend)
        (jmp 'compile_extend_end)))
    (emit-bytes #x85 #xff) ;;(test ARGL ARGL)
    (emit-jnzl 'error_too_many_args)
   (: 'compile_extend_end))

  (define (make-compile-begin)
   (: 'compile_begin)
    (mov ARGL EXP)
    (pop ARGL) ;freedict
   (: 'compile_begin_start) ;for (begin . EXP)
    (test EXP EXP)
    (ifnz
      (begin
       (: 'compile_begin_loop)
        (test 1 EXP)
        (jnzl 'error_expected_pair)
        (cmp 0 (@ 4 EXP))
        (ifne
          (begin
            (clear VAL)
            (save-with-ignored EXP ARGL)
            (mov (@ EXP) EXP)
            (call 'compile_dispatch)
            (restore EXP)
            (mov (@ 4 EXP) EXP)
            (jmp 'compile_begin_loop)))
        (mov (@ EXP) EXP)
        (jmpl 'compile_dispatch_tail)))
    (emit-ret)
    (ret))

  (define (make-compile-lookup-variable)
   (: 'compile_lookup_variable)
    (mov 0 TEMP) ;reset outer count
    (mov ENV VAL)
   (: 'compile_variable_above_loop)
    (push (@ 4 VAL)) ;remember next level
    (mov (@ VAL) VAL)
    (and! #xffff TEMP) ;reset inner count
    (jmp 'compile_variable_inner_loop_begin)
   (: 'compile_variable_inner_loop)
    (push (@ 4 VAL)) ;remember next binding
    (mov (@ VAL) VAL)
    (cmp (@ VAL) EXP)
    (je 'compile_variable_found)
    (pop VAL)
    (add #x10000 TEMP) ;increment inner count
   (: 'compile_variable_inner_loop_begin)
    (test VAL VAL)
    (jnz 'compile_variable_inner_loop)
    (pop VAL)
    (inc TEMP) ;increment outer count
    (cmp 0 (@ 4 VAL))
    (jne 'compile_variable_above_loop)
    (push ENV)
    (mov VAL ENV)
    (call 'ev_variable)
    (pop ENV)
    (mov TEMP EXP)
    (call 'compile_inline_data)
    (ret))

  (define (make-compile-found-variable)
   (: 'compile_variable_found)
    (add 8 esp)
   (: 'compile_inner_variable_found)
    (emit-bytes #x89 #xe8) ;(mov ENV VAL)
   (: 'compile_variable_found_outer_loop)
    (test #xffff TEMP)
    (jz 'compile_variable_outer_end)
    (emit-bytes #x8b #x40 #x04) ;(mov (@ 4 VAL) VAL)
    (loop 'compile_variable_found_outer_loop)
   (: 'compile_variable_outer_end)
    (emit-bytes #x8b #x00) ;(mov (@ VAL) VAL)
    (shr 16 TEMP)
    (test TEMP TEMP)
    (jz 'compile_variable_inner_end)
    (cmp 3 TEMP)
    (jng 'compile_variable_found_inner_loop)
    (emit-bytes #xb9) ;(mov INTEGER TEMP)
    (emit-tetra TEMP)
    (emit-bytes #x8b #x40 #x04) ;(mov (@ 4 VAL) VAL)
    (emit-bytes #xe2 #xfb) ;(loop -5)
    (jmp 'compile_variable_inner_end)
   (: 'compile_variable_found_inner_loop)
    (emit-bytes #x8b #x40 #x04) ;(mov (@ 4 VAL) VAL)
    (loop 'compile_variable_found_inner_loop)
   (: 'compile_variable_inner_end)
    (emit-bytes #x8b #x00) ;(mov (@ VAL) VAL)
    (ret))

  (define (make-compile-variable)
   (: 'compile_variable)
    (call 'compile_inline_variable)
    (emit-ret)
    (ret)
   (: 'compile_inline_variable)
    (call 'compile_lookup_variable)
    (emit-bytes #x8b #x40 #x04) ;(mov (@ 4 VAL) VAL)
    (ret)
    (make-compile-lookup-variable)
    (make-compile-found-variable))

  ;freedict on stack
  ;unevaluated args in ARGL
  (define (make-compile-procedure-call)
   (: 'compile_procedure_call) ;operator in EXP
    (save EXP)
    (call 'reverse) ;VAL <- reversed unevaluated arguments
    (pop ARGL) ;freedict
    (push VAL)
    (emit-call 'initialize_args)
    (pop VAL)
    (jmp 'compile_arguments_loop_begin)
   (: 'compile_arguments_loop)
    (save-with-ignored VAL ARGL) ;rest of reversed unevaluated arguments
    (mov (@ VAL) EXP)
    (call 'compile_dispatch)
    (emit-call 'cons_arg)
    (restore VAL)
    (mov (@ 4 VAL) VAL)
   (: 'compile_arguments_loop_begin)
    (test VAL VAL)
    (jnz 'compile_arguments_loop)
    (restore EXP) ;operator
    (call 'compile_dispatch)
    ;;Now operator is in VAL, ARGL on scheme stack
    (emit-jmpl 'apply_saved_argl_to_procedure)
    (ret))

  (define (make-compile-inline-data)
   (: 'compile_inline_data) ;for (quote EXP)
    (mov EXP (@ FREE))
    (mov (@ UNEV) TEMP)
    (mov TEMP (@ 4 FREE))
    (mov FREE (@ UNEV))
    (push ARGL)
    (clear ARGL VAL)
    (call 'advance_free)
    (pop ARGL)
    (add 4 (@ 'data_index))
    (mov (@ 'data_index) TEMP)
    (emit-bytes #x8b #x04 #x35) ;;(mov (@ TETRA UNEV) VAL)
    (emit-tetra TEMP)
    (ret))

  (define (make-compile-combination)
   (: 'compile_inline_combination)
    (emit-call 'save_unev)
    (emit-continuation)
    (call 'compile_combination)
    (fix-deferred)
    (emit-call 'restore_unev)
    (ret)
   (: 'compile_combination)
    (push ARGL)
    (mov (@ 4 EXP) ARGL) ;unevaluated arguments
    (mov (@ EXP) EXP) ;operator
    (test EXP EXP)
    (jzl 'error_expected_procedure)
    (mov EXP VAL)
    (test 1 (@ EXP))
    (jz 'compile_procedure_call)
   (: 'compile_combination_dispatch)
    (cmp SYNTAX_PRIMITIVE (@ VAL))
    (jel 'compile_syntax)
    (cmp MACRO_CLOSURE (@ VAL))
    (jel 'compile_expand_macro)
    (cmpb PROCEDURE (@ VAL))
    (jel 'compile_procedure_call)
    (cmp SYMBOL (@ VAL))
    (jnel 'error_expected_procedure)
    (push ENV)
    (call 'ev_variable) 
    (pop ENV)
    (test VAL VAL)
    (jzl 'compile_procedure_call)
    (cmp SYNTAX_PRIMITIVE (@ VAL))
    (jel 'compile_syntax)
    (cmp MACRO_CLOSURE (@ VAL))
    (jel 'compile_expand_macro)
    (jmp 'compile_procedure_call))

  (define (make-compile-expand-macro) ;macro in VAL, unevaluated arguments in ARGL
   (: 'compile_expand_macro)
    (push (@ 'freedict))
    (save UNEV ENV)
    (call 'apply_compound)
    (restore ENV UNEV)
    (pop TEMP)
    (cmp (@ 'freedict) TEMP) ;Was our code overwritten?
    (jnel 'compiler_restart)
    (mov VAL EXP)
    (pop ARGL)
    (jmpl 'compile_dispatch_tail))

  (define (make-compile-syntax)
   (: 'compile_syntax) ;syntax in VAL, arguments in ARGL
    (cmp 'proc_if VAL)
    (je 'compile_if)
    (cmp 'proc_define VAL)
    (jel 'compile_define)
    (cmp 'proc_set! VAL)
    (jel 'compile_set!)
    (cmp 'proc_lambda VAL)
    (jel 'compile_lambda)
    (cmp 'proc_quote VAL)
    (jel 'compile_quote)
    (cmp 'proc_begin VAL)
    (jel 'compile_begin)
    (cmp 'proc_macro VAL)
    (jel 'compile_macro)
    (jmpl 'error_unknown_syntax)) ;should never happen.

  (define (make-compile-if)
   (: 'compile_if) ;arguments in ARGL
    (test ARGL ARGL)
    (jzl 'error_too_few_args)
    (mov (@ ARGL) EXP)
    (mov (@ 4 ARGL) ARGL)
    (test ARGL ARGL)
    (jzl 'error_too_few_args)
    (save ARGL)
    (pop ARGL) ;freedict
    (call 'compile_dispatch)
    (emit-bytes #x3d) ;(cmp 'false VAL)
    (emit-tetra 'false)
    (emit-deferred-jel)
    (mov (@ 'root) EXP)
    (mov (@ EXP) EXP)
    (mov (@ EXP) EXP)
    (call 'compile_dispatch_tail)
    (fix-deferred-relative)
    (restore EXP)
    (mov (@ 4 EXP) EXP)
    (test EXP EXP)
    (ifnz
      (begin
        (cmp 0 (@ 4 EXP))
        (jnzl 'error_too_many_args)
        (mov (@ EXP) EXP)
        (jmpl 'compile_dispatch_tail)))
    (emit-bytes #xb8) ;(mov TETRA VAL)
    (emit-tetra 'false)
    (emit-ret)
    (ret))

  (define (make-compile-define)
   (: 'compile_define)
    (call 'compile_define_set_init)
    (pop ARGL) ;freedict
    (call 'compile_dispatch)
    (restore EXP) ;symbol
    (clear TEMP)
    (mov (@ ENV) VAL)
    (jmp 'compile_define_loop_begin)
   (: 'compile_define_loop)
    (push (@ 4 VAL)) ;remember next binding
    (mov (@ VAL) VAL)
    (cmp (@ VAL) EXP)
    (ifne
      (begin
        (pop VAL)
        (add #x10000 TEMP) ;increment inner count
       (: 'compile_define_loop_begin)
        (test VAL VAL)
        (jnz 'compile_define_loop)
        (emit-bytes #xc7 #x03) ;;(mov TETRA (@ FREE))
        (emit-tetra EXP)
        (emit-bytes #x89 #x43 #x04) ;(mov VAL (@ 4 FREE))
        (emit-jmpl 'define_extend)
        (push ARGL)
        (mov EXP (@ FREE))
        (mov 0 (@ 4 FREE))
        (clear ARGL VAL)
        (call 'define_extend)
        (pop ARGL)
        (ret)))
    (add 4 esp)
    (emit-bytes #x89 #xc2) ;(mov VAL EXP)
    (call 'compile_inner_variable_found)
    (jmp 'compile_set_cdr))

  (define (make-compile-set!)
   (: 'compile_define_set_init)
    (test ARGL ARGL)
    (jzl 'error_too_few_args)
    (mov (@ 4 ARGL) EXP)
    (test EXP EXP)
    (jzl 'error_too_few_args)
    (cmp 0 (@ 4 EXP))
    (jnzl 'error_too_many_args)
    (mov (@ EXP) EXP) ;expression
    (mov (@ ARGL) VAL) ;symbol
    (save VAL)
    (ret)
   (: 'compile_set!)
    (call 'compile_define_set_init)
    (pop ARGL) ;freedict
    (call 'compile_dispatch)
    (emit-bytes #x89 #xc2) ;(mov VAL EXP)
    (restore EXP)
    (call 'compile_lookup_variable)
   (: 'compile_set_cdr)
    (emit-bytes #x89 #x50 #x04) ;(mov EXP (@ 4 VAL))
    (emit-ret)
    (ret))

  (define (make-compile-lambda)
   (: 'compile_lambda)
    (mov ARGL EXP)
    (pop ARGL) ;freedict
    (call 'compile_inline_data)
    (emit-call 'make_lambda)
    (emit-ret)
    (ret))

  (define (make-compile-macro)
   (: 'compile_macro)
    (mov ARGL EXP)
    (pop ARGL) ;freedict
    (call 'compile_inline_data)
    (emit-call 'make_macro)
    (emit-ret)
    (ret))

  (define (make-compile-quote)
   (: 'compile_quote)
    (test ARGL ARGL)
    (jzl 'error_too_few_args)
    (cmp 0 (@ 4 ARGL))
    (jnzl 'error_too_many_args)
    (mov (@ ARGL) EXP)
    (pop ARGL) ;freedict
    (test EXP EXP)
    (jz 'compile_static)
    (mov (@ EXP) TEMP)
    (test 1 TEMP)
    (ifnz
      (begin
        (test TEMP TEMP)
        (js 'compile_static)))
    (call 'compile_inline_data)
    (emit-ret)
    (ret))
    
  (define (make-compile-static)
   (: 'compile_static)
    (call 'compile_inline_static)
    (emit-ret)
    (ret)
   (: 'compile_inline_static)
    (emit-bytes #xb8) ;(mov TETRA VAL)
    (emit-tetra EXP)
    (ret))

  (define (make-compile-dispatch)
   (: 'compile_dispatch_tail)
    (test EXP EXP)
    (jz 'compile_static)
    (mov (@ EXP) TEMP)
    (cmp SYMBOL TEMP)
    (jel 'compile_variable)
    (test 1 TEMP)
    (jzl 'compile_combination)
    (test TEMP TEMP)
    (js 'compile_static)
    (call 'compile_inline_data)
    (emit-ret)
    (ret)
   (: 'compile_dispatch)
    (test EXP EXP)
    (jz 'compile_inline_static)
    (mov (@ EXP) TEMP)
    (cmp SYMBOL TEMP)
    (jel 'compile_inline_variable)
    (test 1 TEMP)
    (jzl 'compile_inline_combination)
    (test TEMP TEMP)
    (js 'compile_inline_static)
    (jmp 'compile_inline_data))

   (make-set-freedict)
   (make-compiler)
   (make-compile-begin)
   (make-compile-variable)
   (make-compile-combination)
   (make-compile-procedure-call)
   (make-compile-expand-macro)
   (make-compile-syntax)
   (make-compile-if)
   (make-compile-define)
   (make-compile-set!)
   (make-compile-lambda)
   (make-compile-macro)
   (make-compile-quote)
   (make-compile-static)
   (make-compile-dispatch)
   (make-compile-inline-data))

(: 'define_formal) ;(define (@ FREE) (@ ARGL)) when
  (test ARGL ARGL) ;(@ ARGL) is not already defined
  (jzl 'error_too_few_args)
  (mov (@ ARGL) TEMP)
  (mov (@ 4 ARGL) ARGL)
  (mov TEMP (@ 4 FREE))
(: 'define_extend)
  (mov FREE EXP)
  (add 8 FREE)
  (mov EXP (@ FREE))
  (mov (@ ENV) TEMP)
  (mov TEMP (@ 4 FREE))
  (mov FREE (@ ENV))
  (jmpl 'advance_free)

(: 'initialize_args)
  (mov 0 ARGL)
  (save ARGL)
  (ret)

(: 'cons_arg) ;saved ARGL <= (cons VAL ARGL)
  (mov (@ 'root) ARGL)
  (mov (@ ARGL) TEMP)
  (mov VAL (@ FREE))
  (mov TEMP (@ 4 FREE))
  (mov FREE (@ ARGL))
  (jmpl 'advance_free)

(: 'apply_saved_argl_to_procedure)
  (restore ARGL)
  (jmpl 'apply_dispatch)

(: 'save_unev)
  (save UNEV)
  (save ENV)
  (ret)

(: 'restore_unev)
  (restore ENV)
  (restore UNEV)
  (ret)

(: 'make_lambda)
  (mov (object ENV VAL) VAL)
  (add 8 FREE)
  (mov (object CLOSURE VAL) VAL)
  (jmpl 'advance_free)

(: 'make_macro)
  (mov (object ENV VAL) VAL)
  (add 8 FREE)
  (mov (object MACRO_CLOSURE VAL) VAL)
  (jmpl 'advance_free)