; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-

; This is file assem.scm.

;;;; Disassembler and assembler

(define (disassemble tem)
  (newline)
  (really-disassemble (cond ((number? tem)
			     (extract (if (($ vm closure?) tem)
					  (($ vm closure-template) tem)
					  tem)))
			    ((and (pair? tem) (eq? (car tem) 'lambda))
			     (compile-lambda tem
					     (environment->cenv system-environment)
					     nil))
			    ((template? tem) tem)
			    ((closure? tem) (closure-template tem))
			    (else (error "not coercable to a template" tem)))
                      1)
  'done)

(define (really-disassemble tem level)
  (display "(%LAP ")  ;field reserved for template name
  (if (template-name tem)
      (write (template-name tem))
      (display "#F"))
  (let loop ((pc 0))
    (if (< pc (code-vector-length (template-code tem)))
	(loop (write-instruction tem pc level))
	(write-char #\) ))))

(define (newline-indent n)
  (newline)
  (do ((i n (- i 1)))
      ((= i 0))
    (write-char #\space)))

(define (write-instruction tem pc level)
  (let* ((code  (template-code tem))
         (const tem)  ;constants vector
         (opcode (code-vector-ref code pc))
	 (pc+1 (+ pc 1))
	 (lit (lambda () (vector-ref const (code-vector-ref code pc+1))))
	 (pc+2 (+ pc 2)))
    (newline-indent (* level 2))
    (if (< pc 10) (display " "))
    (write pc)
    (display "  (")
    (write (enumerand->name opcode op))
    (let ((new-pc
	   (cond ((= opcode op/literal)
		  (write-string " '")
		  (write (lit))
		  pc+2)
		 ((= opcode op/native)
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  (write-string " '")
		  (write (vector-ref const (code-vector-ref code pc+2)))
		  (+ pc 3))
		 ((or (= opcode op/global)
		      (= opcode op/set-global!))
		  (write-char #\space)
		  (write `(cell ,(cell-name (lit))))
		  pc+2)
		 ((= opcode op/make-closure)
		  (write-char #\space)
		  (really-disassemble (lit) (+ level 1))
		  pc+2)
		 ((or (= opcode op/local)
		      (= opcode op/set-local!))
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  (write-char #\space)
		  (write (code-vector-ref code pc+2))
		  (+ pc 3))
		 ((or (= opcode op/check-nargs=)
		      (= opcode op/check-nargs>=)
		      (= opcode op/make-env)
		      (= opcode op/make-rest-list)
		      (= opcode op/call)
		      (= opcode op/spread-args)
		      (= opcode op/open-port))
		  (write-char #\space)
		  (write (code-vector-ref code pc+1))
		  pc+2)
		 ((or (= opcode op/jump-if-false)
		      (= opcode op/jump)
		      (= opcode op/make-cont))
		  (write-char #\space)
		  (write `(-> ,(+ pc (code-vector-ref code pc+1) 2)))
		  pc+2)
		 ((or (= opcode op/make-d-vector)
		      (= opcode op/stob-of-type?)
		      (= opcode op/d-vector-ref)
		      (= opcode op/d-vector-set!)
		      (= opcode op/d-vector-length)
		      (= opcode op/make-b-vector)
		      (= opcode op/b-vector-ref)
		      (= opcode op/b-vector-set!)
		      (= opcode op/b-vector-length))
		  (write-char #\space)
		  (write `(e stob ,(enumerand->name (code-vector-ref code pc+1) stob)))
		  pc+2)
		 ((= opcode op/d-vector)
		  (write-char #\space)
		  (write `(e stob ,(enumerand->name (code-vector-ref code pc+1) stob)))
		  (write-char #\space)
		  (write (code-vector-ref code pc+2))
		  (+ pc 3))
		 (else pc+1))))
      (write-char #\))
      new-pc)))

; The rudiments of an assembler.

(define-compilator '%lap
  (lambda (exp cenv cont state)
    (sequentially
     (emit op/make-closure
	   (get-literal state (compile-lap (cadr exp) (cddr exp))))
     (dispose-of-val cont))))

(define (compile-lap name instruction-list)
  name  ;ignored for now
  (compiling (lambda (state)
	       (assemble instruction-list state))))

(define (assemble instruction-list state)
 (do ((l instruction-list (cdr l))
      (seg empty-segment
	   (if (pair? (car l))
	       (sequentially seg (assemble-instruction (car l) state))
	       seg)))  ;Ignore labels.
     ((null? l) seg)))

(define (assemble-instruction instr state)
  (do ((os (cdr instr) (cdr os))
       (seg (emit (name->enumerand (car instr) op))
	    (sequentially seg (assemble-operand (car os) state))))
      ((null? os) seg)))

(define (assemble-operand opcode state)
  (cond ((integer? opcode) (emit opcode))
	((eq? (car opcode) 'quote) (emit (get-literal state (cadr opcode))))
	((eq? (car opcode) 'e)
	 (emit (name->enumerand (caddr opcode)
				(case (cadr opcode)
				  ((stob) stob)
				  (else (error "losing" opcode))))))
	((eq? (car opcode) '->)
	 (error "not yet implemented" opcode))
	(else (error "unknown operand type" opcode))))