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