(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")

(IL:FILECREATED "16-May-90 12:36:15" IL:|{DSK}<usr>local>lde>lispcore>sources>CLOSURE-CACHE.;2|
 3636   

      IL:|changes| IL:|to:|  (IL:VARS IL:CLOSURE-CACHECOMS)

      IL:|previous| IL:|date:| "24-Jan-88 17:32:55" 
IL:|{DSK}<usr>local>lde>lispcore>sources>CLOSURE-CACHE.;1|)


; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:CLOSURE-CACHECOMS)

(IL:RPAQQ IL:CLOSURE-CACHECOMS

          ((IL:FILES IL:IMPLICIT-KEY-HASH)
           (IL:VARIABLES SI::*CLOSURE-CACHE*)
           (IL:FUNCTIONS SI::GET-CACHE-CLOSURE)
           
           (IL:* IL:|;;| "Utilities ")


           (IL:FUNCTIONS SI::INSTALL-CLOSURE-CACHE SI::DISABLE-CLOSURE-CACHE)
           (IL:FUNCTIONS SI::CLEAR-CLOSURE-CACHE SHOW-CLOSURE-CACHE)
           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (
                                                                            SI::INSTALL-CLOSURE-CACHE
                                                                               )))
           (FILE-ENVIRONMENTS "CLOSURE-CACHE")))

(IL:FILESLOAD IL:IMPLICIT-KEY-HASH)

(DEFVAR SI::*CLOSURE-CACHE*
 (MAKE-IMPLICIT-KEY-HASH-TABLE 64 :FIRST))

(DEFUN SI::GET-CACHE-CLOSURE
 (CODE-BLOCK)
   (LET ((CLOSURE (GET-IMPLICIT-KEY-HASH CODE-BLOCK SI::*CLOSURE-CACHE*)))
        (OR CLOSURE (LET ((NEW-CLOSURE (IL:|create|
 IL:COMPILED-CLOSURE)))
                         (IL:UNINTERRUPTABLY
                             
                             (IL:* IL:|;;| "A Non-refcount set of the fnheader field")


                             (IL:FREPLACEFIELD '(IL:COMPILED-CLOSURE 0 IL:XPOINTER)
                                    NEW-CLOSURE CODE-BLOCK)

                             (IL:* IL:|;;| "Cache the closure")


                             (SETF (GET-IMPLICIT-KEY-HASH CODE-BLOCK SI::*CLOSURE-CACHE*)
                                   NEW-CLOSURE))
                         NEW-CLOSURE))))



(IL:* IL:|;;| "Utilities ")



(DEFUN SI::INSTALL-CLOSURE-CACHE
 ()
   (IF (NULL SI::*CLOSURE-CACHE-ENABLED*)
       (IL:UNINTERRUPTABLY
           (SETQ SI::*CLOSURE-CACHE-ENABLED* T))))

(DEFUN SI::DISABLE-CLOSURE-CACHE
 ()
   (IF SI::*CLOSURE-CACHE-ENABLED*
       (IL:UNINTERRUPTABLY
           
           (IL:* IL:|;;| "Shut off caching")


           (SETQ SI::*CLOSURE-CACHE-ENABLED* NIL)

           (IL:* IL:|;;| "clear cache")


           (SI::CLEAR-CLOSURE-CACHE)
           T)))

(DEFUN SI::CLEAR-CLOSURE-CACHE
 ()
   (IL:UNINTERRUPTABLY
       (IMPLICIT-KEY-MAP-HASH #'(LAMBDA (BLOCK CLOSURE)

                                       (IL:* IL:|;;| "Make the pointer to block from closure real")


                                       (IL:\\ADDREF BLOCK))
              SI::*CLOSURE-CACHE*)
       (CLEAR-IMPLICIT-KEY-HASH SI::*CLOSURE-CACHE*)))

(DEFUN SHOW-CLOSURE-CACHE
 (&OPTIONAL (LONG-P NIL)
                                     (STREAM T))
   (IMPLICIT-KEY-MAP-HASH #'(LAMBDA (VAL KEY)
                                   (IF LONG-P (FORMAT STREAM "Code block: ~s~%" KEY))
                                   (FORMAT STREAM "Closure: ~s~%" VAL)
                                   (IF LONG-P (TERPRI STREAM)))
          SI::*CLOSURE-CACHE*))
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY 

(SI::INSTALL-CLOSURE-CACHE)
)

(DEFINE-FILE-ENVIRONMENT "CLOSURE-CACHE"
 :READTABLE "XCL"
   :PACKAGE "XCL"
   :COMPILER :COMPILE-FILE)
(IL:PUTPROPS IL:CLOSURE-CACHE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL)))
IL:STOP