#| -*- Mode                : LISP;
       Package             : (BENCH-HARRISU :USE (GLOBAL RPG-BENCHMARKS)); 
       Base                : 10;
       source-optimizations: ucode;
   -*-
 
  Benchmark from some Harris corp division. Also a study in fancy file mode lines.
  Enhancements (C) Copyright 1983, Lisp Machine, Inc.

 |#


(timer test1 (bench 10000))

(timer test2 (bench2 10000))


#|
FGET and FPUT are lowest level data structure primitives, so make them
be instructions. FGETFRAME and FASSOC are helper routines called by these
instructions, so microcompile them also.
|#

(compiler:define-micro-properties fget (frame slot facet)
  :micro->micro t
  :opcode #o1777)

(compiler:define-micro-properties fput (frame slot facet value)
  :micro->micro t
  :opcode #o1776)

(compiler:define-micro-properties fgetframe (frame)
  :micro->micro t)

(compiler:define-micro-properties fassoc (key a-list)
  :micro->micro t)

(defun load-ucode (&aux
		   (a '(fget fput))
		   (b '(fgetframe fassoc)))
  (apply 'compiler:ma-load (append a b))
  (mapcar 'compiler:enable-micro-misc a)
  (compiler:describe-misc-map))

#|
Introduce the THUNK concept to abstract our rule invoker
|#

(eval-when (eval compile load)
  (defvar *avoid-eval* t "should be T if you have real lexical scoping"))

(defmacro thunk (expression)
  (cond (*avoid-eval*
	 `#'(lambda () ,expression))
	('else
	 `',expression)))

(defmacro invoke-thunk (x)
  `(,(cond (*avoid-eval* 'funcall) ('else 'eval))
    ,x))

#|
Now code the benchmarks without modification.
|#

(defun bench (number)
  (prog ()
     loop
	(cond ((zerop number) (return 'done)))
	(fput 'frame 'slot 'facet (thunk (car '(a b c))))
	(invoke-thunk (car (fget 'frame 'slot 'facet)))
	(setq number (- number 1))
	(go loop)))


(defun bench2 (number)
  (cond ((zerop number))
	(t (fput 'frame 'slot 'facet (thunk (car '(a b c))))
	   (invoke-thunk (car (fget 'frame 'slot 'facet)))
	   (bench2 (- number 1)))))


(defun fget (frame slot facet)
  (mapcar #'car
	  (cdr (assoc facet
		      (cdr (assoc slot
				  (cdr (get frame 'frame))))))))



(defun fput (frame slot facet value)
  (cond ((member value (fget frame slot facet)) nil)
	(t (fassoc value
		   (fassoc facet
			   (fassoc slot
				   (fgetframe frame)))))))


(defun fgetframe (frame)
  (cond ((get frame 'frame))
	(t (putprop frame (ncons frame) 'frame))))

(defun fassoc (key a-list)
  (cond ((assoc key (cdr a-list)))
	(t (cadr (rplacd (last a-list) (ncons (ncons key)))))))