From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/slam.boot.pamphlet | 359 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 359 insertions(+) create mode 100644 src/interp/slam.boot.pamphlet (limited to 'src/interp/slam.boot.pamphlet') diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet new file mode 100644 index 00000000..4b080f02 --- /dev/null +++ b/src/interp/slam.boot.pamphlet @@ -0,0 +1,359 @@ +\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} -- cgit v1.2.3