[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

RE: PCL isn't so bad after all (even at washing cars!)

	Since everyone seemed to have been thrown into convulsions at the
thought of PCL being so mind-bogglingly bad, I thought I'd look into the
	First (to keep everyone reading) here are my results w/1000 cars:
Machine: Symbolics 3650
			  (best of 4 trials - 'cept for the original :-)
---code---		---total time (page&gc time)---
original clos port:	61.65 min (13.33 min)
below (modified):	28.25 sec (1.6 sec)   <-  ~130 times speedup
no methods in the clos-simulation part (only the carwash part):
			27.65 sec (1.7 sec)

Now that we're all awake, here's what I did:
	(1) cut out much needless consing.
	(2) cut out most refs to global vars.
	(3) turned EVALs into APPLYs.
	(4) turned a few complex-recursive functions into iterative ones.
	(5) reorganized style/syntax (mostly for my own sake)

In doing the obove, I assumed that what the original benchmark was
intended to measure was the carwash itself, as opposed to the simulator
(which, frankly, directly translated would not have run efficiently in
any language I know of).  So I felt no restrictions on rewriting much of
the simulator functions to be more efficient without changing the
functionality. The second (slightly faster) modified time above is for
the simulation with all generic functions that have only 1 method turned
into regular functions (Chris mentioned that in Ernie, one can add
declarations inside methods to achieve this effect - you lose the some of
the error catching capability, but it may be faster).  I'm still not
really convinced that the carwash is the right benchmark (especially
after all this!), mostly because the difference between implementing all
gfns with one method as functions made such a small difference. Finally,
I gather that Ernie is quite a different language from lisp, and I'm not
at all convinced that we're not comparing apples and monkey wrenches.

Anyway - below is the source for my version of the benchmark... still
could use tuning, but at least we're much better off than we were.

;;; -*- Package: PCL; Syntax: Common-Lisp -*-
;;; clos-simulator.lsp
;;; Author: Chris Burdorf
;;; Taken from Dave McArthur's  Bert simulator.
;;; Modified by Mike Thome (mthome@bbn.com) 16 Nov '88
;;;    (I *KNEW* that pcl couldn't be THAT bad!)
;;; Here are the two files. To run the system:
;;; 1. load clos-simulator first
;;; 2. after loading the carwash, do (generate-cars num) where num
;;;    is the number of automobiles in the simulation.  I used 20 for my tests.
;;; 3. Then type (get-going).  That should do it.

(defclass bert nil nil)

(defclass simulator (bert)
  ((things-to-do :accessor things-to-do :initform nil)	; elem = (time . (func . args))
   (history :accessor history :initform nil)
   (db :accessor db :initform nil)))

(defclass clock (bert)
  ((current-time :accessor current-time :initform 0)
   (actors-running :accessor actors-running :initform nil)	; elem = (time . simulator)
   (ticksize :accessor ticksize :initform 1)))

(defvar *clock* (make-instance 'clock))

;;;Insert an action into an object's agenda after time n.
(defmethod do-after ((obj simulator) n action)
  (let ((l (things-to-do obj))
	(ti (+ (current-time *clock*) n)))
    (when (or (not l) (< ti (caar l)))
      (setf (actors-running *clock*)
	    (inserttm (cons ti obj) (actors-running *clock*))))
    (setf (things-to-do obj)
	  (inserttm (cons ti action) (things-to-do obj)))))

(defvar *clocktrace nil)

(defmethod tick ((cl clock))
  "Cycle through all the actors and execute methods to be done at this time."
  (let ((newtime (+ (current-time cl) (ticksize cl))))
    (do* ((events (actors-running cl) (actors-running cl)))
	 ((or (null events) (> (caar events) newtime)))
      (setf (current-time cl) (caar events))
      (do ((ev events (cdr ev)))
	  ((or (null ev) (/= (current-time cl) (caar ev))))
	(pop (actors-running cl))
	;;(when *clocktrace (format t "\/\/") (format t (cdar events)))
	(atick (cdar ev) cl)))
    (setf (current-time cl) newtime)))

(defmethod atick ((obj bert) cl)
  "Execute messages to be done at this time."
  (let ((ttd nil))
      (when (or (null (setq ttd (car (things-to-do obj))))
		(< (current-time cl) (car ttd)))
      (apply (cadr ttd) (cddr ttd))
      (pop (things-to-do obj)))

    (when ttd
      (setf (actors-running cl)
	    (mergetm (cons (car ttd) obj) (actors-running cl))))))
;;;run the simulation until there are no more actors running.

(defmethod run ((cl clock))
    (if (actors-running cl)
	(tick cl)

(defmethod tick-times ((cl clock) n)
  (dotimes (j (1- n))
    (tick cl)))

;; inserttm inserts events or plans into a list of same to maintain
;; a minimum first ordering of elements.  a plan or event element
;; is a cons of a time (integer) followed by action or actor
(defun inserttm (itm l)
  (let ((itm-time (car itm)))
      ((null l) (list itm))
      (t (do* ((prev-cons nil this-cons)
	       (this-cons l (cdr this-cons)))
	      ((or (null this-cons)
		   (<= itm-time (caar this-cons)))
	       (if prev-cons
		   (progn (rplacd prev-cons (cons itm this-cons)) l)
		   (cons itm this-cons))))))))

#+ignore					; this one works as advertised
(defun mergetm (itm l)
  (let ((itm-time (car itm))
	(itm-rest (cdr itm)))
      ((null l) (list itm))
      (t (do* ((prev-cons nil this-cons)
	       (this-cons l (cdr this-cons)))
	      ((or (null this-cons) (< itm-time (caar this-cons)))
	       (if prev-cons
		   (progn (rplacd prev-cons (cons itm this-cons)) l)
		   (cons itm this-cons)))
	   (when (and (= itm-time (caar this-cons))
		      (equal itm-rest (cdar this-cons)))
	     (return l)))))))

;;; this is a direct translation from the original... and is not likely to work.
;;; However, changing to the above (working) code slows things down a little -
;;; probably because of the expense of doing lots of EQUALs.  Note that things would
;;; be even faster if inserttm were used instead of mergetm.
;; mergetm inserts as above but only if itm is not already in l
(defun mergetm (itm l)
  (let ((itm-time (car itm)))
      ((null l) (list itm))
      (t (do* ((prev-cons nil this-cons)
	       (this-cons l (cdr this-cons)))
	      ((or (null this-cons) (< itm-time (caar this-cons)))
	       (if prev-cons
		   (progn (rplacd prev-cons (cons itm this-cons)) l)
		   (cons itm this-cons)))
	   (when (eql itm (car this-cons))
	     (return l)))))))


;;; -*- Package: PCL; Syntax: Common-Lisp -*-
;;; load clos-simulator.lisp first
;;; File: Carwash.lsp
;; carwash simulation
;  time warp version using twbert and functional access of variables.
;  author: Chris Burdorf
;  date: 7-87

;; Classes

(defclass delayer (simulator)
       ((twxwindow :accessor twxwindow :initform nil)
	(twxautopix :accessor twautopix :initform nil)
	(twautofont :accessor twautofont :initform nil)
	(IQ :accessor IQ :initform nil)
	(car-x-pos :accessor car-x-pos :initform nil)
	(car-y-pos :accessor car-y-pos :initform nil)
	(queue-x-pos :accessor queue-x-pos :initform nil)
	(queue-y-pos :accessor queue-y-pos :initform  nil)
	(in-use :accessor in-use :initform  nil)
	(delay-factor :accessor delay-factor :initform nil)))

(defclass vacuumer (delayer)
       ((illegal-alien :accessor illegal-alien :initform nil)
	(ashtray-contents :accessor ashtray-contents :initform nil)
	(carwash1-iq :accessor carwash1-iq :initform nil)
	(carwash2-iq :accessor carwash2-iq :initform nil)
	(carwash1-delay :accessor carwash1-delay :initform nil)
	(carwash2-delay :accessor carwash2-delay :initform nil)))

(defclass waxer (delayer) nil)
(defclass carwash (delayer) nil)
(defclass autos (simulator)
     ((ashtray-contents :accessor ashtray-contents :initform nil)))

(defvar autoinstances nil)


(defvar vacuumer1
	(make-instance 'vacuumer
		       :delay-factor   3
		       :illegal-alien  t
		       :carwash1-delay 12
		       :carwash2-delay 2
		       :queue-x-pos    10
		       :queue-y-pos    100
		       :car-x-pos      50
		       :car-y-pos      175))

(defvar waxer1
	(make-instance 'waxer
		       :delay-factor 8
		       :queue-x-pos  400
		       :queue-y-pos  120
		       :car-x-pos    430
		       :car-y-pos    175))

(defvar carwash1
	(make-instance 'carwash
		       :delay-factor 12
		       :queue-x-pos  100
		       :queue-y-pos  10
		       :car-x-pos    200
		       :car-y-pos    80))

(defvar carwash2
	(make-instance 'carwash
		       :delay-factor 2
         	       :queue-x-pos  100
          	       :queue-y-pos  280
          	       :car-x-pos    200
          	       :car-y-pos    205))


(defmethod add-to-queue ((obj delayer) (auto autos))
  "add a new entry to an object's input queue."
  ;;(format t "Adding ~a to ~a's input queue.~%" auto obj)
  (setf (iq obj) (nconc (iq obj) (list auto))))

(defmethod next-iq-entry ((obj delayer))
  "process the next iq entry off of a queue."
  (when (iq obj)
    ;;(format t  "~a on auto ~a~%" obj (car (iq obj)))
    (do-after obj 0.1 `(write-icon ,obj))
    (do-after obj 0.2 `(finish ,obj ,(car (iq obj))))
    (setf (in-use obj) t
	  (iq obj) (cdr (iq obj)))))
(defmethod not-in-use ((obj delayer))
  "This function sets the delayer to not in use."
  (setf (in-use obj) nil))

(defmethod write-icon ((obj delayer))
  "write  the icon to expose or to erase from the screen."

(defmethod finish ((cwash carwash) auto)
  "pass the automobile off to the next position."
  ;;(format t "~a is leaving ~a~%" auto cwash)
  (let ((st (delay-factor cwash)))
    (do-after cwash st `(write-icon ,cwash))
    (do-after waxer1 st `(add-to-queue ,waxer1 ,auto))
    (do-after waxer1 (+ st 0.1) `(next-iq-entry ,waxer1))
    (do-after cwash st `(not-in-use ,cwash))
    (do-after cwash st `(next-iq-entry ,cwash))))
(defmethod leaving-vacuum ((vac vacuumer) (auto autos))
  "This method causes the car to leave the vacuumer."
  ;;(format t "~a leaving vacuum ~a.~%" auto vac)

(defmethod stopped-stealing ((vax vacuumer) (auto autos))
  "indicate to graphics that you are no longer stealing money."
  ;;(format t "~a stopped stealing money from ~a~%" vax auto)	

(defmethod finish ((vac vacuumer) (auto autos))
   ;preschedule getting the carwash queues.
   (let* ((vacst (delay-factor vac))
	  (queue1 (iq carwash1))
	  (queue2 (iq carwash2))
	  (empty-carwash (cond ((in-use carwash1) carwash2)
			       ((in-use carwash2) carwash1)
			      ((> (length queue1) (length queue2))
			      (t carwash1)))
	  (delay nil)
	 (st (delay-factor empty-carwash)))
     (when (and (eq (ashtray-contents auto) 'money)(illegal-alien vac))
       ;;(format t "~a is stealing money from ~a~%" vac auto)
       (do-after vac 0.5 `(stopped-stealing ,vac ,auto)))
     (setq delay (+ st (find-times (if (eq empty-carwash carwash1)
     (do-after empty-carwash vacst `(add-to-queue ,empty-carwash ,auto))
     (do-after empty-carwash delay `(next-iq-entry ,empty-carwash))
     (do-after vac vacst `(leaving-vacuum ,vac ,auto))
     (do-after vac vacst `(next-iq-entry ,vac))
     (do-after vac vacst `(write-icon ,vac))))

(defun find-times (x)
  (if x (length x) 1))

(defmethod finish ((wax waxer) auto)
  ;;(format t "~a is leaving ~a~%" auto wax)
  (let ((st (delay-factor wax)))
     (do-after wax st `(write-icon ,wax))
     (do-after wax st `(next-iq-entry ,wax))))
(defun get-going ()
  (setf (iq vacuumer1) nil
	(things-to-do vacuumer1) nil
	(things-to-do waxer1) nil
	(iq waxer1) nil
	(things-to-do carwash1) nil
	(iq carwash1) nil
	(things-to-do carwash2) nil
	(iq carwash2) nil
	(actors-running *clock*) nil)
  (dolist (auto autoinstances)
    (add-to-queue vacuumer1 auto))
  (next-iq-entry vacuumer1)
  (run *clock*))

;------------------------graphics initialization ---------------------

(defun init-graphics () nil)

(defun generate-cars (n)
  (let ((collection nil))
    (dotimes (i n)
      (push (make-instance 'autos
			   :ashtray-contents (case (rem i 3)
					       (0 'ashes)
					       (1 'gum)
					       (2 'money)))
    (setq autoinstances collection))