-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2012, Gabriel Dos Reis. -- 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. import g_-timer namespace BOOT ++ List of compiled function names. $compiledOpNameList := [] isRecurrenceRelation(op,body,minivectorName) == -- returns [body p1 p2 ... pk] for a k-term recurrence relation -- where the n-th term is computed using the (n-1)st,...,(n-k)th -- whose values are initially computed using the expressions -- p1,...,pk respectively; body has #2,#3,... in place of -- f(k-1),f(k-2),... body isnt ['%when,:pcl] => false -- body should have a conditional expression which -- gives k boundary values, one general term plus possibly an -- "out of domain" condition pcl := [x for x in pcl | not (x is ['%otherwise,:mess] and (CONTAINED('throwMessage,mess) or CONTAINED('throwKeyedMsg,mess)))] integer := eval $Integer iequalSlot:=compiledLookupCheck("=",[$Boolean,"$","$"],integer) lesspSlot:=compiledLookupCheck("<",[$Boolean,"$","$"],integer) notpSlot:= compiledLookupCheck("not",["$","$"],eval $Boolean) for [p,c] in pcl repeat p is ['SPADCALL,sharpVar,n1, ["ELT",["%dynval",=MKQ minivectorName],slot]] and sameObject?(iequalSlot,$minivector.slot) => initList:= [[n1,:c],:initList] sharpList := insert(sharpVar,sharpList) n:=n1 miscList:= [[p,c],:miscList] miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] => return false --first general term starts at n --Must have at least one special value; insist that they be consecutive null initList => false specialValues:= MSORT ASSOCLEFT initList or/[null integer? n for n in specialValues] => false minIndex:= "MIN"/specialValues not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) => sayKeyedMsg("S2IX0005", ["append"/[['" ",sv] for sv in specialValues]]) return nil --Determine the order k of the recurrence and index n of first general term k:= #specialValues n:= k+minIndex --Check general predicate predOk := generalPred = '%otherwise => true generalPred is ['SPADCALL,m,=sharpArg, ["ELT",["%dynval",=MKQ minivectorName],slot]] and sameObject?(lesspSlot,$minivector.slot)=> m+1 generalPred is ['SPADCALL,['SPADCALL,=sharpArg,m, ["ELT",["%dynval",=MKQ minivectorName],slot]], ["ELT",["%dynval",=MKQ minivectorName],notSlot]] and sameObject?(lesspSlot,$minivector.slot) and sameObject?(notpSlot,$minivector.notSlot) => m generalPred is ['%not,['SPADCALL,=sharpArg,m, ["ELT",["%dynval",=MKQ minivectorName], =lesspSlot]]] and sameObject?(lesspSlot,$minivector.slot) => m return nil integer? predOk and predOk ~= n => sayKeyedMsg("S2IX0006",[n,m]) return nil --Check general term for references to just the k previous values diffCell:=compiledLookupCheck("-",'($ $ $),integer) diffSlot := or/[i for i in 0.. for x in $minivector | sameObject?(x,diffCell)] or return nil --Check general term for references to just the k previous values sharpPosition := readInteger subString(symbolName sharpArg,1) al:= mkDiffAssoc(op,generalTerm,k,sharpPosition,sharpArg,diffSlot,minivectorName) null al => false "$failed" in al => false body:= generalTerm for [a,:b] in al repeat body:= substitute(b,a,body) result:= [body,sharpArg,n-1,:reverse! [LASSOC(i,initList) or systemErrorHere('"isRecurrenceRelation") for i in minIndex..(n-1)]] mkDiffAssoc(op,body,k,sharpPosition,sharpArg,diffSlot,vecname) == -- returns alist which should not have any entries = $failed -- form substitution list of the form: -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...) -- but also checking that all difference values lie in 1..k body isnt [.,:.] => nil body is ['%when,:pl] => "union"/[mkDiffAssoc(op,c,k,sharpPosition,sharpArg,diffSlot,vecname) for [p,c] in pl] body is [fn,:argl] => (fn = op) and argl.(sharpPosition-1) is ['SPADCALL,=sharpArg,n,["ELT",["%dynval",=MKQ vecname],=diffSlot]] => integer? n and n > 0 and n <= k => [[body,:$TriangleVariableList.n]] ['$failed] "union"/[mkDiffAssoc(op,x,k,sharpPosition,sharpArg,diffSlot,vecname) for x in argl] systemErrorHere '"mkDiffAssoc" 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 body := substitute(["%dynval",MKQ minivectorName],"$$$",body) symbolValue(minivectorName) := vector $minivector argl := copyTree argl -- play it safe for optimization init := not(isRecursive and $compileRecurrence and #argl = 1) => nil isRecurrenceRelation(nam,body,minivectorName) init => compileRecurrenceRelation(op,nam,argl,body,init) cacheCount:= getCacheCount op cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) parms := [:argl,"envArg"] cacheCount = 0 or null argl => compileInteractive [nam,['%lambda,parms,body]] nam num := integer? 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,['APPLY,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] [["%store",g3,['assocCircular,g1,["%dynval",MKQ cacheName]]],['CDR,g3]] thirdPredPair:= null argl => ['%otherwise,[['%store,['%dynval,MKQ cacheName],computeValue]]] ['%otherwise, ['%store,g2,computeValue], ["SETQ",g3, ["CAR",["%store",["%dynval",MKQ cacheName],['predCircular,["%dynval",cacheName],cacheCount]]]], ["RPLACA",g3,g1], ["RPLACD",g3,g2], g2] codeBody:= ["PROG",[g2,g3],["RETURN",['%when,secondPredPair,thirdPredPair]]] -- cannot use envArg in next statement without redoing much -- of above. mainFunction:= [nam,['%lambda,arg,codeBody]] computeFunction:= [auxfn,['%lambda,parms,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 symbolValue(cacheName) := mkCircularAlist cacheCount nam getCacheCount fn == n:= symbolTarget(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,["APPLY",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 := [['%store,g2,['tableValue,['%dynval,MKQ cacheName],g1]],g2] thirdPredPair := ['%otherwise, ['%store,['tableValue,['%dynval,MKQ cacheName],g1], computeValue]] codeBody:= ["PROG",[g2],["RETURN",['%when,secondPredPair,thirdPredPair]]] mainFunction:= [nam,['%lambda,arg,codeBody]] parms := [:argl, "envArg"] computeFunction:= [auxfn,['%lambda,parms,body]] compileInteractive mainFunction compileInteractive computeFunction cacheType:= 'hash_-table cacheResetCode:= ['%store,['%dynval,MKQ cacheName],['hashTable,''EQUAL]] cacheCountCode:= ['hashCount,cacheName] cacheVector:= mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) $e:= put(nam,'cacheInfo, cacheVector,$e) eval cacheResetCode nam hashCount table == +/[1 + nodeCount val for [key,:val] in entries table] mkCircularAlist n == l:= [[$failed,:$failed] for i in 1..n] lastNode(l).rest := l countCircularAlist(cal,n) == +/[nodeCount x for x in cal for i in 1..n] predCircular(al,n) == for i in 1..(n - 1) repeat al:= rest al al assocCircular(x,al) == --like ASSOC except that al is circular forwardPointer:= al val:= nil until sameObject?(forwardPointer,al) repeat CAAR forwardPointer = x => return (val:= first forwardPointer) forwardPointer:= rest 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 := makeSymbol strconc('"#",toString(#argl + 1)) decomposeBindings:= [[gIndex,["ELT",lastArg,0]],:[[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,['%iinc,gIndex]] newTripleCode := ['%list,sharpArg,:gsList] newStateCode := null extraArguments => ["%store",["%dynval", MKQ stateNam],newTripleCode] ['store,['tableValue,["%dynval", MKQ stateNam],extraArgumentCode], newTripleCode] computeFunction:= [auxfn,['%lambda,cargl,cbody]] where cargl:= [:argl,lastArg] returnValue:= ["PROGN",newStateCode,first gsList] cbody:= endTest:= ['%when, [['%ieq,sharpArg,gIndex],['RETURN,returnValue]]] newValueCode:= ["%LET",g,substitute(gIndex,sharpArg, applySubst(pairList(rest $TriangleVariableList,gsList),body))] ['%bind,decomposeBindings, ['%repeat,["WHILE",'%true],["PROGN",endTest,advanceCode, newValueCode,:rotateCode],voidValue()]] 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,['%lambda,margl,mbody]] where margl:= [:argl,'envArg] max:= gensym() tripleCode := ['%pair,n,['%list,:initCode]] -- initialSetCode initializes the global variable if necessary and -- also binds "stateVar" to its current value initialSetCode := initialValueCode := extraArguments => ["hashTable",''EQUAL] tripleCode cacheResetCode := ['%store,['%dynval, MKQ stateNam],initialValueCode] ['%when,[['%not,['%and,["BOUNDP",MKQ stateNam], _ ['%pair?,['%dynval,MKQ stateNam]]]], _ ["%LET",stateVar,cacheResetCode]], _ ['%otherwise, ["%LET",stateVar,['%dynval,MKQ stateNam]]]] -- when there are extra arguments, initialResetCode resets "stateVar" -- to the hashtable entry for the extra arguments initialResetCode := null extraArguments => nil [["%LET",stateVar,['%or, ["tableValue",stateVar,extraArgumentCode], ['%store,['tableValue,stateVar,extraArgumentCode],tripleCode]]]] mbody := preset := [initialSetCode,:initialResetCode,["%LET",max,["ELT",stateVar,0]]] phrase1:= [['%and,["%LET",max,["ELT",stateVar,0]],['%ige,sharpArg,max]], [auxfn,:argl,stateVar]] phrase2:= [['%igt,sharpArg,['%store,max,["DIFFERENCE",max,k]]], ["ELT",stateVar,['%iinc,["%isub",k,["DIFFERENCE",sharpArg,max]]]]] phrase3:= [['%igt,sharpArg,n],[auxfn,:argl,['%list,n,:initCode]]] phrase4:= [['%igt,sharpArg,n-k], ["ELT",['%list,:initCode],["%isub",n,sharpArg]]] phrase5:= ['%otherwise,['recurrenceError,MKQ op,sharpArg]] ['PROGN,:preset,['%when,phrase1,phrase2,phrase3,phrase4,phrase5]] if $verbose then 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] ++ We are about to clear local modemaps associated with `x'. ++ It is insufficient to just remove the internal functions ++ form the 'localModemap property list in the current environment. ++ We also need to clear any Lisp-level function resulting from ++ previous compilations. reallyClearLocalModemaps x == for mm in get(x,'localModemap,$e) repeat FMAKUNBOUND second mm $e:= putHist(x,'localModemap,nil,$e) clearCache x == get(x,'localModemap,$e) or get(x,'mapBody,$e) => for [map,:sub] in $mapSubNameAlist repeat map=x => _/UNTRACE_,2(sub,nil) $e := reallyClearLocalModemaps x $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:= reallyClearLocalModemaps x for mm in u repeat [.,fn,:.] := mm if def:= get(fn,'definition,$e) then $e:= putHist(x,'value,objNew(def,$EmptyMode),$e) if cacheVec:= get(fn,'cacheInfo,$e) then symbolValue(cacheVec.cacheName) := nil -- now clear the property list of the identifier $e := addIntSymTabBinding(x,nil,$e) sayKeyedMsg("S2IX0007",[x]) $e $e compileInteractive fn == try startTimingProcess 'compilation if fn is [.,[bindOp,.,.]] and abstractionOperator? bindOp then fn := [first fn,declareUnusedParameters second fn] if $reportCompilation then sayBrightlyI bright '"Generated LISP code for function:" pp fn compQuietly [timedOptimization fn] finally stopTimingProcess 'compilation ++ Subroutine of compileInteractive. compQuietly fn == $backend: local := $compileDontDefineFunctions => "COMPILE-DEFUN" "EVAL-DEFUN" quietlyIfInteractive backendCompile(nil,fn) clearAllSlams x == fn(x,nil) where fn(thoseToClear,thoseCleared) == for x in thoseToClear | not symbolMember?(x,thoseCleared) repeat slamListName:= mkCacheName x symbolValue(slamListName) := nil thoseCleared:= ADJOIN(x,thoseCleared) someMoreToClear:= setDifference(symbolTarget(x,$functorDependencyAlist),[:thoseToClear,: thoseCleared]) append!(thoseToClear,someMoreToClear) clearSlam("functor")== symbolValue(mkCacheName functor) := nil