;;; -*- Mode:LISP; Package:FILE-SYSTEM; Base:10; Readtable:ZL -*-


Observed that a file-server-data-top-level process can get the put-lock
and not give it up somehow when a file is open for write. Then when the
control connection process goes to close the file it cannot, because
the PUT-LOCK is still taken.

Since process-run-function keeps a freelist of processes it could be
possible that some other process actually snarfed the lock,
then went away, then the process-run-function in the file server
happened to get that process from the freelist.

Processes should have a slot for all locks they are taking, and
process reseting and recyling should have error checks to make
sure locks are not kept.

The only operation it does on the local file stream is :STRING-OUT.

The MAP-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER does ALLOCATE-DISK-BLOCK
and :SEND-OUTPUT-BUFFER does
       (USING-PUT
	(CHANGE-BLOCK-DISK-SPACE (+ LOC USED-NPAGES) (- RQB-VALID-PAGES USED-NPAGES)
				 PUT-RESERVED PUT-FREE))


PUT-LOCK: allocate-disk-block locking-recursively

USING-PUT: 
 (:METHOD MAP-OUTPUT-STREAM-MIXIN :NEW-OUTPUT-BUFFER)

 (LM-OUTPUT-STREAM-MIXIN :AFTER :INIT)
  in case of if-exists :APPEND or :OVERWRITE changes mapdisk-space to put-reserved.

(DEFUN SAVE-DIRECTORY-TREE-1 (DO-ALL?)
  (LET ((OLD-MAPS (SAVE-DIRECTORY-SUBTREE (DC-ROOT-DIRECTORY) DO-ALL?)))
    (when OLD-MAPS
      (USING-PUT
	(DOLIST (MAP OLD-MAPS)
	  ;; BUG: If one or more these function calls happens and then an error or abortion
	  ;; happens, then the put is changed, but the root directory is not written.
	  ;; therefore blocks in directories will be marked as free.
	  (CHANGE-MAP-DISK-SPACE MAP PUT-USED PUT-FREE))
	(ASET PUT-CONSISTENT PAGE-USAGE-TABLE 0)
	(LOCKING DISK-CONFIGURATION-LOCK
	  (LM-WRITE-CONFIGURATION))))))

LMFS-WRITE-DIRECTORY
 change-map-disk-space of its new-map to put-used.

LMFS-CLOSE-FILE 
 change-map-disk-space

LMFS-DELETE-FILE, same

LMFS-UNDELETE-FILE, same


LMFS-EXPUNGE-FILE, same

LMFS-OPEN-FILE, in case of IF-EXISTS :TRUNCATE change-map-disk-space



(DEFMACRO USING-PUT (&BODY BODY)
  (LET ((LOCK-OWNED (GENSYM)))
    `(LET ((,LOCK-OWNED (EQ PUT-LOCK CURRENT-PROCESS))
	   OLD-STATE)
       (UNWIND-PROTECT
	 (PROGN
	   (COND ((NOT ,LOCK-OWNED)
		  (PROCESS-LOCK (LOCF PUT-LOCK))
		  (IF (NOT (NULL PUT-MODIFIED))
		      (FERROR NIL "PUT evidently modified while unlocked"))
		  (SETQ OLD-STATE (AREF PAGE-USAGE-TABLE 0))
		  (ASET PUT-INCONSISTENT PAGE-USAGE-TABLE 0)))
	   . ,BODY)
	 (COND ((NOT ,LOCK-OWNED)
		(ASET OLD-STATE PAGE-USAGE-TABLE 0)
		(WRITE-PUT)
		(PROCESS-UNLOCK (LOCF PUT-LOCK))))))))




(DEFMACRO LOCKING-RECURSIVELY (LOCK &BODY BODY)
  "Execute BODY with LOCK locked; don't die if already locked."
  (LET ((LOCK-CELL (GENSYM))
	(LOCK-OWNED (GENSYM)))
    `(LET* ((,LOCK-CELL (LOCF ,LOCK))
	    (,LOCK-OWNED (EQ (CAR ,LOCK-CELL) CURRENT-PROCESS)))
       (UNWIND-PROTECT
	 (PROGN (IF (NOT ,LOCK-OWNED)
		    (PROCESS-LOCK ,LOCK-CELL))
		. ,BODY)
	 (IF (NOT ,LOCK-OWNED)			;unlock it only if you locked it.
	     (%STORE-CONDITIONAL ,LOCK-CELL CURRENT-PROCESS NIL))))))



