;; Evaluator backend, useful for macro execution. Takes the output of
;; the "annotate" phase (a lambda term, in the cps2-value language).

(define (core-scheme-eval sexp)
  (when (debug-mode=? 'coreeval)
    (pretty-print `(core-scheme-eval ',(if (node? sexp)
					   (vector "NODE"
						   (node->list sexp))
					   sexp))))
  (let* ((cps2 (compiler-front-end-phases sexp))
	 (thunk (cps2->closure cps2))
	 (result ((thunk '#() '#()))))
    (when (debug-mode=? 'coreeval)
      (pretty-print `("core-scheme-eval-result" ,result)))
    result))

(define-record-type core-scheme-cell
  (make-core-scheme-cell name value)
  core-scheme-cell?
  (name core-scheme-cell-name)
  (value core-scheme-cell-value set-core-scheme-cell-value!))

(define *globals* (make-hash-table))

(defmacro debug-pretty-print (exp)
  `(begin (when (debug-mode=? 'coreeval-pp) (pretty-print ,exp)) 'debug-pretty-print-result)
  ;;`(begin 'debug-pretty-print-result)
  )

(define ($define-global-variable name value)
  (debug-pretty-print `($define-global-variable ,name ,value))
  (hash-table-put! *globals* name value))

(define *coreeval-magic* (cons "coreeval" "magic"))

(define (coreeval$apply magic args)
  (if (eq? magic *coreeval-magic*)
      (let ((k (car args))
	    (fn (cadr args))
	    (args (cddr args)))
	(k *coreeval-magic* (list (apply apply fn args))))
      ;; Now, we probably could do something sensible here, I'm just
      ;; too lazy at present to figure out what that thing might be.
      (error "Expected magic in coreeval$apply")))

(define (cps2->closure node)
  (define (make-accessor generate-box-loads name location)
    (node-match location
      ((@loc-local source index)
       (case source
	 ((argument)
	  (if (and generate-box-loads (@loc-local-boxed? location))
	      (lambda (args env)
		(debug-pretty-print `(load.ab ,name))
		(core-scheme-cell-value (vector-ref args index)))
	      (lambda (args env)
		(debug-pretty-print `(load.a ,name))
		(vector-ref args index))))
	 ((environment)
	  (if (and generate-box-loads (@loc-local-boxed? location))
	      (lambda (args env)
		(debug-pretty-print `(load.eb ,name))
		(core-scheme-cell-value (vector-ref env index)))
	      (lambda (args env)
		(debug-pretty-print `(load.e ,name))
		(vector-ref env index))))))
      ((@loc-global)
       (lambda (args env)
	 (debug-pretty-print `(load.g ,name))
	 (cache-global name)))))
  (define (make-mutator generate-box-stores name location value-closure)
    (node-match location
      ((@loc-local source index)
       (case source
	 ((argument)
	  (if (and generate-box-stores (@loc-local-boxed? location))
	      (lambda (args env)
		(debug-pretty-print `(store.ab ,name))
		(set-core-scheme-cell-value! (vector-ref args index)
					     (value-closure args env)))
	      (lambda (args env)
		(debug-pretty-print `(store.a ,name))
		(vector-set! args index (value-closure args env)))))
	 ((environment)
	  (if (and generate-box-stores (@loc-local-boxed? location))
	      (lambda (args env)
		(debug-pretty-print `(store.eb ,name))
		(set-core-scheme-cell-value! (vector-ref env index)
					     (value-closure args env)))
	      (lambda (args env)
		(debug-pretty-print `(store.e ,name))
		(vector-set! env index (value-closure args env)))))))
      ((@loc-global)
       (lambda (args env)
	 (debug-pretty-print `(store.g ,name))
	 (hash-table-put! *globals* name (value-closure args env))))))
  (define (magic-wrapper proc)
    (lambda actuals
      (debug-pretty-print `(magic-wrapper ,proc ,actuals))
      (if (or (null? actuals)
	      (not (eq? (car actuals) *coreeval-magic*)))
	  (let ((wrapping-outer-k (lambda (dummy-magic-variable actuals) (car actuals))))
	    (proc (cons wrapping-outer-k actuals)))
	  (proc (cadr actuals)))))
  (define (magic-k-wrapper proc)
    (lambda actuals
      (debug-pretty-print `(magic-k-wrapper ,proc ,actuals))
      (if (or (null? actuals)
	      (not (eq? (car actuals) *coreeval-magic*)))
	  (proc actuals)
	  (proc (cadr actuals)))))
  (define (magic-unwrapper name proc)
    (lambda actuals
      (debug-pretty-print `(magic-unwrapper ,name ,actuals))
      (if (or (null? actuals)
	      (not (eq? (car actuals) *coreeval-magic*)))
	  (apply proc actuals)
	  (let ((v (apply proc (cdr (cadr actuals)))))
	    (debug-pretty-print `(unwrapper-value ,v))
	    ((car (cadr actuals)) *coreeval-magic* (list v))))))
  (define (maybe-unwrap name value)
    (if (procedure? value)
	(magic-unwrapper name value)
	value))
  (define (cache-global name) ;; %%% needs fixing properly
    (hash-table-get *globals* name
		    (lambda ()
		      (let* ((orig-value (eval name))
			     (value (maybe-unwrap name orig-value)))
			(hash-table-put! *globals* name value)
			value))))
  (define (evaluate-chain args env chain)
    (for-each (lambda (entry) (entry args env)) chain))
  (let walk ((node node))
    (define (make-seq head tail)
      (let ((head-closure (walk head))
	    (tail-closure (walk tail)))
	(lambda (args env)
	  (head-closure args env)
	  (tail-closure args env))))
    (define (make-if test true false)
      (let ((test-closure (walk test))
	    (true-closure (walk true))
	    (false-closure (walk false)))
	(lambda (args env)
	  (let ((test-result (test-closure args env)))
	    (debug-pretty-print `(if ,test-result))
	    (if test-result
		(true-closure args env)
		(false-closure args env))))))
    ;;(debug-pretty-print `(COMPILING ,(node->list node)))
    (node-match node
      ((@cps2-lit value) (lambda (args env)
			   (debug-pretty-print `(lit ,value))
			   value))
      ((@cps2-void) (lambda (args env)
		      (debug-pretty-print `(void))
		      '<void>))
      ((@cps2-get name location) (make-accessor #t name location))
      ((@cps2-lambda is-continuation formals varargs expr captures globals)
       (let* ((body-closure (walk expr))
	      (num-formals (length formals))
	      (num-non-rest-formals (- (length formals) 1))
	      (num-captures (length captures))
	      (boxing-actions
	       (filter-map (lambda (location)
			     (and (@loc-local-boxed? location)
				  (let ((name (@arginfo-name (@loc-local-arginfo location))))
				    (make-mutator #f
						  name
						  location
						  (lambda (args env)
						    (make-core-scheme-cell
						     name
						     ((make-accessor #f name location)
						      args env)))))))
			   formals))
	      (capture-actions
	       (map (lambda (capture)
		      (let* ((arginfo (@capture-arginfo capture))
			     (name (@arginfo-name arginfo))
			     (old-loc (@capture-old-location capture))
			     (new-loc (@capture-new-location capture))
			     (new-index (@loc-local-index new-loc))
			     (get (make-accessor #f name old-loc)))
			(lambda (args oldenv newenv)
			  (debug-pretty-print `(capture ,name))
			  (vector-set! newenv new-index (get args oldenv)))))
		    captures)))
	 (if varargs
	     (lambda (oldargs oldenv)
	       (debug-pretty-print `(va-lambda ,oldargs ,oldenv ,num-formals ,num-captures))
	       (let ((env (make-vector num-captures 'uninitialized)))
		 (for-each (lambda (action) (action oldargs oldenv env)) capture-actions)
		 ((if is-continuation magic-k-wrapper magic-wrapper)
		  (lambda (actuals)
		    (debug-pretty-print `(va-app ,@actuals))
		    (let ((args (make-vector num-formals 'bug)))
		      (do ((i 0 (+ i 1))
			   (actuals actuals (cdr actuals)))
			  ((= i num-non-rest-formals)
			   (vector-set! args i actuals))
			(vector-set! args i (car actuals)))
		      (evaluate-chain args env boxing-actions)
		      (body-closure args env))))))
	     (lambda (oldargs oldenv)
	       (debug-pretty-print `(lambda ,oldargs ,oldenv ,num-formals ,num-captures))
	       (let ((env (make-vector num-captures 'uninitialized)))
		 (for-each (lambda (action) (action oldargs oldenv env)) capture-actions)
		 ((if is-continuation magic-k-wrapper magic-wrapper)
		  (lambda (actuals)
		    (debug-pretty-print `(app ,@actuals))
		    (let ((args (list->vector actuals)))
		      (evaluate-chain args env boxing-actions)
		      (body-closure args env)))))))))
      ((@cps2-asm formals actuals code)
       (cond
	((find (lambda (clause) (eq? 'scheme (@backend-asm-name clause))) code)
	 => (lambda (clause)
	      (let* ((code-expr `(lambda ,formals ,@(@backend-asm-code clause)))
		     (code-proc (eval code-expr)) ;; !
		     (actual-thunks (map walk actuals)))
		(lambda (args env)
		  (apply code-proc (map (lambda (t) (t args env)) actual-thunks))))))
	(else
	 (error "@cps2-asm missing Scheme clause" node))))
      ((@cps2-set name location expr) (make-mutator #t name location (walk expr)))
      ((@cps2-value-begin head tail) (make-seq head tail))
      ((@cps2-value-if test true false) (make-if test true false))
      ((@cps2-apply rator rands)
       (let ((rator-closure (walk rator))
	     (rands-closures (map walk rands)))
	 (lambda (args env)
	   (let* ((argvals (map (lambda (c) (c args env)) rands-closures))
		  (ratorval (rator-closure args env)))
	     (debug-pretty-print `(app-outer ,ratorval ,@argvals))
	     (ratorval *coreeval-magic* argvals)))))
      ((@cps2-exp-begin head tail) (make-seq head tail))
      ((@cps2-exp-if test true false) (make-if test true false)))))
