;;; $Id: cpu.ss,v 1.8 1993/08/06 16:49:29 burger Exp $
;;; $Revision: 1.8 $

(define scheme-machine
  (lambda (go interrupt halt)
    (letrec
	([start ; Wait for GO signal
	  ; Pre: none
	  ($regs
	   (if (go)
	       ($next load (addr (add (c24 0) (c24 0) tt)) (cont fetch))
	       ($next start)))]
	 [load ; Load all registers from the heap
	  ; Pre: addr valid, cont = state to go after loading registers
	  ($regs
	   ($next load-1 (addr (add addr (c24 0) tt))
		  (acc (alu-memrd mem addr))))]
	 [load-1 ; Load all but acc from heap
	  ; Pre: addr valid, cont = next-state
	  ($regs
	   (assign ((val* (obj.ptr (memrd mem addr)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((lex-env (obj.ptr (memrd mem addr)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((k (memrd mem addr)) (addr (add addr (c24 0) tt)))
	   (assign ((code (obj.ptr (memrd mem addr)))
		    (addr (add addr (c24 0) tt)))
	     ($next cont (pc (add (obj.ptr (memrd mem addr)) code tt))))))))]
	 [save ; Save all registers on the heap
	  ; Pre: addr valid, cont = state to go after dumping registers
	  ($regs
	   ($next save-1 (mem (memwr mem addr acc))
		  (addr (add addr (c24 0) tt))))]
	 [save-1 ; Save all registers except acc on the heap
	  ; Pre: addr valid, cont = next-state
	  ($regs
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> val*)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> lex-env)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr k))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> code)))
		    (addr (add addr (c24 0) tt))
		    (pc (add pc (complement code) ff)))
	     ($next cont (mem (memwr mem addr (hcite <imm> <fixnum> pc)))))
	   ))))]
	 [fetch ; Reads opcode into cont register & bumps PC & goes to opcode
	  ; Pre: valid PC
	  ($regs
	   (if (halt)
	       ($finish)
	       (if (and (interrupt) ie)
		   ($next malloc (tag (c8 (make-tag <vector> <int-cont>)))
			  (addr (add (c24 0) (c24 5) tt))
			  (cont interrupt-1))
		   (assign ((cont (convert (memrd mem pc)))
			    (pc (add pc (c24 0) tt)))
		     ($next cont)))))]
	 [lit-inst
	  ($regs
	   ($next fetch (acc (alu-memrd mem pc))
		  (pc (add pc (c24 0) tt))))]
	 [varref-inst
	  ($regs
	   ($next lookup (pc (add pc (c24 0) tt))
		  (cont varref-inst-1)
		  (addr (add (c24 0) lex-env tt))
		  (acc (alu-memrd mem pc))))]
	 [varref-inst-1
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (if (same-type? m <imm> <undefined>)
		 ($next error (addr (add (c24 0) (c24 unbound-error) ff))
			(acc (alu-void)))
		 ($next fetch
			(acc (hcite (obj.tag m)
				    (alu-out (alu b+0 ? (obj.ptr m) ff)))))
		 )))]
	 [varassign-inst
	  ($regs
	   (assign ((mem (memwr mem (c24 acc-loc) acc)))
	     ($next lookup (pc (add pc (c24 0) tt)) (cont varassign-inst-1)
		    (addr (add (c24 0) lex-env tt))
		    (acc (alu-memrd mem pc)))))]
	 [varassign-inst-1
	  ($regs
	   (assign ((acc (alu-memrd mem (c24 acc-loc))))
	     ($next fetch (mem (memwr mem addr acc))
		    (acc (alu-void)))))]
	 [if-inst
	  ($regs
	   (if (true-value? acc)
	       ($next fetch (pc (add pc (c24 0) tt)))
	       ($next fetch (pc (add (obj.ptr (memrd mem pc)) code tt)))))]
	 [proc-inst
	  ($regs
	   ($next malloc (tag (c8 (make-tag <fixed> <closure>)))
		  (cont proc-inst-1)))]
	 [proc-inst-1
	  ($regs
	   (assign ((lex-env addr)
		    (mem (memwr mem addr (hcite <vector> <vec> lex-env)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> code)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((acc (alu-memrd mem pc))
		    (pc (add pc (c24 0) tt)))
	   (assign ((mem (memwr mem addr acc))
		    (addr (add (c24 0) lex-env ff)))
	     ($next fetch
		    (acc (hcite <fixed> <closure> addr))
		    (lex-env (obj.ptr (memrd mem addr)))))
	   ))))]
	 [save-inst
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <save-cont>)))
		  (addr (add (c24 0) (c24 5) ff))
		  (cont save-inst-1)))]
	 [save-inst-1
	  ($regs
	   (assign ((acc (hcite <vector> <save-cont> addr))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> val*)))
		    (val* (c24 zero-loc))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> lex-env)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr k))
		    (k acc)
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr (hcite <vector> <vec> code)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((acc (alu-memrd mem pc))
		    (pc (add pc (c24 0) tt)))
	     ($next fetch (mem (memwr mem addr acc))
		    (acc (alu-void))))
	   ))))))]
	 [args-inst
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <vec>)))
		  (addr (add (c24 0) (obj.ptr (memrd mem pc)) ff))
		  (pc (add pc (c24 0) tt))
		  (acc (alu-void))
		  (cont args-inst-1)))]
	 [args-inst-1
	  ($regs
	   ($next fetch (val* addr)))]
	 [push-inst
	  ($regs
	   (assign ((addr (add val* (obj.ptr (memrd mem pc)) tt))
		    (pc (add pc (c24 0) tt)))
	     ($next fetch (mem (memwr mem addr acc))
		    (acc (alu-void)))))]
	 [interrupt-1
	  ($regs
	   ($next save (addr (add addr (c24 0) tt))
		  (cont interrupt-2)))]
	 [interrupt-2
	  ($regs
	   (assign ((acc (alu-memrd mem (c24 int-loc)))
		    (addr (add addr (c24 -6) ff)))
	     ($next apply-proc
		    (ie (*interrupts-enabled* ie ff))
		    (k (hcite tag addr)))))]
	 [lookup
	  ($regs
	   (ddd-let ((r (alu a-0 (obj.ptr acc) ? ff)))
	     (if (n-flag r)
		 ($next cont (pc (add pc (c24 0) tt))
			(acc (hcite (obj.tag acc) (alu-out r)))
			(addr (add addr (obj.ptr (memrd mem pc)) ff)))
		 ($next lookup (acc (hcite (obj.tag acc) (alu-out r)))
			(addr (add (c24 0) (obj.ptr (memrd mem addr)) tt))))))]
	 [extend-env
	  ; addr -> new rib
	  ($regs
	   ; [pc-loc] <- pc, pc <- rib+1
	   (assign ((mem (memwr mem (c24 pc-loc) (hcite <imm> <fixnum> pc)))
		    (pc (add addr (c24 0) tt)))
	   ; [rib+1] <- lex-env, lex-env <- rib, pc <- rib, addr <- rib+1
	   (assign ((mem (memwr mem pc (hcite <vector> <vec> lex-env)))
		    (lex-env addr)
		    (pc (add addr (c24 0) ff))
		    (addr (add addr (c24 0) tt)))
	   ; [k-loc] <- k
	   (assign ((mem (memwr mem (c24 k-loc) k)))
	     ; acc <- [rib], addr <- rib+2, pc <- val*+1
	     ($next extend-env-1 (acc (alu-memrd mem pc))
		    (addr (add addr (c24 0) tt))
		    (pc (add val* (c24 0) tt)))))))]
	 [extend-env-1
	  ($regs
	   (ddd-let ((r (alu a-0 (obj.ptr acc) ? ff)))
	     (if (n-flag r)
		 (assign ((acc (hcite (obj.tag acc) (alu-out r)))
			  (val* (c24 zero-loc))
			  (k (memrd mem (c24 k-loc))))
		   ($next fetch (pc (add (obj.ptr (memrd mem (c24 pc-loc)))
					 (c24 0) ff))))
		 (assign ((k (memrd mem pc))
			  (pc (add pc (c24 0) tt))
			  (acc (hcite (obj.tag acc) (alu-out r))))
		   ($next extend-env-1 (mem (memwr mem addr k))
			  (addr (add addr (c24 0) tt)))))))]
	 [apply-proc
	  ($regs
	   (if (same-type? acc <fixed> <closure>)
	       (assign ((addr (add (obj.ptr acc) (c24 0) ff)))
	       (assign ((lex-env (obj.ptr (memrd mem addr)))
			(addr (add addr (c24 0) tt)))
	       (assign ((code (obj.ptr (memrd mem addr)))
			(addr (add addr (c24 0) tt)))
	       (assign ((pc (add (obj.ptr (memrd mem addr)) code tt))
			(addr (add val* (c24 0) ff)))
		 ($next malloc (cont extend-env)
			(tag (c8 (make-tag <vector> <vec>)))
			(addr (add (c24 0) (obj.ptr (memrd mem addr)) tt))))
	       )))
	     (if (same-type? acc <imm> <primitive>)
		 (assign ((cont (convert acc))
			  (addr (add val* (c24 0) tt)))
		   ($next cont))
	     (if (same-type? acc <fixed> <callcc>)
		 ($next callcc (addr (add val* (c24 0) tt))
			(k (memrd mem (obj.ptr acc))))
		 ($next error (addr (add (c24 0) (c24 procedure-error) ff)))
		 ))))]
	 [callcc
	  ($regs
	   ($next apply-cont (acc (alu-memrd mem addr))))]
	 [apply-cont
	  ($regs
	   (if (same-type? k <vector> <int-cont>)
	       ($next load (addr (add (c24 0) (obj.ptr k) tt))
		      (cont fetch))
	       (if (same-type? k <vector> <save-cont>)
		   ($next load-1 (addr (add (c24 0) (obj.ptr k) tt))
			  (cont fetch))
		   ; Else it's a done-cont
		   ($finish))))]
	 [malloc ; Allocate
	  ; Pre: tag+addr specify what to allocate,
	  ; Post: addr contains the new address
	  ($regs
	   (ddd-let ((a (alloc tt ff (make-cite tag addr))))
	     (if (gc-needed? a)
		 ($next gc-1)
		 (if (alloc-done? a)
		     ($next malloc-2)
		     ($next malloc)))))]
	 [malloc-1
	  ($regs
	   (ddd-let ((a (alloc tt ff (make-cite tag addr))))
	     (if (gc-needed? a)
		 ($next start (mem (panic mem)))
		 (if (alloc-done? a)
		     ($next malloc-2)
		     ($next malloc-1)))))]
	 [malloc-2
	  ($regs
	   (ddd-let ((a (alloc tt tt ?)))
	     ($next malloc-3 (addr (add (c24 0) (mem-avail a) ff)))))]
	 [malloc-3
	  ($regs
	   (ddd-let ((a (alloc ff ff ?)))
	     (if (alloc-ready? a)
		 ($next cont)
		 ($next malloc-3))))]
	 [gc-1
	  ($regs
	   (ddd-let ((a (alloc tt ff ?)))
	   (assign ((mem (memwr mem (c24 acc-loc) acc)))
	   (ddd-let ((a (alloc tt ff ?)))
	   (assign ((mem (memwr mem (c24 val*-loc)
				(hcite <vector> <vec> val*))))
	   (ddd-let ((a (alloc tt ff ?)))
	   (assign ((mem (memwr mem (c24 lex-env-loc)
				(hcite <vector> <vec> lex-env))))
	   (ddd-let ((a (alloc tt ff ?)))
	   (assign ((mem (memwr mem (c24 k-loc) k)))
	   (ddd-let ((a (alloc tt ff ?)))
	   (assign ((mem (memwr mem (c24 code-loc)
				(hcite <vector> <vec> code)))
		    (pc (add pc (complement code) ff)))
	     ($next gc-2 (mem (memwr mem (c24 pc-loc)
				     (hcite <imm> <fixnum> pc)))))
	   ))))))))))]
	 [gc-2
	  ($regs
	   (ddd-let ((a (alloc ff ff ?)))
	     (if (alloc-ready? a)
		 (if (eqv? cont p-gc-1)
		     ($next cont)
		     (assign ((acc (alu-memrd mem (c24 acc-loc))))
		     (assign ((val* (obj.ptr (memrd mem (c24 val*-loc)))))
		     (assign ((lex-env (obj.ptr
					(memrd mem (c24 lex-env-loc)))))
		     (assign ((k (memrd mem (c24 k-loc))))
		     (assign ((code (obj.ptr (memrd mem (c24 code-loc)))))
		       ($next malloc-1
			      (pc (add (obj.ptr (memrd mem (c24 pc-loc)))
				       code tt))))
		     )))))
		 ($next gc-2))))]
	 [error
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <vec>)))
		  (addr (add (c24 0) (c24 2) ff))
		  (cont error-1)
		  (pc (add addr (c24 0) ff))))]
	 [error-1
	  ($regs
	   (assign ((addr (add addr (c24 0) tt)) (val* addr))
	   (assign ((mem (memwr mem addr (hcite <imm> <fixnum> pc)))
		    (addr (add addr (c24 0) tt)))
	   (assign ((mem (memwr mem addr acc)))
	     ($next apply-proc
		    (acc (alu-memrd mem (c24 err-loc)))))
	   )))]
	 [p-fixnum?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <imm> <fixnum>) () ())))]
	 [p-positive?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b+0 ? (obj.ptr m) ff)))
	       (alu-if (not (or (n-flag r) (z-flag r))) () ()))))]
	 [p-negative?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b+0 ? (obj.ptr m) ff)))
	       (alu-if (n-flag r) () ()))))]
	 [p-zero?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b+0 ? (obj.ptr m) ff)))
	       (alu-if (z-flag r) () ()))))]
	 [p-odd?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (c-odd? m) () ())))]
	 [p-even?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (not (c-odd? m)) () ())))]
	 [p-eq
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a-b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (z-flag r) () ()))))]
	 [p-ne
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a-b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (not (z-flag r)) () ()))))]
	 [p-gt
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu b-a (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (xor (n-flag r) (v-flag r)) () ()))))]
	 [p-ge
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a-b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (not (xor (n-flag r) (v-flag r))) () ()))))]
	 [p-lt
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a-b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (xor (n-flag r) (v-flag r)) () ()))))]
	 [p-le
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu b-a (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (alu-if (not (xor (n-flag r) (v-flag r))) () ()))))]
	 [p-add
	  ($regs
	   (assign ((acc (hcite (make-imm (memrd mem addr))
				(alu-out (alu b+0 ?
					      (obj.ptr (memrd mem addr)) ff))))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a+b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) ff)))
	       (if (v-flag r)
		   ($next error (addr (add (c24 0) (c24 overflow-error) ff))
			  (acc (hcite (obj.tag acc) (alu-out r))))
		   ($next apply-cont
			  (acc (hcite (obj.tag acc) (alu-out r))))))))]
 	 [p-sub
	  ($regs
	   (assign ((acc (hcite (make-imm (memrd mem addr))
				(alu-out (alu b+0 ?
					      (obj.ptr (memrd mem addr)) ff))))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a-b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       (if (v-flag r)
		   ($next error (addr (add (c24 0) (c24 overflow-error) ff))
			  (acc (hcite (obj.tag acc) (alu-out r))))
		   ($next apply-cont
			  (acc (hcite (obj.tag acc) (alu-out r))))))))]
	 [p-add1
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b+0 ? (obj.ptr m) tt)))
	       (if (v-flag r)
		   ($next error (addr (add (c24 0) (c24 overflow-error) ff))
			  (acc (hcite (make-imm m) (alu-out r))))
		   ($next apply-cont
			  (acc (hcite (make-imm m) (alu-out r))))
		   ))))]
 	 [p-sub1
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b-0 ? (obj.ptr m) ff)))
	       (if (v-flag r)
		   ($next error (addr (add (c24 0) (c24 overflow-error) ff))
			  (acc (hcite (make-imm m) (alu-out r))))
		   ($next apply-cont
			  (acc (hcite (make-imm m) (alu-out r))))
		   ))))]
	 [p-asr
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (ddd-let ((r (alu b+0 ? (obj.ptr m) ff)))
	       ($next apply-cont
		      (acc (hcite (make-imm m) (asr (alu-out r))))))))]
	 [p-boolean?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (or (same-type? m <imm> <true>)
			  (same-type? m <imm> <false>)) () ())))]
	 [p-not
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <imm> <false>) () ())))]
	 [p-bitand
	  ($regs
	   (assign ((acc (hcite (make-imm (memrd mem addr))
				(alu-out (alu b+0 ?
					      (obj.ptr (memrd mem addr)) ff))))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu a&b (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       ($next apply-cont
		      (acc (hcite (obj.tag acc) (alu-out r)))))))]
	 [p-bitor
	  ($regs
	   (assign ((acc (hcite (make-imm (memrd mem addr))
				(alu-out (alu b+0 ?
					      (obj.ptr (memrd mem addr)) ff))))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu aorb (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       ($next apply-cont
		      (acc (hcite (obj.tag acc) (alu-out r)))))))]
	 [p-bitxor
	  ($regs
	   (assign ((acc (hcite (make-imm (memrd mem addr))
				(alu-out (alu b+0 ?
					      (obj.ptr (memrd mem addr)) ff))))
		    (addr (add addr (c24 0) tt)))
	     (ddd-let ((r (alu axorb (obj.ptr acc)
			       (obj.ptr (memrd mem addr)) tt)))
	       ($next apply-cont
		      (acc (hcite (obj.tag acc) (alu-out r)))))))]
	 [p-char?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <imm> <char>) () ())))]
	 [p-read-char
	  ($regs
	   (assign ((pc (add (obj.ptr (memrd mem addr)) (c24 0) ff))
		    (addr (add addr (c24 0) tt)))
	     ; PC = port number
	     (ddd-let ((p (pread port pc)))
	       ($next apply-cont
		      (acc (hcite (obj.tag p)
				  (alu-out (alu b+0 ? (obj.ptr p) ff))))))))]
	 [p-write-char
	  ($regs
	   (assign ((pc (add (obj.ptr (memrd mem addr)) (c24 0) ff))
		    (addr (add addr (c24 0) tt)))
	   ; PC = port number, ACC = char
	   (assign ((acc (alu-memrd mem addr)))
	     ($next apply-cont (port (pwrite port pc acc))
		    (acc (alu-void))))))]
	 [p-eof-object?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <imm> <eof-object>) () ())))]
	 [p-null?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <imm> <null>) () ())))]
	 [p-pair?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <fixed> <pair>) () ())))]
	 [p-cons
	  ($regs
	   ($next malloc (tag (c8 (make-tag <fixed> <pair>)))
		  (pc (add addr (c24 0) ff))
		  (cont p-cons-1)))]
	 [p-cons-1
	  ($regs
	   (assign ((acc (alu-memrd mem pc))
		    (pc (add pc (c24 0) tt))
		    (val* addr))
	   (assign ((mem (memwr mem addr acc))
		    (addr (add addr (c24 0) tt)))
	   (assign ((acc (alu-memrd mem pc)))
	   (assign ((mem (memwr mem addr acc))
		    (addr (add val* (c24 0) ff)))
	     ($next apply-cont (acc (hcite <fixed> <pair> addr))))
	   ))))]
	 [p-vector?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <vector> <vec>) () ())))]
	 [p-make-vector
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <vec>)))
		  (addr (add (c24 0) (obj.ptr (memrd mem addr)) ff))
		  (cont p-make-vector-1)))]
	 [p-make-vector-1
	  ($regs
	   ($next apply-cont (acc (hcite <vector> <vec> addr))))]
	 [p-string?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <vector> <string>) () ())))]
	 [p-make-string
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <string>)))
		  (addr (add (c24 0) (obj.ptr (memrd mem addr)) ff))
		  (cont p-make-string-1)))]
	 [p-make-string-1
	  ($regs
	   ($next apply-cont (acc (hcite <vector> <string> addr))))]
	 [p-symbol?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (same-type? m <vector> <symbol>) () ())))]
	 [p-string->symbol
	  ($regs
	   ($next apply-cont
		  (acc (hcite <vector> <symbol>
			      (alu-out (alu b+0 ? (obj.ptr (memrd mem addr))
					    ff))))))]
	 [p-symbol->string
	  ($regs
	   ($next apply-cont
		  (acc (hcite <vector> <string>
			      (alu-out (alu b+0 ? (obj.ptr (memrd mem addr))
					    ff))))))]
	 [p-procedure?
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (or (same-type? m <imm> <primitive>)
			  (same-type? m <fixed> <closure>)
			  (same-type? m <fixed> <callcc>)) () ())))]
	 [p-eq?
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	   (ddd-let ((m (memrd mem addr)))
	   (ddd-let ((r (alu a-b (obj.ptr acc) (obj.ptr m) tt)))
	     (alu-if (and (same-type? acc (obj.tag.type m) (obj.tag.sub m))
			  (z-flag r)) () ())))))]
	 [p-apply
	  ($regs
	   (assign ((acc (alu-memrd mem addr))
		    (addr (add addr (c24 0) tt)))
	     ($next apply-proc (val* (obj.ptr (memrd mem addr))))))]
	 [p-abort
	  ($regs
	   ($finish (acc (alu-void))))]
	 [p-call/cc
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <vec>)))
		  (addr (add (c24 0) (c24 0) tt))
		  (acc (alu-memrd mem addr))
		  (cont p-call/cc-1)))]
	 [p-call/cc-1
	  ($regs
	   ($next malloc (tag (c8 (make-tag <fixed> <callcc>)))
		  (val* addr)
		  (pc (add addr (c24 0) tt))
		  (cont p-call/cc-2)))]
	 [p-call/cc-2
	  ($regs
	   (assign ((mem (memwr mem addr k)))
	     ($next apply-proc (mem (memwr mem pc (hcite tag addr))))))]
	 [p-void
	  ($regs
	   ($next apply-cont (acc (alu-void))))]
	 [p-read-obj
	  ($regs
	   (assign ((addr (add (c24 0) (obj.ptr (memrd mem addr)) ff))
		    (pc (add addr (c24 0) tt)))
	   ; ADDR -> object, PC -> offset
	   (assign ((addr (add addr (obj.ptr (memrd mem pc)) ff)))
	     ($next apply-cont (acc (alu-memrd mem addr))))))]
	 [p-write-obj
	  ($regs
	   (assign ((addr (add (c24 0) (obj.ptr (memrd mem addr)) ff))
		    (pc (add addr (c24 0) tt)))
	   ; ADDR -> object, PC -> offset
	   (assign ((addr (add addr (obj.ptr (memrd mem pc)) ff))
		    (pc (add pc (c24 0) tt)))
	   (assign ((acc (alu-memrd mem pc)))
	     ($next apply-cont (acc (alu-void))
		    (mem (memwr mem addr acc)))))))]
	 [p-gc
	  ($regs
	   ($next malloc (tag (c8 (make-tag <vector> <vec>)))
		  (addr (add (c24 0) (c24 #x7fffff) ff))
		  (cont p-gc-1)))]
	 [p-gc-1
	  ($regs
	   ($next load-1 (addr (add (c24 0) (c24 val*-loc) ff))
		  (acc (alu-void))
		  (cont apply-cont)))]
	 [p-argc
	  ($regs
	   (assign ((addr (add (c24 0) lex-env ff)))
	     ($next apply-cont
		    (acc (hcite (obj.tag (memrd mem addr))
				(alu-out (alu b-0 ? (obj.ptr (memrd mem addr))
					      ff)))))))]
	 [p-execute
	  ($regs
	   (assign ((code (obj.ptr (memrd mem addr)))
		    (addr (add addr (c24 0) tt)))
	     (assign ((lex-env (obj.ptr (memrd mem addr)))
		      (addr (add (c24 0) (c24 0) ff)))
	       ($next fetch (pc (add addr code tt))
		      (val* (c24 zero-loc))
		      (acc (alu-void))))))]
	 [p-interrupts-enabled?
	  ($regs
	   (zero-if ie () ()))]
	 [p-interrupts-enabled
	  ($regs
	   (ddd-let ((m (memrd mem addr)))
	     (zero-if (true-value? m)
		      ((ie (*interrupts-enabled* ie tt)))
		      ((ie (*interrupts-enabled* ie ff))))))]
	 [p-interrupt-handler
	  ($regs
	   ($next apply-cont (acc (alu-memrd mem (c24 int-loc)))))]
	 [p-set-interrupt-handler
	  ($regs
	   (assign ((acc (alu-memrd mem addr)))
	     ($next apply-cont (mem (memwr mem (c24 int-loc) acc))
		    (acc (alu-void)))))]
	 [p-error-handler
	  ($regs
	   ($next apply-cont (acc (alu-memrd mem (c24 err-loc)))))]
	 [p-set-error-handler
	  ($regs
	   (assign ((acc (alu-memrd mem addr)))
	     ($next apply-cont (mem (memwr mem (c24 err-loc) acc))
		    (acc (alu-void)))))]
	 )
      (ddd-init start (acc (hobj <imm> <fixnum> 0))
		(val* ?) (lex-env ?) (k ?) (code ?) (pc 0)
		(tag ?) (addr 0) (ie *ie*) (port ?) (mem ?) (cont ?)
		))))