(DEFMACRO WITH-LOCK (&ENVIRONMENT ENV
		     (LOCATOR &KEY NORECURSIVE (WHOSTATE "Lock" WHOSTATEP) TIMEOUT)
		     &BODY BODY)
  "Execute the BODY with a lock locked.
LOCATOR is an expression whose value is the lock status;
it should be suitable for use inside LOCF.
NORECURSIVE means do not allow locking a lock already locked by this process.
WHOSTATE is what to display if we hang waiting for the lock.
TIMEOUT, if non-NIL, say to signal a SYS:LOCK-TIMEOUT condition if the lock remains
  unavailable for that many 60'ths of a second.  Otherwise, we wait indefinitely."
  (let ((lock (macroexpand `(locf ,locator) env)))
    `(LET* ((.POINTER. ,lock)
	    (.ALREADY.MINE. (EQ (CAR .POINTER.) CURRENT-PROCESS)))
       ;; Kludge due to the fact the fact that the compiler knows nothing about types.
       ;; Common cases which are guaranteed to return locatives.
       ,@(if (memq (car-safe lock) '(variable-location aloc locate-in-instance %instance-loc))
	     ()
	   `((IF (CONSP .POINTER.)
		 (SETQ .POINTER. (CDR-LOCATION-FORCE .POINTER.)))))
       (UNWIND-PROTECT
	   (PROGN
	     (IF .ALREADY.MINE.
		 ,(IF NORECURSIVE `(FERROR "Attempt to lock ~S recursively."
					   ',LOCATOR))
	       ;; Redundant, but saves time if not locked.
	       (OR (%STORE-CONDITIONAL .POINTER. NIL CURRENT-PROCESS)
		   ,(cond (timeout
			   `(process-lock .pointer. nil ,whostate ,timeout))
			  (whostatep
			   `(process-lock .pointer. nil ,whostate))
			  (t
			   `(process-lock .pointer.)))))
	     . ,BODY)
	 (UNLESS .ALREADY.MINE.
	   (%STORE-CONDITIONAL .POINTER. CURRENT-PROCESS NIL))))))





(DEFUN PROCESS-UNLOCK (LOCATIVE-POINTER &OPTIONAL LOCK-VALUE (ERROR-P T))
  "Unlock a lock locked with PROCESS-LOCK.
LOCATIVE-POINTER points to the cell which is the lock."
  (OR LOCK-VALUE (SETQ LOCK-VALUE CURRENT-PROCESS))
  (OR (%STORE-CONDITIONAL LOCATIVE-POINTER LOCK-VALUE NIL)
      (AND ERROR-P
	   (FERROR "Attempt to unlock ~S, which you don't have locked"
		   LOCATIVE-POINTER))))


(DEFUN PROCESS-LOCK (LOCATIVE-POINTER &OPTIONAL LOCK-VALUE (WHOSTATE "Lock")
		     TIMEOUT)
  "Usage of WITH-LOCK is preferable in most cases.
Lock the cell which LOCATIVE-POINTER points to, waiting if it is already locked.
The lock cell contains NIL when not locked;
when locked, it contains the process that locked it.
Does not hack UNWIND-PROTECT, so caller should provide for that.
If TIMEOUT is non-NIL, it is in 60'ths of a second,
and if that much time elapses we signal the SYS:LOCK-TIMEOUT error condition."
  (OR LOCK-VALUE (SETQ LOCK-VALUE CURRENT-PROCESS))
  (DO ((LOCKER (CAR LOCATIVE-POINTER) (CAR LOCATIVE-POINTER)))
      ((%STORE-CONDITIONAL LOCATIVE-POINTER NIL LOCK-VALUE))
    (AND (EQ LOCKER LOCK-VALUE)
	 (FERROR "Lock ~S already locked by this process" LOCATIVE-POINTER))
    (IF TIMEOUT
	(UNLESS
	  (PROCESS-WAIT-WITH-TIMEOUT WHOSTATE TIMEOUT
				     #'(LAMBDA (BAD-CONTENTS POINTER)
					 (NEQ (CONTENTS POINTER) BAD-CONTENTS))
				     LOCKER
				     LOCATIVE-POINTER)
	  (CERROR :NO-ACTION NIL 'SYS:LOCK-TIMEOUT
		  "The ~A ~S remained unavailable for ~D//60 seconds."
		  WHOSTATE LOCATIVE-POINTER TIMEOUT))
      (PROCESS-WAIT WHOSTATE
		    #'(LAMBDA (BAD-CONTENTS POINTER)
			(NEQ (CONTENTS POINTER) BAD-CONTENTS))
		    LOCKER
		    LOCATIVE-POINTER))
    (SETQ TIMEOUT NIL)))