diff options
Diffstat (limited to 'src/interp/g-opt.boot.pamphlet')
| -rw-r--r-- | src/interp/g-opt.boot.pamphlet | 421 |
1 files changed, 421 insertions, 0 deletions
diff --git a/src/interp/g-opt.boot.pamphlet b/src/interp/g-opt.boot.pamphlet new file mode 100644 index 00000000..33fad9dd --- /dev/null +++ b/src/interp/g-opt.boot.pamphlet @@ -0,0 +1,421 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-opt.boot} +\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>> + +--% OPTIMIZER + +optimizeFunctionDef(def) == + if $reportOptimization then + sayBrightlyI bright '"Original LISP code:" + pp def + + def' := optimize COPY def + + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp def' + sayBrightlyI bright '"Final LISP code:" + [name,[slamOrLam,args,body]] := def' + + body':= + removeTopLevelCatch body where + removeTopLevelCatch body == + body is ["CATCH",g,u] => + removeTopLevelCatch replaceThrowByReturn(u,g) + body + replaceThrowByReturn(x,g) == + fn(x,g) + x + fn(x,g) == + x is ["THROW", =g,:u] => + rplac(first x,"RETURN") + rplac(rest x,replaceThrowByReturn(u,g)) + atom x => nil + replaceThrowByReturn(first x,g) + replaceThrowByReturn(rest x,g) + [name,[slamOrLam,args,body']] + +optimize x == + (opt x; x) where + opt x == + atom x => nil + (y:= first x)='QUOTE => nil + y='CLOSEDFN => nil + y is [["XLAM",argl,body],:a] => + optimize rest x + argl = "ignore" => RPLAC(first x,body) + if not (LENGTH argl<=LENGTH a) then + SAY '"length mismatch in XLAM expression" + PRETTYPRINT y + RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) + atom y => + optimize rest x + y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) + y="false" => RPLAC(first x,nil) + if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) + op:= GETL(subrname first y,"OPTIMIZE") => + (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) + RPLAC(first x,optimize first x) + optimize rest x + +subrname u == + IDENTP u => u + COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u + nil + +optCatch (x is ["CATCH",g,a]) == + $InteractiveMode => x + atom a => a + if a is ["SEQ",:s,["THROW", =g,u]] then + changeThrowToExit(s,g) where + changeThrowToExit(s,g) == + atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil + s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) + changeThrowToExit(first s,g) + changeThrowToExit(rest s,g) + rplac(rest a,[:s,["EXIT",u]]) + ["CATCH",y,a]:= optimize x + if hasNoThrows(a,g) + then (rplac(first x,first a); rplac(rest x,rest a)) where + hasNoThrows(a,g) == + a is ["THROW", =g,:.] => false + atom a => true + hasNoThrows(first a,g) and hasNoThrows(rest a,g) + else + changeThrowToGo(a,g) where + changeThrowToGo(s,g) == + atom s or first s='QUOTE => nil + s is ["THROW", =g,u] => + changeThrowToGo(u,g) + rplac(first s,"PROGN") + rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) + changeThrowToGo(first s,g) + changeThrowToGo(rest s,g) + rplac(first x,"SEQ") + rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) + x + +optSPADCALL(form is ['SPADCALL,:argl]) == + null $InteractiveMode => form + -- last arg is function/env, but may be a form + argl is [:argl,fun] => + fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => + optCall ['call,['ELT,dom,slot],:argl] + form + form + +optCall (x is ["call",:u]) == + -- destructively optimizes this new x + x:= optimize [u] + -- next should happen only as result of macro expansion + atom first x => first x + [fn,:a]:= first x + atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) + fn is ["PAC",:.] => optPackageCall(x,fn,a) + fn is ["applyFun",name] => + (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) + fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => + not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w + q="CONST" => +--+ + ["spadConstant",R,n] + --putInLocalDomainReferences will change this to ELT or QREFELT + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + systemErrorHere '"optCall" + +optCallSpecially(q,x,n,R) == + y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) + MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) + (y:= get(R,"value",$e)) and + MEMQ(opOf y.expr,$optimizableConstructorNames) => + optSpecialCall(x,y.expr,n) + ( + (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and + (yy:= LASSOC(y,$specialCaseKeyList)) => + optSpecialCall(x,[op,yy,prop],n)) where + lookup(a,l) == + null l => nil + [l',:l]:= l + l' is ["LET", =a,l',:.] => l' + lookup(a,l) + nil + +optCallEval u == + u is ["List",:.] => List Integer() + u is ["Vector",:.] => Vector Integer() + u is ["PrimitiveArray",:.] => PrimitiveArray Integer() + u is ["FactoredForm",:.] => FactoredForm Integer() + u is ["Matrix",:.] => Matrix Integer() + eval u + +optCons (x is ["CONS",a,b]) == + a="NIL" => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) + x + a is ['QUOTE,a'] => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) + x + x + +optSpecialCall(x,y,n) == + yval := optCallEval y + CAAAR x="CONST" => + KAR yval.n = function Undef => + keyedSystemError("S2GE0016",['"optSpecialCall", + '"invalid constant"]) + MKQ yval.n + fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => + rplac(rest x,CDAR x) + rplac(first x,fn) + if fn is ["XLAM",:.] then x:=first optimize [x] + x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) + --DEF-EQUAL is really an optimiser + x + [fn,:a]:= first x + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + +compileTimeBindingOf u == + NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) + name="Undef" => MOAN "optimiser found unknown function" + name + +optMkRecord ["mkRecord",:u] == + u is [x] => ["LIST",x] + #u=2 => ["CONS",:u] + ["VECTOR",:u] + +optCond (x is ['COND,:l]) == + if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then + RPLACD(rest x,c) + if l is [[p1,:c1],[p2,:c2],:.] then + if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then + l:=[[p1,:c1],['(QUOTE T),:c2]] + RPLACD( x,l) + c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => + p1 is ['NULL,p1']=> return p1' + return ['NULL,p1] + l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => + EqualBarGensym(c1,c3) => + ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] + EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] + x + for y in tails l repeat + while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat + a:=['OR,a1,a2] + RPLAC(first first y,a) + RPLAC(rest y,y') + x + +AssocBarGensym(key,l) == + for x in l repeat + PAIRP x => + EqualBarGensym(key,CAR x) => return x + +EqualBarGensym(x,y) == + $GensymAssoc: nil + fn(x,y) where + fn(x,y) == + x=y => true + GENSYMP x and GENSYMP y => + z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) + $GensymAssoc:= [[x,:y],:$GensymAssoc] + true + null x => y is [g] and GENSYMP g + null y => x is [g] and GENSYMP g + atom x or atom y => false + fn(first x,first y) and fn(rest x,rest y) + +--Called early, to change IF to COND + +optIF2COND ["IF",a,b,c] == + b is "noBranch" => ["COND",[["NULL",a],c]] + c is "noBranch" => ["COND",[a,b]] + c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] + c is ["COND",:p] => ["COND",[a,b],:p] + ["COND",[a,b],[$true,c]] + +optXLAMCond x == + x is ["COND",u:= [p,c],:l] => + (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) + atom x => x + RPLAC(first x,optXLAMCond first x) + RPLAC(rest x,optXLAMCond rest x) + x + +optPredicateIfTrue p == + p is ['QUOTE,:.] => true + p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true + nil + +optCONDtail l == + null l => nil + [frst:= [p,c],:l']:= l + optPredicateIfTrue p => [[$true,c]] + null rest l => [frst,[$true,["CondError"]]] + [frst,:optCONDtail l'] + +optSEQ ["SEQ",:l] == + tryToRemoveSEQ SEQToCOND getRidOfTemps l where + getRidOfTemps l == + null l => nil + l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => + getRidOfTemps substitute(x,g,r) + first l="/throwAway" => getRidOfTemps rest l + --this gets rid of unwanted labels generated by declarations in SEQs + [first l,:getRidOfTemps rest l] + SEQToCOND l == + transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] + before:= take(#transform,l) + aft:= after(l,before) + null before => ["SEQ",:aft] + null aft => ["COND",:transform,'((QUOTE T) (conderr))] + true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] + tryToRemoveSEQ l == + l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a + l + +optRECORDELT ["RECORDELT",name,ind,len] == + len=1 => + ind=0 => ["QCAR",name] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["QCAR",name] + ind=1 => ["QCDR",name] + keyedSystemError("S2OO0002",[ind]) + ["QVELT",name,ind] + +optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == + len=1 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] + keyedSystemError("S2OO0002",[ind]) + ["QSETVELT",name,ind,expr] + +optRECORDCOPY ["RECORDCOPY",name,len] == + len=1 => ["LIST",["CAR",name]] + len=2 => ["CONS",["CAR",name],["CDR",name]] + ["MOVEVEC",["MAKE_-VEC",len],name] + +--mkRecordAccessFunction(ind,len) == +-- stringOfDs:= $EmptyString +-- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") +-- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" +-- if $QuickCode then prefix:=STRCONC("Q",prefix) +-- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) + +optSuchthat [.,:u] == ["SUCHTHAT",:u] + +optMINUS u == + u is ['MINUS,v] => + NUMBERP v => -v + u + u + +optQSMINUS u == + u is ['QSMINUS,v] => + NUMBERP v => -v + u + u + +opt_- u == + u is ['_-,v] => + NUMBERP v => -v + u + u + +optLESSP u == + u is ['LESSP,a,b] => + b = 0 => ['MINUSP,a] + ['GREATERP,b,a] + u + +optEQ u == + u is ['EQ,l,r] => + NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] + -- That undoes some weird work in Boolean to do with the definition of true + u + u + +EVALANDFILEACTQ + ( + for x in '( (call optCall) _ + (SEQ optSEQ)_ + (EQ optEQ) + (MINUS optMINUS)_ + (QSMINUS optQSMINUS)_ + (_- opt_-)_ + (LESSP optLESSP)_ + (SPADCALL optSPADCALL)_ + (_| optSuchthat)_ + (CATCH optCatch)_ + (COND optCond)_ + (mkRecord optMkRecord)_ + (RECORDELT optRECORDELT)_ + (SETRECORDELT optSETRECORDELT)_ + (RECORDCOPY optRECORDCOPY)) _ + repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) + --much quicker to call functions if they have an SBC + ) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |