1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32 33)package "BOOT" 34 35--% Cache Lambda Facility 36-- for remembering previous values to functions 37 38--to CLAM a function f, there must be an entry on $clamList as follows: 39-- (functionName --the name of the function to be CLAMed (e.g. f) 40-- kind --"hash" or number of values to be stored in 41-- circular list 42-- eqEtc --the equal function to be used 43-- (EQ, EQUAL, UEQUAL,..) 44-- "shift" --(opt) for circular lists, shift most recently 45-- used to front 46-- "count") --(opt) use reference counts (see below) 47-- 48-- Notes: 49-- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL 50-- Functions with some other <identifier> as kind hashed as property 51-- lists with eqEtc used to compare entries 52-- Functions which have 0 arguments may only be CLAMmed when kind is 53-- identifier other than hash (circular/private hashtable for no args 54-- makes no sense) 55-- 56-- Functions which have more than 1 argument must never be CLAMed with EQ 57-- since arguments are cached as lists 58-- For circular lists, "count" will do "shift"ing; entries with lowest 59-- use count are replaced 60-- For cache option without "count", all entries are cleared on garbage 61-- collection; For cache option with "count", 62-- entries have their use count set 63-- to 0 on garbage collection; those with 0 use count at garbage collection 64-- are cleared 65-- see definition of COMP,2 in COMP LISP which calls clamComp below 66 67 68compHash(op, argl, body, cacheName, eqEtc) == 69 70 auxfn := INTERNL1(op, '";") 71 g1:= GENSYM() --argument or argument list 72 [arg,cacheArgKey,computeValue] := 73 -- arg: to be used as formal argument of lambda construction; 74 -- cacheArgKey: the form used to look up the value in the cache 75 -- computeValue: the form used to compute the value from arg 76 null argl => [nil,nil,[auxfn]] 77 argl is [.] => 78 -- we call 'devaluate' only on domains 79 key := maybe_devaluate(g1, first($functor_cosig1)) 80 [[g1],['LIST,key],[auxfn,g1]] --g1 is a parameter 81 -- we call 'devaluate' only on domains 82 all_type := true 83 for c in $functor_cosig1 while all_type repeat 84 all_type := c 85 key := 86 all_type => ['devaluateList, g1] 87 ["devaluate_sig", g1, ["QUOTE", $functor_cosig1]] 88 [g1, key, ['APPLY,['function,auxfn],g1]] --g1 is a parameter list 89 if $reportCounts=true then 90 hitCounter := INTERNL1(op, '";hit") 91 callCounter := INTERNL1(op, '";calls") 92 SET(hitCounter,0) 93 SET(callCounter,0) 94 callCountCode := [['SETQ, callCounter, ['inc_SI, callCounter]]] 95 hitCountCode := [['SETQ, hitCounter, ['inc_SI, hitCounter]]] 96 g2:= GENSYM() --value computed by calling function 97 returnFoundValue:= 98 null argl => 99 -- if we have a global hastable, functions with no arguments are 100 -- stored in the same format as those with several arguments, e.g. 101 -- to cache the value <val> given by f(), the structure 102 -- ((nil <count> <val>)) is stored in the cache 103 ['CDRwithIncrement,['CDAR,g2]] 104 ['CDRwithIncrement,g2] 105 getCode:= 106 null argl => ['HGET,cacheName,MKQ op] 107 ['lassocShiftWithFunction, cacheArgKey, 108 ['HGET, cacheName, MKQ op], MKQ eqEtc] 109 secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue] 110 putCode:= 111 null argl => 112 ['CDDAR, ['HPUT, cacheName, MKQ op, 113 ['LIST, ['CONS, nil, ['CONS, 1, computeValue]]]]] 114 computeValue 115 putCode := 116 ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]], 117 ['COND, [['NOT, g2], ['HREM, cacheName, MKQ op]]]] 118 thirdPredPair:= ['(QUOTE T),putCode] 119 codeBody:= ['PROG,[g2], 120 :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]] 121 lamex:= ['LAMBDA, arg, codeBody] 122 mainFunction:= [op,lamex] 123 computeFunction:= [auxfn,['LAMBDA,argl,:body]] 124 125 -- compile generated function stub 126 compileInteractive mainFunction 127 128 -- compile main body: this has already been compTran'ed 129 if $reportCompilation then 130 sayBrightlyI bright '"Generated LISP code for function:" 131 pp computeFunction 132 compileQuietly computeFunction 133 op 134 135devaluate_sig(tl, cl) == [(c => devaluate(t); t) for t in tl for c in cl] 136 137CDRwithIncrement x == 138 RPLACA(x, inc_SI first x) 139 CDR x 140 141clearClams() == 142 for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat 143 clearClam fn 144 145clearClam fn == 146 infovec := GET(fn, 'cacheInfo) or keyedSystemError("S2GE0003", [fn]) 147 -- eval infovec.cacheReset 148 ir := infovec.cacheReset 149 ir is ["SETQ", var , ['MAKE_HASHTABLE, ["QUOTE", mode]]] => 150 SETF(SYMBOL_-VALUE(var), MAKE_HASHTABLE(mode)) 151 ir is ["SETQ", var , ["initCache", val]] => 152 SETF(SYMBOL_-VALUE(var), initCache(val)) 153 BREAK() 154 155reportAndClearClams() == 156 cacheStats() 157 clearClams() 158 159clear_sorted_caches() == 160 scl := HGET($ConstructorCache, "SortedCache") 161 for [., ., :dom] in scl repeat 162 cc := compiledLookupCheck("clearCache", [$Void], dom) 163 SPADCALL(cc) 164 165clearConstructorCaches() == 166 clear_sorted_caches() 167 clearCategoryCaches() 168 CLRHASH $ConstructorCache 169 170clearConstructorCache(cname) == 171 (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => 172 kind = 'category => clearCategoryCache cname 173 HREM($ConstructorCache,cname) 174 175clearConstructorAndLisplibCaches() == 176 clearClams() 177 clearConstructorCaches() 178 179clearCategoryCaches() == 180 for name in allConstructors() repeat 181 if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then 182 if BOUNDP(cacheName := INTERNL1(PNAME(name), '";AL")) 183 then SET(cacheName,nil) 184 if BOUNDP(cacheName := INTERNL1(PNAME(name), '";CAT")) 185 then SET(cacheName,nil) 186 187clearCategoryCache catName == 188 cacheName := INTERNL1(PNAME(catName), '";AL") 189 SET(cacheName,nil) 190 191displayHashtable x == 192 l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) 193 for [a,b] in l repeat 194 sayBrightlyNT ['%b,a,'%d] 195 pp b 196 197cacheStats() == 198 for [fn,kind,:u] in $clamList repeat 199 not MEMQ('count,u) => 200 sayBrightly ["%b",fn,"%d","does not keep reference counts"] 201 INTEGERP kind => reportCircularCacheStats(fn,kind) 202 kind = 'hash => reportHashCacheStats fn 203 sayBrightly ["Unknown cache type for","%b",fn,"%d"] 204 205reportCircularCacheStats(fn,n) == 206 infovec := GET(fn, 'cacheInfo) 207 circList:= eval infovec.cacheName 208 numberUsed := 209 +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]] 210 sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] 211 displayCacheFrequency mkCircularCountAlist(circList,n) 212 TERPRI() 213 214displayCacheFrequency al == 215 al := NREVERSE SORTBY('CAR,al) 216 sayBrightlyNT " #hits/#occurrences: " 217 for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] 218 TERPRI() 219 220mkCircularCountAlist(cl,len) == 221 for [x,count,:.] in cl for i in 1..len while x ~= '_$failed repeat 222 u:= assoc(count,al) => RPLACD(u,1 + CDR u) 223 if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then 224 sayBrightlyNT [" ",count," "] 225 pp x 226 al:= [[count,:1],:al] 227 al 228 229reportHashCacheStats fn == 230 infovec := GET(fn, 'cacheInfo) 231 hashTable:= eval infovec.cacheName 232 hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] 233 sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] 234 displayCacheFrequency mkHashCountAlist hashValues 235 TERPRI() 236 237mkHashCountAlist vl == 238 for [count,:.] in vl repeat 239 u:= assoc(count,al) => RPLACD(u,1 + CDR u) 240 al:= [[count,:1],:al] 241 al 242 243clearHashReferenceCounts() == BREAK() 244 245remHashEntriesWith0Count $hashTable == BREAK() 246 247initCache n == 248 tail:= '(0 . $failed) 249 l:= [[$failed,:tail] for i in 1..n] 250 RPLACD(LASTNODE l,l) 251 252assocCache(x,cacheName,fn) == 253 --fn=equality function; do not SHIFT or COUNT 254 al:= eval cacheName 255 forwardPointer:= al 256 val:= nil 257 until EQ(forwardPointer,al) repeat 258 FUNCALL(fn, CAAR forwardPointer, x) => 259 return (val := first forwardPointer) 260 backPointer:= forwardPointer 261 forwardPointer := rest forwardPointer 262 val => val 263 SET(cacheName,backPointer) 264 nil 265 266assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular 267 --fn=equality function; SHIFT but do not COUNT 268 al:= eval cacheName 269 forwardPointer:= al 270 val:= nil 271 until EQ(forwardPointer,al) repeat 272 FUNCALL(fn, first(y := first forwardPointer), x) => 273 if not EQ(forwardPointer,al) then --shift referenced entry to front 274 RPLACA(forwardPointer, first al) 275 RPLACA(al,y) 276 return (val:= y) 277 backPointer := forwardPointer -- first is slot replaced on failure 278 forwardPointer := rest forwardPointer 279 val => val 280 SET(cacheName,backPointer) 281 nil 282 283assocCacheShiftCount(x,al,fn) == 284 -- if x is found, entry containing x becomes first element of list; if 285 -- x is not found, entry with smallest use count is shifted to front so 286 -- as to be replaced 287 --fn=equality function; COUNT and SHIFT 288 forwardPointer:= al 289 val:= nil 290 minCount:= 10000 --preset minCount but not newFrontPointer here 291 until EQ(forwardPointer,al) repeat 292 FUNCALL(fn, first(y := first forwardPointer), x) => 293 newFrontPointer := forwardPointer 294 rplac(CADR y, inc_SI CADR y) --increment use count 295 return (val:= y) 296 if less_SI(c := CADR y, minCount) then --initial c is 1 so is true 1st time 297 minCount := c 298 newFrontPointer := forwardPointer -- first is slot replaced on failure 299 forwardPointer:= rest forwardPointer 300 if not EQ(newFrontPointer,al) then --shift referenced entry to front 301 temp := first newFrontPointer --or entry with smallest count 302 RPLACA(newFrontPointer, first al) 303 RPLACA(al,temp) 304 val 305 306clamStats() == 307 for [op,kind,:.] in $clamList repeat 308 cacheVec := GET(op, 'cacheInfo) or systemErrorHere "clamStats" 309 prefix:= 310 $reportCounts~= true => nil 311 hitCounter := INTERNL1(op, '";hit") 312 callCounter := INTERNL1(op, '";calls") 313 res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "] 314 SET(hitCounter,0) 315 SET(callCounter,0) 316 res 317 postString:= 318 cacheValue:= eval cacheVec.cacheName 319 kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"] 320 empties:= numberOfEmptySlots eval cacheVec.cacheName 321 empties = 0 => nil 322 [" (","%b",kind-empties,"/",kind,"%d","slots used)"] 323 sayBrightly 324 [:prefix,op,:postString] 325 326numberOfEmptySlots cache== 327 count:= (CAAR cache ='$failed => 1; 0) 328 for x in tails rest cache while not(EQ(x, cache)) repeat 329 if CAAR x='$failed then count:= count+1 330 count 331 332addToConstructorCache(op,args,value) == 333 ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] 334 335haddProp(ht,op,prop,val) == 336 --called inside functors (except for union and record types ??) 337 --presently, ht always = $ConstructorCache 338 statRecordInstantiationEvent() 339 if $reportInstantiations = true or $reportEachInstantiation = true then 340 startTimingProcess 'debug 341 recordInstantiation(op,prop,false) 342 stopTimingProcess 'debug 343 u:= HGET(ht,op) => --hope that one exists most of the time 344 assoc(prop,u) => val --value is already there--must = val; exit now 345 RPLACD(u, [first u, :rest u]) 346 RPLACA(u,[prop,:val]) 347 $op: local := op 348 listTruncate(u,20) --save at most 20 instantiations 349 val 350 HPUT(ht,op,[[prop,:val]]) 351 val 352 353recordInstantiation(op,prop,dropIfTrue) == 354 startTimingProcess 'debug 355 recordInstantiation1(op,prop,dropIfTrue) 356 stopTimingProcess 'debug 357 358recordInstantiation1(op,prop,dropIfTrue) == 359 op in '(RepeatedSquaring) => nil--ignore defaults for now 360 if $reportEachInstantiation = true then 361 trailer:= (dropIfTrue => '" dropped"; '" instantiated") 362 if $insideCoerceInteractive= true then 363 $instantCoerceCount:= 1+$instantCoerceCount 364 if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then 365 $instantCanCoerceCount:= 1+$instantCanCoerceCount 366 xtra:= 367 ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] 368 if $insideEvalMmCondIfTrue = true and null dropIfTrue then 369 $instantMmCondCount:= $instantMmCondCount + 1 370 typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] 371 null $reportInstantiations => nil 372 u:= HGET($instantRecord,op) => --hope that one exists most of the time 373 v := LASSOC(prop,u) => 374 dropIfTrue => (rplac(CDR v, 1 + CDR v); v) 375 rplac(first v, 1 + first v) 376 v 377 RPLACD(u, [first u, :rest u]) 378 val := 379 dropIfTrue => [0,:1] 380 [1,:0] 381 RPLACA(u,[prop,:val]) 382 val := 383 dropIfTrue => [0,:1] 384 [1,:0] 385 HPUT($instantRecord,op,[[prop,:val]]) 386 387reportInstantiations() == 388 --assumed to be a hashtable with reference counts 389 conList:= 390 [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)] 391 for key in HKEYS $instantRecord] 392 sayBrightly ['"# instantiated/# dropped/domain name", 393 "%l",'"------------------------------------"] 394 nTotal:= mTotal:= rTotal := nForms:= 0 395 for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat 396 nTotal:= nTotal+n; mTotal:= mTotal+m 397 if n > 1 then rTotal:= rTotal + n-1 398 nForms:= nForms + 1 399 typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] 400 sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", 401 '" ",$instantCoerceCount,'" inside coerceInteractive","%l", 402 '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", 403 '" ",$instantMmCondCount,'" inside evalMmCond","%l", 404 '" ",rTotal,'" reinstantiated","%l", 405 '" ",mTotal,'" dropped","%l", 406 '" ",nForms,'" distinct domains instantiated/dropped"] 407 408listTruncate(l,n) == 409 u:= l 410 n := dec_SI n 411 while n ~= 0 and null atom u repeat 412 n := dec_SI n 413 u := QCDR u 414 if null atom u then 415 if null atom rest u and $reportInstantiations = true then 416 recordInstantiation($op,CAADR u,true) 417 RPLACD(u,nil) 418 l 419 420lassocShift(x,l) == 421 y:= l 422 while not atom y repeat 423 EQUAL(x, first QCAR y) => return (result := QCAR y) 424 y:= QCDR y 425 result => 426 if not(EQ(y, l)) then 427 QRPLACA(y, first l) 428 QRPLACA(l,result) 429 QCDR result 430 nil 431 432lassocShiftWithFunction(x,l,fn) == 433 y:= l 434 while not atom y repeat 435 FUNCALL(fn, x, first QCAR y) => return (result := QCAR y) 436 y:= QCDR y 437 result => 438 if not(EQ(y, l)) then 439 QRPLACA(y, first l) 440 QRPLACA(l,result) 441 QCDR result 442 nil 443 444globalHashtableStats(x,sortFn) == 445 --assumed to be a hashtable with reference counts 446 keys:= HKEYS x 447 for key in keys repeat 448 u:= HGET(x,key) 449 for [argList,n,:.] in u repeat 450 not INTEGERP n => keyedSystemError("S2GE0013",[x]) 451 argList1:= [constructor2ConstructorForm x for x in argList] 452 reportList:= [[n,key,argList1],:reportList] 453 sayBrightly ["%b"," USE NAME ARGS","%d"] 454 for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat 455 sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "] 456 pp args 457 458constructor2ConstructorForm x == 459 VECP x => x.0 460 x 461 462rightJustifyString(x,maxWidth) == 463 size:= entryWidth x 464 size > maxWidth => keyedSystemError("S2GE0014",[x]) 465 [fillerSpaces(maxWidth-size,'" "),x] 466 467-- Should be better, but ATM this must do 468domainEqualList(argl1, argl2) == EQUAL(argl1, argl2) 469 470removeAllClams() == 471 for [fun,:.] in $clamList repeat 472 sayBrightly ['"Un-clamming function",'%b,fun,'%d] 473 SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) 474