-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are -- met: -- -- - Redistributions of source code must retain the above copyright -- notice, this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in -- the documentation and/or other materials provided with the -- distribution. -- -- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. import g_-timer namespace BOOT --% Cache Lambda Facility -- for remembering previous values to functions --to CLAM a function f, there must be an entry on $clamList as follows: -- (functionName --the name of the function to be CLAMed (e.g. f) -- kind --"hash" or number of values to be stored in -- circular list -- eqEtc --the equal function to be used -- (EQ, EQUAL, UEQUAL,..) -- "shift" --(opt) for circular lists, shift most recently -- used to front -- "count") --(opt) use reference counts (see below) -- -- Notes: -- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL -- Functions with some other as kind hashed as property -- lists with eqEtc used to compare entries -- Functions which have 0 arguments may only be CLAMmed when kind is -- identifier other than hash (circular/private hashtable for no args -- makes no sense) -- -- Functions which have more than 1 argument must never be CLAMed with EQ -- since arguments are cached as lists -- For circular lists, "count" will do "shift"ing; entries with lowest -- use count are replaced -- For cache option without "count", all entries are cleared on garbage -- collection; For cache option with "count", -- entries have their use count set -- to 0 on garbage collection; those with 0 use count at garbage collection -- are cleared ++ $clamList == '((canCoerce hash UEQUAL count) _ (canCoerceFrom hash UEQUAL count) _ (coerceConvertMmSelection hash UEQUAL count) _ (isLegitimateMode hash UEQUAL count) _ (isValidType hash UEQUAL count) _ (resolveTT hash UEQUAL count) _ (selectMms1 hash UEQUAL count) _ (underDomainOf hash UEQUAL count)) ++ $failed := '"failed" CDRwithIncrement x == x.first := first x + 1 rest x clearClams() == for [fn,kind,:.] in $clamList | kind = 'hash or integer? kind repeat clearClam fn clearClam fn == infovec := property(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) eval infovec.cacheReset reportAndClearClams() == cacheStats() clearClams() clearConstructorCaches() == clearCategoryCaches() CLRHASH $ConstructorCache clearConstructorCache(cname) == (kind := getConstructorKindFromDB cname) => kind = "category" => clearCategoryCache cname tableRemove!($ConstructorCache,cname) clearConstructorAndLisplibCaches() == clearClams() clearConstructorCaches() clearCategoryCaches() == for name in allConstructors() repeat if getConstructorKindFromDB name = "category" then if symbolGlobal?(cacheName:= mkCacheName name) then symbolValue(cacheName) := nil db := constructorDB name => dbTemplate(db) := nil clearCategoryCache catName == symbolValue(mkCacheName catName) := nil displayHashtable x == l := sortBy(function first,[[opOf val,key] for [key,:val] in entries x]) for [a,b] in l repeat sayBrightlyNT ['"%b",a,'"%d"] pp b cacheStats() == for [fn,kind,:u] in $clamList repeat not ('count in u) => sayBrightly ["%b",fn,"%d","does not keep reference counts"] integer? kind => reportCircularCacheStats(fn,kind) kind = 'hash => reportHashCacheStats fn sayBrightly ["Unknown cache type for","%b",fn,"%d"] reportCircularCacheStats(fn,n) == infovec:= property(fn,'cacheInfo) circList:= eval infovec.cacheName numberUsed := +/[1 for i in 1..n for x in circList while x isnt ['_$failed,:.]] sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] displayCacheFrequency mkCircularCountAlist(circList,n) finishLine $OutputStream displayCacheFrequency al == al := sortBy(function first,al) sayBrightlyNT " #hits/#occurrences: " for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] finishLine $OutputStream mkCircularCountAlist(cl,len) == for [x,count,:.] in cl for i in 1..len while x ~= '_$failed repeat u:= assoc(count,al) => u.rest := 1 + rest u if integer? $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then sayBrightlyNT [" ",count," "] pp x al:= [[count,:1],:al] al reportHashCacheStats fn == infovec:= property(fn,'cacheInfo) ht := eval infovec.cacheName hashValues:= [val for [.,:val] in entries ht] sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] displayCacheFrequency mkHashCountAlist hashValues finishLine $OutputStream mkHashCountAlist vl == for [count,:.] in vl repeat u:= assoc(count,al) => u.rest := 1 + rest u al:= [[count,:1],:al] al clamStats() == for [op,kind,:.] in $clamList repeat cacheVec:= property(op,'cacheInfo) or systemErrorHere ["clamStats",op] postString:= cacheValue:= eval cacheVec.cacheName kind = 'hash => [" (","%b",tableLength cacheValue,"%d","entries)"] empties:= numberOfEmptySlots eval cacheVec.cacheName empties = 0 => nil [" (","%b",kind-empties,"/",kind,"%d","slots used)"] sayBrightly [op,:postString] numberOfEmptySlots cache== count:= (CAAR cache ='$failed => 1; 0) for x in tails rest cache while not sameObject?(x,cache) repeat if CAAR x='$failed then count:= count+1 count addToConstructorCache(op,args,value) == ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] haddProp(ht,op,prop,val) == --presently, ht always = $ConstructorCache statRecordInstantiationEvent() if $reportInstantiations or $reportEachInstantiation then startTimingProcess 'debug recordInstantiation(op,prop,false) stopTimingProcess 'debug u:= tableValue(ht,op) => --hope that one exists most of the time assoc(prop,u) => val --value is already there--must = val; exit now u.rest := [first u,:rest u] u.first := [prop,:val] $op: local := op listTruncate(u,20) --save at most 20 instantiations val tableValue(ht,op) := [[prop,:val]] val recordInstantiation(op,prop,dropIfTrue) == startTimingProcess 'debug recordInstantiation1(op,prop,dropIfTrue) stopTimingProcess 'debug recordInstantiation1(op,prop,dropIfTrue) == if $reportEachInstantiation then trailer:= (dropIfTrue => '" dropped"; '" instantiated") if $insideCoerceInteractive= true then $instantCoerceCount:= 1+$instantCoerceCount if $insideCanCoerceFrom is [m1,m2] and not dropIfTrue then $instantCanCoerceCount:= 1+$instantCanCoerceCount xtra:= ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] if $insideEvalMmCondIfTrue and not dropIfTrue then $instantMmCondCount:= $instantMmCondCount + 1 typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] not $reportInstantiations => nil u:= tableValue($instantRecord,op) => --hope that one exists most of the time v := LASSOC(prop,u) => dropIfTrue => v.rest := 1+rest v v.first := 1+first v u.rest := [first u,:rest u] val := dropIfTrue => [0,:1] [1,:0] u.first := [prop,:val] val := dropIfTrue => [0,:1] [1,:0] tableValue($instantRecord,op) := [[prop,:val]] reportInstantiations() == --assumed to be a hashtable with reference counts conList:= [:[[n,m,[key,:argList]] for [argList,n,:m] in item] for [key,:item] in entries $instantRecord] sayBrightly ['"# instantiated/# dropped/domain name", "%l",'"------------------------------------"] nTotal:= mTotal:= rTotal := nForms:= 0 for [n,m,form] in sortBy(function third,conList) repeat nTotal:= nTotal+n; mTotal:= mTotal+m if n > 1 then rTotal:= rTotal + n-1 nForms:= nForms + 1 typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", '" ",$instantCoerceCount,'" inside coerceInteractive","%l", '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", '" ",$instantMmCondCount,'" inside evalMmCond","%l", '" ",rTotal,'" reinstantiated","%l", '" ",mTotal,'" dropped","%l", '" ",nForms,'" distinct domains instantiated/dropped"] listTruncate(l,n) == u:= l n:= n - 1 while n ~= 0 and cons? u repeat n := n - 1 u := rest u if cons? u then if cons? rest u and $reportInstantiations then recordInstantiation($op,CAADR u,true) u.rest := nil l lassocShiftWithFunction(x,l,fn) == y:= l while cons? y repeat apply(fn,[x,first first y]) => return (result := first y) y:= rest y result => if not sameObject?(y,l) then y.first := first l l.first := result rest result nil rightJustifyString(x,maxWidth) == size:= entryWidth x size > maxWidth => keyedSystemError("S2GE0014",[x]) [fillerSpaces(maxWidth-size,char " "),x] domainEqualList(argl1,argl2) == --function used to match argument lists of constructors while argl1 and argl2 repeat item1:= devaluate first argl1 item2:= first argl2 partsMatch:= item1 = item2 => true false not partsMatch => return nil argl1:= rest argl1; argl2 := rest argl2 argl1 or argl2 => nil true removeAllClams() == for [fun,:.] in $clamList repeat sayBrightly ['"Un-clamming function",'"%b",fun,'"%d"] symbolValue(fun) := eval makeSymbol strconc(STRINGIMAGE fun,'";")