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
35reportFunctionCompilation(op,nam,argl,body,isRecursive) ==
36  -- for an alternate definition of this function which does not allow
37  -- dynamic caching, see SLAMOLD BOOT
38--+
39  $compiledOpNameList := [nam]
40  minivectorName := makeInternalMapMinivectorName(nam)
41  body := substitute(minivectorName, "$$$", body)
42  SET(minivectorName,LIST2REFVEC $minivector)
43  argl := COPY argl     -- play it safe for optimization
44  init :=
45    not(isRecursive and $compileRecurrence and #argl = 1) => nil
46    NRTisRecurrenceRelation(nam,body,minivectorName)
47  init => compileRecurrenceRelation(op,nam,argl,body,init)
48  cacheCount:= getCacheCount op
49  cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body)
50  cacheCount = 0 or null argl =>
51    function:= [nam,['LAMBDA,[:argl,'envArg],body]]
52    compileInteractive function
53    nam
54  num :=
55    FIXP cacheCount =>
56      cacheCount < 1 =>
57        keyedSystemError("S2IM0019",[cacheCount,op])
58      cacheCount
59    keyedSystemError("S2IM0019",[cacheCount,op])
60  sayKeyedMsg("S2IX0003",[op,num])
61  auxfn := mkAuxiliaryName nam
62  g1:= GENSYM()  --argument or argument list
63  [arg,computeValue] :=
64    null argl => [nil,[auxfn]]
65    argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]]  --g1 is a parameter
66    [g1, ['APPLY, MKQ auxfn, g1]]          --g1 is a parameter list
67  cacheName := mkCacheName nam
68  g2:= GENSYM()  --length of cache or arg-value pair
69  g3:= GENSYM()  --value computed by calling function
70  secondPredPair:=
71    null argl => [cacheName]
72    [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]]
73  thirdPredPair:=
74    null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]]
75    ['(QUOTE T),
76      ['SETQ,g2,computeValue],
77        ['SETQ,g3,
78            ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]],
79          ['RPLACA,g3,g1],
80            ['RPLACD,g3,g2],
81              g2]
82  codeBody:=
83    ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]]
84  -- cannot use envArg in next statement without redoing much
85  -- of above.
86  lamex:= ['LAMBDA, arg, codeBody]
87  mainFunction:= [nam,lamex]
88  computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]]
89  compileInteractive mainFunction
90  compileInteractive computeFunction
91  cacheType:= 'function
92  cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]]
93  cacheCountCode:= ['countCircularAlist,cacheName,cacheCount]
94  cacheVector:=
95    mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode)
96  $e:= put(nam,'cacheInfo, cacheVector,$e)
97  eval cacheResetCode
98  SET(cacheName,mkCircularAlist cacheCount)
99  nam
100
101getCacheCount fn ==
102  n:= LASSOC(fn,$cacheAlist) => n
103  $cacheCount
104
105reportFunctionCacheAll(op,nam,argl,body) ==
106  sayKeyedMsg("S2IX0004",[op])
107  auxfn:= mkAuxiliaryName nam
108  g1:= GENSYM()  --argument or argument list
109  [arg,computeValue] :=
110    null argl => [['envArg],[auxfn, 'envArg]]
111    argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]]  --g1 is a parameter
112    [g1, ['APPLY, MKQ auxfn, g1]]          --g1 is a parameter list
113  if null argl then g1:=nil
114  cacheName:= mkCacheName nam
115  g2:= GENSYM()  --value computed by calling function
116  secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2]
117  thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]]
118  codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]]
119  lamex:= ['LAMBDA, arg, codeBody]
120  mainFunction:= [nam,lamex]
121  computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]]
122  compileInteractive mainFunction
123  compileInteractive computeFunction
124  cacheType:= 'hash_-table
125  cacheResetCode := ['SETQ, cacheName, ['MAKE_HASHTABLE, ''UEQUAL]]
126  cacheCountCode:= ['hashCount,cacheName]
127  cacheVector:=
128    mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode)
129  $e:= put(nam,'cacheInfo, cacheVector,$e)
130  eval cacheResetCode
131  nam
132
133hashCount table ==
134  +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table]
135
136mkCircularAlist n ==
137  l:= [[$failed,:$failed] for i in 1..n]
138  RPLACD(LASTNODE l,l)
139
140countCircularAlist(cal,n) ==
141  +/[nodeCount x for x in cal for i in 1..n]
142
143predCircular(al,n) ==
144  for i in 1..dec_SI n repeat al := QCDR al
145  al
146
147assocCircular(x,al) ==  --like ASSOC except that al is circular
148  forwardPointer:= al
149  val:= nil
150  until EQ(forwardPointer,al) repeat
151    EQUAL(CAAR forwardPointer,x) => return (val := first forwardPointer)
152    forwardPointer := rest forwardPointer
153  val
154
155compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) ==
156  k:= #initCode
157  extraArgumentCode :=
158    extraArguments := [x for x in argl | x ~= sharpArg] =>
159      extraArguments is [x] => x
160      ['LIST,:extraArguments]
161    nil
162  g:= GENSYM()
163  gIndex:= GENSYM()
164  gsList:= [GENSYM() for x in initCode]
165  auxfn := mkAuxiliaryName(nam)
166  $compiledOpNameList := [:$compiledOpNameList,auxfn]
167  stateNam:= GENVAR()
168  stateVar:= GENSYM()
169  stateVal:= GENSYM()
170  lastArg := INTERNL1('"#", STRINGIMAGE(inc_SI(LENGTH(argl))))
171  decomposeCode:=
172    [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]]
173      for g in gsList for i in 1..]]
174  gsRev:= REVERSE gsList
175  rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]]
176  advanceCode:= ['LET,gIndex,['ADD1,gIndex]]
177
178  newTripleCode := ['LIST,sharpArg,:gsList]
179  newStateCode :=
180    null extraArguments => ['SETQ,stateNam,newTripleCode]
181    ['HPUT,stateNam,extraArgumentCode,newTripleCode]
182
183  computeFunction:= [auxfn,['LAMBDA, cargl, cbody]] where
184    cargl:= [:argl,lastArg]
185    returnValue:= ['PROGN,newStateCode,first gsList]
186    cbody:=
187      endTest:=
188        ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]]
189      newValueCode := ['LET, g, substitute(gIndex, sharpArg,
190        EQSUBSTLIST(gsList,rest $TriangleVariableList,body))]
191      ['PROGN,:decomposeCode,
192        ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode,
193          newValueCode,:rotateCode]]]
194  fromScratchInit:=
195    [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]]
196  continueInit:=
197    [['LET,gIndex,['ELT,stateVar,0]],
198      :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]]
199  mainFunction:= [nam,['LAMBDA, margl, mbody]] where
200    margl:= [:argl,'envArg]
201    max:= GENSYM()
202    tripleCode := ['CONS,n,['LIST,:initCode]]
203
204    -- initialSetCode initializes the global variable if necessary and
205    --  also binds "stateVar" to its current value
206    initialSetCode :=
207      initialValueCode :=
208        extraArguments => ['MAKE_HASHTABLE, ''UEQUAL]
209        tripleCode
210      cacheResetCode := ['SETQ,stateNam,initialValueCode]
211      ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _
212                          ['PAIRP,stateNam]]],    _
213                 ['LET,stateVar,cacheResetCode]], _
214             [''T, ['LET,stateVar,stateNam]]]
215
216    -- when there are extra arguments, initialResetCode resets "stateVar"
217    --  to the hashtable entry for the extra arguments
218    initialResetCode :=
219      null extraArguments => nil
220      [['LET,stateVar,['OR,
221         ['HGET,stateVar,extraArgumentCode],
222          ['HPUT,stateVar,extraArgumentCode,tripleCode]]]]
223
224    mbody :=
225      preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]]
226      phrase1:= [['AND, ['LET, max, ['ELT, stateVar, 0]],
227                      [">=", sharpArg, max]], [auxfn,:argl,stateVar]]
228      phrase2:= [[">", sharpArg, ['SETQ, max, ["-", max, k]]],
229                  ['ELT, stateVar, ['inc_SI,
230                    ['sub_SI, k, ["-", sharpArg, max]]]]]
231      phrase3:= [[">", sharpArg, n], [auxfn, :argl, ['LIST, n, :initCode]]]
232      phrase4:= [[">", sharpArg, n - k],
233        ['ELT, ['LIST, :initCode], ['sub_SI, n, sharpArg]]]
234      phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]]
235      ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]]
236  sayKeyedMsg("S2IX0001",[op])
237  compileInteractive computeFunction
238  compileInteractive mainFunction
239  cacheType:= 'recurrence
240  cacheCountCode:= ['nodeCount,stateNam]
241  cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode)
242  $e:= put(nam,'cacheInfo, cacheVector,$e)
243  nam
244
245NUMOFNODES(x) ==
246    ATOM(x) => 0
247    NUMOFNODES(first(x)) + NUMOFNODES(rest(x)) + 1
248
249nodeCount x == NUMOFNODES x
250
251recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg])
252
253mkCacheVec(op,nam,kind,resetCode,countCode) ==
254  [op,nam,kind,resetCode,countCode]
255
256-- reportCacheStore vl ==
257--   sayMSG concat(centerString('"Name",22,'" "),"   Kind          #Cells")
258--   sayMSG concat(centerString('"----",22,'" "),"   ----          ------")
259--   for x in vl repeat reportCacheStoreFor x
260--
261-- op2String op ==
262--   u:= linearFormatName op
263--   atom u => PNAME u
264--   "STRCONC"/u
265--
266-- reportCacheStorePrint(op,kind,count) ==
267--   ops:= op2String op
268--   opString:= centerString(ops,22,'" ")
269--   kindString:= centerString(PNAME kind,10,'" ")
270--   countString:= centerString(count,19,'" ")
271--   sayMSG concat(opString,kindString,countString)
272--
273-- reportCacheStoreFor op ==
274--   u:= getI(op,'localModemap) =>
275--     for [['local,target,:.],[.,fn],:.] in u repeat
276--       [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or
277--         keyedSystemError("S2GE0016",['"reportCacheStoreFor",
278--           '"missing cache information vector"])
279--       reportCacheStorePrint(op,kind,eval countCode)
280--     true
281--   u:= getI(op,"cache") =>
282--     reportCacheStorePrint(op,'variable,nodeCount u)
283--   nil
284
285clearCache x ==
286  get(x,'localModemap,$e) or get(x,'mapBody,$e) =>
287    for [map,:sub] in $mapSubNameAlist repeat
288      map=x => untrace2(sub,[])
289    $e:= putHist(x,'localModemap,nil,$e)
290    $e:= putHist(x,'mapBody,nil,$e)
291    $e:= putHist(x,'localVars,nil,$e)
292    sayKeyedMsg("S2IX0007",[x])
293
294compileInteractive fn ==
295  if $InteractiveMode then startTimingProcess 'compilation
296  if $reportCompilation then
297    sayBrightlyI bright '"Generated LISP code for function:"
298    pp fn
299  optfn :=
300     $InteractiveMode => timedOptimization fn
301     fn
302  result := compQuietly optfn
303  if $InteractiveMode then stopTimingProcess 'compilation
304  result
305
306clearAllSlams x ==
307  fn(x,nil) where
308    fn(thoseToClear,thoseCleared) ==
309      for x in thoseToClear | not MEMQ(x,thoseCleared) repeat
310        slamListName:= mkCacheName x
311        SET(slamListName,nil)
312        thoseCleared:= ADJOIN(x,thoseCleared)
313        someMoreToClear:=
314          setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,:
315            thoseCleared])
316        NCONC(thoseToClear,someMoreToClear)
317
318clearSlam(functor)==
319  id:= mkCacheName functor
320  SET(id,nil)
321