aboutsummaryrefslogtreecommitdiff
path: root/src/interp/g-opt.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/g-opt.boot.pamphlet')
-rw-r--r--src/interp/g-opt.boot.pamphlet421
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}