;;
;; simulator.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 (asm-insts) with instructions,
;; 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.
;; Currently does nothing with instruction.
(define (assemble-instruction code inst)
  (define (look-in-args 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))
  (cond ((assign? inst)
	 (code-add-reg! code (assign-reg-name inst))
	 (look-in-args (assign-value-exp inst)))
	((perform? inst)
	 (look-in-args (perform-action inst)))
	((test? inst)
	 (look-in-args (test-condition inst)))
	((branch? inst)
	 (look-in-args (branch-dest inst)))	; CHANGED May 3
	((goto? inst)
	 (look-in-args (goto-dest inst)))	; CHANGED May 3
	((save? inst)
	 (code-add-reg! code (save-register inst)))
	((restore? inst)
	 (code-add-reg! code (restore-register inst)))
	((halt? inst)
	 'nothing-to-do)
	(else (error "unknown instruction type: " inst)))
  inst) ; return inst

;;;;;;;;;;;;;;;;;;; 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) inst))
    (if (halt? inst)
	#f
	(begin
	  (cond ((assign? inst)
		 (set-register! machine
				(assign-reg-name inst)
				(eval-expression machine 
						 (assign-value-exp inst)))
		 (inc-pc! machine))
		((perform? inst)
		 (eval-expression machine (perform-action inst))
		 (inc-pc! machine))
		((test? inst)
		 (set-register! machine
				'cr
				(eval-expression machine
						 (test-condition inst)))
		 (inc-pc! machine))
		((branch? inst)
		 (if (get-register machine 'cr)
		     (set-register! machine 'pc
				    (eval-expression machine
						     (branch-dest inst)))
		     (inc-pc! machine)))
		((goto? inst)
		 (set-register! machine 'pc
				(eval-expression machine
						 (goto-dest inst))))
		((save? inst)
		 (stack-push machine
			     (get-register machine 
					   (save-register inst)))
		 (inc-pc! machine))
		((restore? inst)
		 (set-register! machine
				(restore-register inst)
				(stack-pop machine))
		 (inc-pc! machine))
		(else
		 (machine-error machine "unknown instruction" inst)))
	  #t))))

;; 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)))

;; return value of expression
(define (eval-expression machine exp)
  (cond ((application-exp? exp)
         (let ((op (lookup-prim (application-exp-op exp)
				(machine-primitives machine)))
               (args
                (map (lambda (e)
                       (parse-primitive-exp e machine))
                     (application-exp-operands exp))))
           (apply op args)))
        ((and (pair? exp) (null? (cdr exp))) ;list has a single element
         (parse-primitive-exp (car exp) machine))
        (else
	 (machine-error machine "bad expression -- ASSEMBLE" exp))))

;; return value of primitive expression (const, label or reg)
(define (parse-primitive-exp exp machine)
  (cond ((constant-exp? exp)
	 (constant-exp-value exp))
        ((label-exp? exp)
	 (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)
         (get-register machine (register-exp-reg exp)))
        (else
	 (machine-error machine "unknown expression type -- ASSEMBLE" exp))))

;; 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))))))))

;; 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)))