;;
;; analyze-sim.scm - 6.001 Spring '04
;; project 6 (register machines / analyze)
;;

;;;;;;;;;;;;;;;;;;;; Assembler ;;;;;;;;;;;;;;;;;;;
;; converts list of instructions/labels into assembled-code

(define (assemble insts)
  (format #t ";Assembling")
  (sweep-insts insts 
	       (make-assembled-code '()
				    '()
				    (make-label-table)
				    (make-assembled-instructions (length insts))
				    0)
	       0))

;; fill assembled-instructions structure with (instruction . proc),
;; while remembering labels, used registers, and used operations
(define (sweep-insts insts asm-insts i)
  (format #t ".")
  (cond ((null? insts)
	 (code-set-size! asm-insts i)
	 (format #t "done~%")
	 asm-insts)
	((label? (car insts))
	 (add-label! (code-label-table asm-insts) (car insts) i)
	 (sweep-insts (cdr insts) asm-insts i))
	((instruction? (car insts))
	 (set-instruction! (code-insts asm-insts) i
			   (assemble-instruction asm-insts (car insts)))
	 (sweep-insts (cdr insts) asm-insts (+ i 1)))
	(else
	 (error "unknown instruction:" (car insts) i))))

;; notice use of registers and ops in given instruction
;; returns (instruction . (lambda (machine) do-instruction))
(define (assemble-instruction code inst)
  (cons inst
	(cond ((assign? inst) (analyze-assign inst code))
	      ((perform? inst) (analyze-perform inst code))
	      ((test? inst) (analyze-test inst code))
	      ((branch? inst) (analyze-branch inst code))
	      ((goto? inst) (analyze-goto inst code))
	      ((save? inst) (analyze-save inst code))
	      ((restore? inst) (analyze-restore inst code))
	      ((halt? inst) (analyze-halt inst code))
	      (else (error "unknown instruction type: " inst)))))

(define (look-in-args code args)
  (for-each (lambda (arg)
	      (cond ((register-exp? arg)
		     (code-add-reg! code (register-exp-reg arg)))
		    ((tagged-list? arg 'op)
		     (code-add-op! code (cadr arg)))))
	    args))

(define (analyze-assign inst code)
  (code-add-reg! code (assign-reg-name inst))
  (look-in-args code (assign-value-exp inst))
  (let ((value-proc (analyze-expr (assign-value-exp inst)))
	(reg-name (assign-reg-name inst)))
    (lambda (machine)
      (set-register! machine
		     reg-name
		     (value-proc machine))
      (inc-pc! machine)
      #t)))

(define (analyze-perform inst code)
  (look-in-args code (perform-action inst))
  (let ((action-proc (analyze-expr (perform-action inst))))
    (lambda (machine)
      (action-proc machine)
      (inc-pc! machine)
      #t)))

(define (analyze-test inst code)
  (look-in-args code (test-condition inst))
  ...)

(define (analyze-branch inst code)
  (look-in-args code (branch-dest inst))	; CHANGED - May 3
  ...)

(define (analyze-goto inst code)
  (look-in-args code (goto-dest inst))		; CHANGED - May 3
  ...)

(define (analyze-save inst code)
  (code-add-reg! code (save-register inst))
  ...)

(define (analyze-restore inst code)
  (code-add-reg! code (restore-register inst))
  ...)

(define (analyze-halt inst code)
  (lambda (machine)
    #f))

;; return (lambda (machine) ...) that when called, 
;;  returns value of expression
(define (analyze-expr exp)
  (cond ((application-exp? exp)
         (let ((op (lookup-prim (application-exp-op exp)
				standard-primitives))    ; efficiency hack
               (args
                (map (lambda (e)
                       (analyze-primitive-exp e))
                     (application-exp-operands exp))))
	   (lambda (machine)
	     (apply op (map (lambda (a) (a machine)) args)))))
        ((and (pair? exp) (null? (cdr exp))) ;list has a single element
         (analyze-primitive-exp (car exp)))
        (else
	 (error "bad expression -- ASSEMBLE" exp))))

;; return (lambda (machine) ...) that when called, 
;;  returns value of primitive expression (const,label or reg)
(define (analyze-primitive-exp exp)
  (cond ((constant-exp? exp)
	 (lambda (machine)
	   (constant-exp-value exp)))
        ((label-exp? exp)
	 (lambda (machine)
	   (let ((addr (lookup-label (label-exp-label exp)
				     (code-label-table
				      (machine-code machine)))))
	     (if addr
		 addr
		 (machine-error machine "missing label" (label-exp-label exp))))))
        ((register-exp? exp)
	 (lambda (machine)
	   (let ((regn (index-of (register-exp-reg exp) (code-regs (machine-code machine)))))
	     (get-register machine regn))))
        (else
	 (error "unknown expression type -- ASSEMBLE" exp))))

;;;;;;;;;;;;;;;;;;; code execution ;;;;;;;;;;;;;;;;;;;;;;;

;; display instructions as executing?
(define *tracing* #f)

;; execute 1 instruction
;;  return false if machine reaches (halt) instruction
(define (step-machine machine)
  (inc-cycles machine)
  (let ((addr (get-register machine 'pc)))
    (if (not (and (number? addr)
		  (>= addr 0)
		  (< addr (code-size (machine-code machine)))))
	(machine-error machine "pc out of bounds" addr)))
  (let* ((code (machine-code machine))
	 (inst (get-instruction (code-insts code) 
				(get-register machine 'pc))))
    (if *tracing*
	(format #t " pc=~4A I=~A~%" (get-register machine 'pc) (car inst)))
    ((cdr inst) machine))) ; just call instruction procedure

;; step machine until (halt), then return value of 'result' reg
(define (run-machine machine)
  (if (step-machine machine)
      (run-machine machine)
      (get-register machine 'result)))

;; print machine state and signal error
(define (machine-error machine msg . rest)
  (display-machine-status machine)
  (apply error msg rest))

;; generates a program that runs code on the given machine
;;  initializes pc, continue, and args as given
;;  returns 'result', and prints cycle usage
(define (code-runner machine)
  (lambda (code startlabel endlabel . args)
    (reset-machine default-machine)
    (load-code default-machine code)
    (initialize-pc default-machine startlabel)
    (initialize-continue default-machine endlabel)
    (initialize-args default-machine args)
    (with-timings
	(lambda ()
	  (let ((val (run-machine default-machine)))
	    (format #t ";Result = ~A~%;Cycles used: ~7A  Max Stack Depth: ~7A~%"
		    val
		    (machine-cycles default-machine)
		    (stack-max-depth (machine-stack default-machine)))))
      (lambda (run-time gc-time real-time)
	(format #t ";Timing - Run: ~As GC: ~As Real: ~As~%"
		(internal-time/ticks->seconds run-time)
		(internal-time/ticks->seconds gc-time)
		(internal-time/ticks->seconds real-time))))))

;; as code-runner, but enables tracing
(define (code-tracer machine)
  (let ((runner (code-runner machine)))
    (lambda args
      (set! *tracing* #t)
      (apply runner args)
      (set! *tracing* #f))))

;; prompt for stepping, reads a char from keyboard
(define (step-prompt)
  (prompt-for-command-char "[' ' next inst, 'd' for display, 'q' to quit]"))

;; steps through code in tracing mode
(define (code-stepper machine)
  (lambda (code startlabel endlabel . args)
    (reset-machine default-machine)
    (load-code default-machine code)
    (initialize-pc default-machine startlabel)
    (initialize-continue default-machine endlabel)
    (initialize-args default-machine args)
    (set! *tracing* #t)
    (let loop ((char (step-prompt)))
      (cond ((eq? char #\q)
	     (set! *tracing* #f)
	     'done-stepping)
	    ((eq? char #\d)
	     (newline)
	     (display-machine-status machine)
	     (loop (step-prompt)))
	    (else
	     (newline)
	     (if (step-machine machine)
		 (loop (step-prompt))
		 (begin
		   (set! *tracing* #f)
		   (get-register machine 'result))))))))

;; 'filler' instruction used to pad code
(define default-instruction
  (cons '(halt) (lambda (machine) #f)))

;; automatically defined code
(define default-code
  (make-assembled-code
   default-registers         ; default (always present) registers
   '()                       ; no ops
   (add-label!               ; one label, pointing to the halt
    (make-label-table)
    'machine-done 0)
   (make-vector
    1 default-instruction)  ; only a (halt) inst
   1))                      ; 1 instruction

;; default machine for executing code
;;  32 registers, 1000 element stack
(define default-machine
  (make-machine 32 standard-primitives 1000))

;; standard code running on default-machine
(define run-code (code-runner default-machine))
(define trace-code (code-tracer default-machine))
(define start-stepper (code-stepper default-machine))
(define (display-code)
  (display-assembled-code (machine-code default-machine)))