Merge branch 'master' of git@github.com:bvds/andes

Base/match.cl

@@ -115,7 +115,8 @@
   (cond 
     ((stringp model) model)
     ((or (stringp (car model)) (listp (car model)))
-     (join-words (remove nil (mapcar #'word-string model))))
+     ;; mapcar copies list; subsequent operations can be destructive
+     (join-words (delete nil (mapcar #'word-string model))))
     ((eql (car model) 'and)
      (when (cdr model) (word-string (cdr model))))
     ((eql (car model) 'or)
@@ -125,14 +126,15 @@
     ((eql (car model) 'conjoin)
      (pop model)
      (let ((conjunction (word-string (car model)))
-	   (items (remove nil (mapcar #'word-string (cdr model)))))
+	   ;; mapcar copies list; subsequent operations can be destructive
+	   (items (delete nil (mapcar #'word-string (cdr model)))))
        (cond 
 	 ((null conjunction)
 	  (warn "conjoin must have conjunction ~A" model)
 	  (join-words items))
 	 ((cdr items) 
 	  ;; doesn't add commas, as it should, when (cdr (butlast items))
-	  (join-words (append (butlast items) 
+	  (join-words (nconc (butlast items) 
 			      (list conjunction) (last items))))
 	 (t (car items)))))
     ((eql (car model) 'allowed) nil)
@@ -323,7 +325,7 @@
     ;; there are m! (m+n-1)!/(n! (m-1)!) different possible matches.
     (update-bound best (match-model-slow 
 			matches model-free 
-			(list (list 0 (length student)))))
+			(list (cons 0 (length student)))))
 
     )
 
@@ -401,7 +403,7 @@
   (if model-free
       (let ((best 20000))
 	(dolist (interval student-intervals)
-	  (let ((lower (first interval)) (upper (second interval)))
+	  (let ((lower (car interval)) (upper (cdr interval)))
 	    (do ((y lower (1+ y)))
 		((= y (1+ upper))) 
 	      (do ((z lower (1+ z)))
@@ -412,8 +414,8 @@
 		(when (aref matches (car model-free) y z) 
 		  ;; remove best fit interval and add new intervals
 		  (let ((new-student (remove interval student-intervals)))
-		    (push (list (first interval) z) new-student)
-		    (push (list y (second interval)) new-student)
+		    (push (cons lower z) new-student)
+		    (push (cons y upper) new-student)
 		    (update-bound 
 		     best 
 		     (+ (aref matches (car model-free) y z) 
@@ -424,7 +426,7 @@
 					  new-student)))))))))
 	  best)
 	;; count remaining student words
-      (apply #'+ (mapcar #'(lambda (x) (- (second x) (first x))) 
+      (reduce #'+ (mapcar #'(lambda (x) (- (cdr x) (car x))) 
 			 student-intervals))))
 
 (defun match-model-conjoin (student model &key best)
@@ -482,8 +484,9 @@
       ;; (format webserver:*stdout* "      Got ~A for match to ~A~%" this (car x))
       (when (< this bound) (push (cons this (cdr x)) quants))
       (when (< this best) (setf best this)))
-    ;; remove any quantities that are not equivalent with best fit. 
-    (remove-if #'(lambda (x) (> (car x) (* best equiv))) quants)))
+    ;; remove any quantities that are not equivalent with best fit
+    ;; and return result. 
+    (delete-if #'(lambda (x) (> (car x) (* best equiv))) quants)))
 
 
 (defun normalized-levenshtein-distance (s1 s2)
@@ -506,6 +509,7 @@
 	  ((= 0 m) (return-from levenshtein-distance n)))
     (let ((col (make-array (1+ m) :element-type 'integer))
 	  (prev-col (make-array (1+ m) :element-type 'integer)))
+      (declare (dynamic-extent col prev-col))
       ;; We need to store only two columns---the current one that
       ;; is being built and the previous one
       (dotimes (i (1+ m))

Base/web-server.cl

@@ -24,7 +24,7 @@
   (:use :cl :hunchentoot :json)
   (:export :defun-method :start-json-rpc-service :stop-json-rpc-service 
 	   :*stdout* :print-sessions :*env* :close-idle-sessions :*debug*
-	   :get-session-env :*log-id*))
+	   :*debug-alloc* :get-session-env :*log-id*))
 
 (in-package :webserver)
 
@@ -34,7 +34,19 @@
 (defvar *stdout* *standard-output*)
 (defvar *service-methods* (make-hash-table :test #'equal))
 
-(defvar *debug* t "Special error conditions for debugging")
+(defparameter *debug* t "Special error conditions for debugging")
+(defparameter *debug-alloc* nil "Turn on memory profiling.")
+#+sbcl (eval-when (:load-toplevel :compile-toplevel)
+	 (require :sb-sprof))
+(defvar *print-lock*  (or #+sbcl (sb-thread:make-mutex)
+			  #+bordeaux-threads 
+			  (bordeaux-threads:make-lock)))
+
+(defmacro with-a-lock (args &body body)
+  "Choose method for setting mutex"
+  (or #+sbcl `(sb-thread:with-mutex ,args ,@body)
+      #+bordeaux-threads `(bordeaux-threads:with-lock-held ,@body)
+      '(error "no thread locking, possible race condition")))
 
 (defun start-json-rpc-service (uri &key (port 8080) log-function
 			       server-log-path)
@@ -104,8 +116,12 @@
 			       *service-methods*))
 	 reply)
 
-    (when *debug* (format *stdout* "session ~A calling ~A with~%     ~S~%" 
-			  client-id method params))
+    (when *debug* (with-a-lock (*print-lock* :wait-p t) 
+		    (format *stdout* "session ~A calling ~A with~%     ~S~%" 
+			    client-id method params)))
+    #+sbcl (when *debug-alloc* 
+	     (sb-sprof:start-profiling 
+	      :mode :alloc :threads (list sb-thread:*current-thread*)))
 
     (multiple-value-bind (result error1)
 	(cond
@@ -143,8 +159,11 @@
 	  ;; match the function...
 	  (t (execute-session client-id turn method-func params)))
 
-      (when *debug* 
-	(format *stdout* "result ~S~%~@[error ~S~%~]" result error1))
+      #+sbcl (when *debug-alloc* (sb-sprof:stop-profiling))
+      (when *debug* (with-a-lock (*print-lock* :wait-p t) 
+		      (format *stdout* 
+			      "session ~a result~%     ~S~%~@[     error ~S~%~]" 
+			      client-id result error1)))
 
       ;; only give a response when there is an error or id is given
       (when (or error1 turn)
@@ -242,7 +261,7 @@
 				 #+bordeaux-threads 
 				 (bordeaux-threads:make-lock))))))
 
-(defun close-idle-sessions (&key (idle 7200) (method #'identity) params)
+(defun close-idle-sessions (&key (idle 0) (method #'identity) params)
   "Apply method to all (idle) sessions.  idle is time in seconds."
   (let ((cutoff (- (get-internal-real-time) 
 		   (* idle internal-time-units-per-second))))
@@ -272,12 +291,6 @@
 (defun hung-session-error ()
   (error "Help system running for too long, killing turn."))
 
-(defmacro with-a-lock (args &body body)
-  "Choose method for setting mutex"
-  (or #+sbcl `(sb-thread:with-mutex ,args ,@body)
-      #+bordeaux-threads `(bordeaux-threads:with-lock-held ,@body)
-      '(error "no thread locking, possible race condition")))
-
 (defun lock-session (session turn)
   "Attempt to lock a session; return a result or error if unsuccessful."
   ;; If previous attempt at this turn is still locked, give it

Help/State.cl

@@ -177,10 +177,14 @@
 (defun do-close-problem ()
    ;; empty symbol table and entry list
    (empty-symbol-table)
+   (fill **grammar** nil) ;shallow dereference, for garbage collection
    (setf **grammar** nil)
-   (setq *StudentEntries* nil)
+   (fill *StudentEntries* nil) ;shallow dereference, for garbage collection
+   (setf *StudentEntries* nil)
 
    ;; unload current problem with its sgraph structures
+   ;; Garbage collection for problems may be complicated,
+   ;; since it may use stuff that is shared across problems
    (setf *cp* NIL)
 
    ;; Set the current problem instance time from the universal time.

Help/nlg.cl

@@ -452,7 +452,8 @@
 	 (let ((args (expand-vars (cdr model))))
 	   (when args (cons (car model) args))))
 	((or (stringp (car model)) (listp (car model))) ;plain list
-	 (remove nil (mapcar #'expand-vars model)))
+	 ;; mapcar copies list; subsequent operations can be destructive
+	 (delete nil (mapcar #'expand-vars model)))
 	;; expansion of var must be done at run-time.
 	((eql (car model) 'var)
 	 (apply #'symbols-label (cdr model)))

Help/sessions.cl

@@ -133,7 +133,7 @@
 	  ;; Variables used for scoring in Help/RunTimeTest.cl
           *Runtime-Testset* *Runtime-Score-Testset*
 	  *Runtime-testset-current-Solindex*
-	  *Runtime-Testset-current-total-score*
+	  *Runtime-Testset-current-total-score* **Checking-entries**
 	  ;; Variables holding session-local memos.
 	  *parse-memo* *grammar-get-rhs-memo* *grammar-get-rhs-with-first*
 	  ;; Cache variables in Testcode/Tests.cl
@@ -148,7 +148,9 @@
 	)
 
 ;; New method with 
-(defstruct help-env "Quantities that must be saved between turns of a session.  Member vals contains list of values for help-env-vars." 
+;; Use type vector to make dereferencing easy.
+(defstruct help-env ; (help-env (:type vector)) 
+  "Quantities that must be saved between turns of a session.  Member vals contains list of values for help-env-vars." 
 	   section student problem vals)
 
 ;; Should be useful for debugging.
@@ -187,7 +189,7 @@
     `(progn
       ;; Null webserver:*env* indicates that the student is trying to work
       ;; on a session that has timed out or has not been initialized:  
-      (if (and webserver:*env* (help-env-p webserver:*env*))
+      (if (and webserver:*env* (help-env-p webserver:*env*)) ;(vectorp webserver:*env*))
 	  (let ,(mapcar 
 		 #'(lambda (x) (list x '(pop (help-env-vals webserver:*env*))))
 		 help-env-vars)
@@ -243,6 +245,9 @@
       ;; need to make the session-local copy first. 
       (session-local-runtime-testset)
 
+      ;; Used by some Runtime tests
+      (setf **checking-entries** nil)
+
       ;; Andes2 had the following calls that can be found in log files:
       ;;   read-student-info; the only remaining step is:
       (Load-Config-File)			
@@ -724,8 +729,33 @@
 		  (:URL . "http://www.webassign.net/something/or/other"))
 		result)
 	  result))
+    (fill (help-env-vals webserver:*env*) nil)
+;    (fill webserver:*env* nil)
+;    (dereference webserver:*env*)
+
     ;; Tell the session manager that the session is over.
     ;; Must be done after env-wrap
     (setf webserver:*env* nil)))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *dereferenced*) ;define symbol, but don't bind
+
+(defun dereference (x)
+  (cond 
+    ((or (stringp x) (symbolp x) (numberp x)))
+    ((consp x)
+     (dereference (car x)) (setf (car x) '*dereferenced*)
+     (dereference (cdr x)) (setf (cdr x) '*dereferenced*))
+    ((vectorp x)
+     (loop for y across x do (dereference y) (setf y '*dereferenced*)))
+    ;; Most structures are hard to think about, since
+    ;; data may be shared across problems and they are 
+    ;; hard to derefernce.
+    ((or (runtime-test-p x) (htime-p x) (turn-p x) (cmd-p x)
+	 (Enode-p x) (SystemEntry-p x) 
+	 (MT19937:random-state-p x) ;random number generator seed
+	 #+sbcl (sb-ext:process-p x))) ;solver process
+    (t
+     (format webserver:*stdout* "unknown type ~A for ~A~%" (type-of x) x))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Help/symbols.cl

@@ -141,6 +141,7 @@
   (setf (cdr (get-variables-table x)) new-variables))
 
 (defun empty-symbol-table ()
+    (fill *variables* nil) ;shallow dereference, for garbage collection
     (setf *variables* (mapcar #'list *variable-namespaces*)))
 
 ;;-----------------------------------------------------------------------------

HelpStructs/RuntimeTest.cl

@@ -404,7 +404,7 @@
 ;;; to the help system.  If it is t then any entry that comes in is
 ;;; assumed to be a saved entry that is being sent automatically.  If
 ;;; it is nil then it is assumed to be a user entry.
-(defparameter **Checking-Entries** Nil)
+(defvar **Checking-Entries** Nil)
 
 ;;; Iterate over the tests funcalling their funcs to set the new scores.
 ;;; Each func is assumed to take a single argument which is the current 

HelpStructs/StudentEntry.cl

@@ -83,7 +83,7 @@
 
 ;; There must be a better place for this declaration.
 ;; It should probably be set to either nil or webserver:*stdout*
-(defvar *debug-help* t "The stream showing help system runtime activities.")
+(defvar *debug-help* nil "The stream showing help system runtime activities.")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Student entry list functions.

Knowledge/Problem.cl

@@ -648,7 +648,8 @@
     (cond ((null times) '("Let T0 be the time."))
 	  ((eql times 'none) nil)
 	  ((listp (problem-times problem))
-	   (remove nil (mapcar #'problem-time-english times)))
+	   ;; mapcar copies list; subsequent operations can be destructive
+	   (delete nil (mapcar #'problem-time-english times)))
 	  (t (warn "Invalid time specifications ~A" times)))))
 
 (defun problem-time-english (time)

LogProcessing/databaseCreationScripts/delete_test_database.sql

@@ -0,0 +1,6 @@
+/* This Script removes all the Entries in the two Tables of the Test DataBase */
+
+USE 'andes_test';
+
+DELETE FROM PROBLEM_ATTEMPT;
+DELETE FROM PROBLEM_ATTEMPT_TRANSACTION;