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