diff options
Diffstat (limited to 'src/interp/slam.boot.pamphlet')
| -rw-r--r-- | src/interp/slam.boot.pamphlet | 359 |
1 files changed, 0 insertions, 359 deletions
diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet deleted file mode 100644 index 4b080f02..00000000 --- a/src/interp/slam.boot.pamphlet +++ /dev/null @@ -1,359 +0,0 @@ -\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} -<<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. - -@ -<<*>>= -<<license>> - -)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} |