\documentclass{article} \usepackage{axiom} \begin{document} \title{\File{src/interp/slam.boot} Pamphlet} \author{The Axiom Team} \maketitle \begin{abstract} \end{abstract} \eject \tableofcontents \eject \section{License} <>= -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- 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. @ <<*>>= <> )package "BOOT" reportFunctionCompilation(op,nam,argl,body,isRecursive) == -- for an alternate definition of this function which does not allow -- dynamic caching, see SLAMOLD BOOT --+ $compiledOpNameList := [nam] minivectorName := makeInternalMapMinivectorName(nam) $minivectorNames := [[op,:minivectorName],:$minivectorNames] body := SUBST(minivectorName,"$$$",body) if $compilingInputFile then $minivectorCode := [:$minivectorCode,minivectorName] SET(minivectorName,LIST2REFVEC $minivector) argl := COPY argl -- play it safe for optimization init := not(isRecursive and $compileRecurrence and #argl = 1) => nil NRTisRecurrenceRelation(nam,body,minivectorName) init => compileRecurrenceRelation(op,nam,argl,body,init) cacheCount:= getCacheCount op cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) cacheCount = 0 or null argl => function:= [nam,['LAMBDA,[:argl,'envArg],body]] compileInteractive function nam num := FIXP cacheCount => cacheCount < 1 => keyedSystemError("S2IM0019",[cacheCount,op]) cacheCount keyedSystemError("S2IM0019",[cacheCount,op]) sayKeyedMsg("S2IX0003",[op,num]) auxfn := mkAuxiliaryName nam g1:= GENSYM() --argument or argument list [arg,computeValue] := null argl => [nil,[auxfn]] argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list cacheName := mkCacheName nam g2:= GENSYM() --length of cache or arg-value pair g3:= GENSYM() --value computed by calling function secondPredPair:= null argl => [cacheName] [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] thirdPredPair:= null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] ['(QUOTE T), ['SETQ,g2,computeValue], ['SETQ,g3, ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], ['RPLACA,g3,g1], ['RPLACD,g3,g2], g2] codeBody:= ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] -- cannot use envArg in next statement without redoing much -- of above. lamex:= ['LAM,arg,codeBody] mainFunction:= [nam,lamex] computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] compileInteractive mainFunction compileInteractive computeFunction cacheType:= 'function cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] cacheVector:= mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) $e:= put(nam,'cacheInfo, cacheVector,$e) eval cacheResetCode SETANDFILE(cacheName,mkCircularAlist cacheCount) nam getCacheCount fn == n:= LASSOC(fn,$cacheAlist) => n $cacheCount reportFunctionCacheAll(op,nam,argl,body) == sayKeyedMsg("S2IX0004",[op]) auxfn:= mkAuxiliaryName nam g1:= GENSYM() --argument or argument list [arg,computeValue] := null argl => [['envArg],[auxfn, 'envArg]] argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list if null argl then g1:=nil cacheName:= mkCacheName nam g2:= GENSYM() --value computed by calling function secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] lamex:= ['LAM,arg,codeBody] mainFunction:= [nam,lamex] computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] compileInteractive mainFunction compileInteractive computeFunction cacheType:= 'hash_-table cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] cacheCountCode:= ['hashCount,cacheName] cacheVector:= mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) $e:= put(nam,'cacheInfo, cacheVector,$e) eval cacheResetCode nam hashCount table == +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] mkCircularAlist n == l:= [[$failed,:$failed] for i in 1..n] RPLACD(LASTNODE l,l) countCircularAlist(cal,n) == +/[nodeCount x for x in cal for i in 1..n] predCircular(al,n) == for i in 1..QSSUB1 n repeat al:= QCDR al al assocCircular(x,al) == --like ASSOC except that al is circular forwardPointer:= al val:= nil until EQ(forwardPointer,al) repeat EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) forwardPointer:= CDR forwardPointer val compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == k:= #initCode extraArgumentCode := extraArguments := [x for x in argl | x ^= sharpArg] => extraArguments is [x] => x ['LIST,:extraArguments] nil g:= GENSYM() gIndex:= GENSYM() gsList:= [GENSYM() for x in initCode] auxfn := mkAuxiliaryName(nam) $compiledOpNameList := [:$compiledOpNameList,auxfn] stateNam:= GENVAR() stateVar:= GENSYM() stateVal:= GENSYM() lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) decomposeCode:= [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] for g in gsList for i in 1..]] gsRev:= REVERSE gsList rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] advanceCode:= ['LET,gIndex,['ADD1,gIndex]] newTripleCode := ['LIST,sharpArg,:gsList] newStateCode := null extraArguments => ['SETQ,stateNam,newTripleCode] ['HPUT,stateNam,extraArgumentCode,newTripleCode] computeFunction:= [auxfn,['LAM,cargl,cbody]] where cargl:= [:argl,lastArg] returnValue:= ['PROGN,newStateCode,first gsList] cbody:= endTest:= ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] ['PROGN,:decomposeCode, ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, newValueCode,:rotateCode]]] fromScratchInit:= [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] continueInit:= [['LET,gIndex,['ELT,stateVar,0]], :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] mainFunction:= [nam,['LAM,margl,mbody]] where margl:= [:argl,'envArg] max:= GENSYM() tripleCode := ['CONS,n,['LIST,:initCode]] -- initialSetCode initializes the global variable if necessary and -- also binds "stateVar" to its current value initialSetCode := initialValueCode := extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] tripleCode cacheResetCode := ['SETQ,stateNam,initialValueCode] ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ ['PAIRP,stateNam]]], _ ['LET,stateVar,cacheResetCode]], _ [''T, ['LET,stateVar,stateNam]]] -- when there are extra arguments, initialResetCode resets "stateVar" -- to the hashtable entry for the extra arguments initialResetCode := null extraArguments => nil [['LET,stateVar,['OR, ['HGET,stateVar,extraArgumentCode], ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] mbody := preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], [auxfn,:argl,stateVar]] phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] phrase4:= [['GT,sharpArg,n-k], ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] sayKeyedMsg("S2IX0001",[op]) compileInteractive computeFunction compileInteractive mainFunction cacheType:= 'recurrence cacheCountCode:= ['nodeCount,stateNam] cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) $e:= put(nam,'cacheInfo, cacheVector,$e) nam nodeCount x == NUMOFNODES x recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) mkCacheVec(op,nam,kind,resetCode,countCode) == [op,nam,kind,resetCode,countCode] -- reportCacheStore vl == -- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") -- sayMSG concat(centerString('"----",22,'" ")," ---- ------") -- for x in vl repeat reportCacheStoreFor x -- -- op2String op == -- u:= linearFormatName op -- atom u => PNAME u -- "STRCONC"/u -- -- reportCacheStorePrint(op,kind,count) == -- ops:= op2String op -- opString:= centerString(ops,22,'" ") -- kindString:= centerString(PNAME kind,10,'" ") -- countString:= centerString(count,19,'" ") -- sayMSG concat(opString,kindString,countString) -- -- reportCacheStoreFor op == -- u:= getI(op,'localModemap) => -- for [['local,target,:.],[.,fn],:.] in u repeat -- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or -- keyedSystemError("S2GE0016",['"reportCacheStoreFor", -- '"missing cache information vector"]) -- reportCacheStorePrint(op,kind,eval countCode) -- true -- u:= getI(op,"cache") => -- reportCacheStorePrint(op,'variable,nodeCount u) -- nil clearCache x == get(x,'localModemap,$e) or get(x,'mapBody,$e) => for [map,:sub] in $mapSubNameAlist repeat map=x => _/UNTRACE_,2(sub,NIL) $e:= putHist(x,'localModemap,nil,$e) $e:= putHist(x,'mapBody,nil,$e) $e:= putHist(x,'localVars,nil,$e) sayKeyedMsg("S2IX0007",[x]) clearLocalModemaps x == u:= get(x,"localModemap",$e) => for sub in ASSOCRIGHT $mapSubNameAlist repeat _/UNTRACE_,2(sub,NIL) $e:= putHist(x,"localModemap",nil,$e) for mm in u repeat [.,fn,:.] := mm if def:= get(fn,'definition,$e) then $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) if cacheVec:= get(fn,'cacheInfo,$e) then SET(cacheVec.cacheName,NIL) -- now clear the property list of the identifier $e := addIntSymTabBinding(x,nil,$e) sayKeyedMsg("S2IX0007",[x]) compileInteractive fn == if $InteractiveMode then startTimingProcess 'compilation --following not used for common lisp --removeUnnecessaryLastArguments CADR fn if $reportCompilation then sayBrightlyI bright '"Generated LISP code for function:" pp fn optfn := $InteractiveMode => [timedOptimization fn] [fn] result := compQuietly optfn if $InteractiveMode then stopTimingProcess 'compilation result clearAllSlams x == fn(x,nil) where fn(thoseToClear,thoseCleared) == for x in thoseToClear | not MEMQ(x,thoseCleared) repeat slamListName:= mkCacheName x SET(slamListName,nil) thoseCleared:= ADJOIN(x,thoseCleared) someMoreToClear:= setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: thoseCleared]) NCONC(thoseToClear,someMoreToClear) clearSlam("functor")== id:= mkCacheName functor SET(id,nil) @ \eject \begin{thebibliography}{99} \bibitem{1} nothing \end{thebibliography} \end{document}