remove pamphlets - part 2

1 files changed, 399 insertions, 0 deletions

diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
new file mode 100644
index 00000000..932cff17
--- /dev/null
+++ b/src/interp/g-opt.boot
@@ -0,0 +1,399 @@
+-- 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.
+
+
+--% 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
+    )
+ 
+