path: root/src/interp/g-opt.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2010, 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 macros
namespace BOOT

--% 

$optimizableConstructorNames := $SystemInlinableConstructorNames

++ Return true if the domain `dom' is an instance of a functor
++ that has been nominated for inlining.
optimizableDomain? dom ==
  opOf dom in $optimizableConstructorNames

++ Register the domain `dom' for inlining.
nominateForInlining dom ==
  $optimizableConstructorNames := [opOf dom,:$optimizableConstructorNames]
  
--%

++ return the template of the instantiating functor for
++ the domain form `dom'.
getDomainTemplate dom ==
  atom dom => nil
  getInfovec first dom

++ Emit code for an indirect call to domain-wide Spad function.  
++ This is usually the case for exported functions.
emitIndirectCall(fn,args,x) ==
  x.first := "SPADCALL"
  fn.first := "getShellEntry"
  x.rest := [:args,fn]
  x

--% 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'

  [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] =>
          x.first := "RETURN"
          x.rest := 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" => x.first := body
        if not (# argl<= # a) then
          SAY '"length mismatch in XLAM expression"
          PRETTYPRINT y
        x.first := optimize optXLAMCond SUBLIS(pairList(argl,a),body)
      atom y =>
        optimize rest x
      if first y="IF" then (x.first := optIF2COND y; y:= first x)
      op:= GETL(subrname first y,"OPTIMIZE") =>
        (optimize rest x; x.first := FUNCALL(op,optimize first x))
      x.first := optimize first x
      optimize rest x
 
subrname u ==
  IDENTP u => u
  COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u
  nil
 
changeThrowToExit(s,g) ==
  atom s or s.op in '(QUOTE SEQ REPEAT COLLECT %collect %repeat %reduce) => nil
  s is ["THROW", =g,:u] => (s.first := "EXIT"; s.rest := u)
  changeThrowToExit(first s,g)
  changeThrowToExit(rest s,g)

hasNoThrows(a,g) ==
  a is ["THROW", =g,:.] => false
  atom a => true
  hasNoThrows(first a,g) and hasNoThrows(rest a,g)

changeThrowToGo(s,g) ==
  atom s or first s='QUOTE => nil
  s is ["THROW", =g,u] =>
    changeThrowToGo(u,g)
    s.first := "PROGN"
    s.rest := [["%LET",second g,u],["GO",second g]]
  changeThrowToGo(first s,g)
  changeThrowToGo(rest s,g)

++ Change any `(THROW tag (%return expr))' in x to just
++ `(%return expr) since a return-operator transfer control
++ out of the function body anyway.  Similarly, transform
++ reudant `(THROW tag (THROW tag expr))' to `(THROW tag expr)'.
removeNeedlessThrow x ==
  isAtomicForm x => x
  x is ['THROW,.,y] and y is ['%return,:.] =>
    removeNeedlessThrow third y
    x.op := y.op
    x.args := y.args
  x is ['THROW,g,y] and y is ['THROW,=g,z] =>
    removeNeedlessThrow z
    second(x.args) := z
  for x' in x repeat
    removeNeedlessThrow x'

optCatch (x is ["CATCH",g,a]) ==
  $InteractiveMode => x
  atom a => a
  removeNeedlessThrow a
  if a is ["SEQ",:s,["THROW", =g,u]] then
    changeThrowToExit(s,g)
    a.rest := [:s,["EXIT",u]]
    ["CATCH",y,a]:= optimize x
  if hasNoThrows(a,g) then
    x.first := first a
    x.rest := rest a
  else
    changeThrowToGo(a,g)
    x.first := "SEQ"
    x.rest := [["EXIT",a],second g,["EXIT",second g]]
  x
 
optSPADCALL(form is ['SPADCALL,:argl]) ==
  null $InteractiveMode => form
  -- last arg is function/env, but may be a form
  argl is [:argl,fun] and fun is ["ELT",dom,slot] =>
    optCall ["%Call",['ELT,dom,slot],:argl]
  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 => (x.rest := a; x.first := fn)
  fn is ["applyFun",name] =>
    (x.first := "SPADCALL"; x.rest := [:a,name]; x)
  fn is [q,R,n] and q in '(getShellEntry ELT QREFELT CONST) =>
    not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w
    q="CONST" => ["spadConstant",R,n]
    emitIndirectCall(fn,a,x)
  systemErrorHere ["optCall",x]
 
optCallSpecially(q,x,n,R) ==
    y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n)
    optimizableDomain? R => optSpecialCall(x,R,n)
    (y:= get(R,"value",$e)) and
      optimizableDomain? y.expr =>
        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 => (x.first := 'QUOTE; x.rest := ['NIL,:'NIL]; x)
    b is ['QUOTE,:c] => (x.first := 'QUOTE; x.rest := ['NIL,:c]; x)
    x
  a is ['QUOTE,a'] =>
    b='NIL => (x.first := 'QUOTE; x.rest := [a',:'NIL]; x)
    b is ['QUOTE,:c] => (x.first := 'QUOTE; x.rest := [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 := getFunctionReplacement compileTimeBindingOf first yval.n =>
    x.rest := CDAR x
    x.first := 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
  emitIndirectCall(fn,a,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
    x.rest.rest := c
  if l is [[p1,:c1],[p2,:c2],:.] then
    if (p1 is ["NOT",=p2]) or (p2 is ["NOT",=p1]) then
      l:=[[p1,:c1],['(QUOTE T),:c2]]
      x.rest := l
    c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) =>
      p1 is ["NOT",p1']=> return p1'
      return ["NOT",p1]
  l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 =>
    EqualBarGensym(c1,c3) =>
      ["COND",[["OR",p1,["NOT",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]
      first(y).first := a
      y.rest := y'
  x
 
AssocBarGensym(key,l) ==
  for x in l repeat
    cons? x =>
      EqualBarGensym(key,first x) => return x
 
EqualBarGensym(x,y) ==
  $GensymAssoc: fluid := nil
  fn(x,y) where
    fn(x,y) ==
      x=y => true
      GENSYMP x and GENSYMP y =>
        z:= assoc(x,$GensymAssoc) => y=rest z
        $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",[["NOT",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
  x.first := optXLAMCond first x
  x.rest := 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 splicePROGN l where
    splicePROGN l ==
      isAtomicForm l => l
      l is [["PROGN",:stmts],:l'] => [:stmts,:l']
      l.rest := splicePROGN rest l
    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 op in '(EXIT RETURN THROW) => a
      l
 
optRECORDELT ["RECORDELT",name,ind,len] ==
  len=1 =>
    ind=0 => ["%head",name]
    keyedSystemError("S2OO0002",[ind])
  len=2 =>
    ind=0 => ["%head",name]
    ind=1 => ["%tail",name]
    keyedSystemError("S2OO0002",[ind])
  ["QVELT",name,ind]
 
optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] ==
  len=1 =>
    ind=0 => ["PROGN",["RPLACA",name,expr],["%head",name]]
    keyedSystemError("S2OO0002",[ind])
  len=2 =>
    ind=0 => ["PROGN",["RPLACA",name,expr],["%head",name]]
    ind=1 => ["PROGN",["RPLACD",name,expr],["%tail",name]]
    keyedSystemError("S2OO0002",[ind])
  ["QSETVELT",name,ind,expr]
 
optRECORDCOPY ["RECORDCOPY",name,len] ==
  len=1 => ["LIST",["CAR",name]]
  len=2 => ["CONS",["CAR",name],["CDR",name]]
  ["REPLACE",["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
 
++ List of VM side effect free operators.
$VMsideEffectFreeOperators ==
  '(CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
    SPADfirst QVELT _+ _- _* _< _= _<_= _> _>_= ASH INTEGER_-LENGTH
     QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP
      MINUSP GREATERP ZEROP ODDP FLOAT_-RADIX FLOAT FLOAT_-SIGN FLOAT_-DIGITS
       CGREATERP GGREATERP CHAR BOOLE GET BVEC_-GREATER FUNCALL %false %true
        %and %or %not %eq %ieq %ilt %ile %igt %ige %head %tail %integer?
         %imul %iadd %isub %igcd %ilcm %ipow %imin %imax %ieven? %iodd? %iinc
          %feq %flt %fle %fgt %fge %fmul %fadd %fsub %fexp %fmin %fmax %float?
           %fpow %fdiv %nil %pair? %lconcat %llength %lfirst %lsecond %lthird
            %lreverse %lempty? %hash %ismall? %string?
             %ceq %clt %cle %cgt %cge %c2i %i2c)

++ List of simple VM operators
$simpleVMoperators == 
  append($VMsideEffectFreeOperators,
    ["CONS","LIST","VECTOR","STRINGIMAGE",'%gensym, '%lreverse_!,
      "MAKE-FULL-CVEC","BVEC-MAKE-FULL","COND"])

++ Return true if the `form' is semi-simple with respect to
++ to the list of operators `ops'.
semiSimpleRelativeTo?(form,ops) ==
  isAtomicForm form => true
  form isnt [op,:args] or not MEMQ(op,ops) => false
  and/[semiSimpleRelativeTo?(f,ops) for f in args]

++ Return true if `form' is a simple VM form.
++ See $simpleVMoperators for the definition of simple operators.
isSimpleVMForm form ==
  semiSimpleRelativeTo?(form,$simpleVMoperators)

++ Return true if `form' is a VM form whose evaluation does not depend
++ on the program point where it is evaluated. 
isFloatableVMForm: %Code -> %Boolean
isFloatableVMForm form ==
  atom form => form ~= "$"
  form is ["QUOTE",:.] => true
  MEMQ(first form, $simpleVMoperators) and
    "and"/[isFloatableVMForm arg for arg in rest form]
    

++ Return true if the VM form `form' is one that we certify to 
++ evaluate to a (compile time) constant.  Note that this is a
++ fairly conservative approximation of compile time constants.
isVMConstantForm: %Code -> %Boolean
isVMConstantForm form ==
  integer? form or string? form => true
  form=nil or form=true => true
  form isnt [op,:args] => false
  op = "QUOTE" => true
  MEMQ(op,$simpleVMoperators) and 
    "and"/[isVMConstantForm arg for arg in args]

++ Return the set of free variables in the VM form `form'.
findVMFreeVars form ==
  IDENTP form => [form]
  form isnt [op,:args] => nil  
  op = "QUOTE" => nil
  vars := union/[findVMFreeVars arg for arg in args]
  atom op => vars
  union(findVMFreeVars op,vars)

++ Return true is `var' is the left hand side of an assignment
++ in `form'.
varIsAssigned(var,form) ==
  isAtomicForm form => false
  form is [op,=var,:.] and op in '(%LET LETT SETQ %store) => true
  or/[varIsAssigned(var,f) for f in form]

++ Subroutine of optLET.  Return true if the variable `var' locally
++ defined in the LET-form can be safely replaced by its initalization
++ `expr' in the `body' of the LET-form.
canInlineVarDefinition(var,expr,body) ==
  varIsAssigned(var,body) => false
  numOfOccurencesOf(var,body) < 2 => true
  atom expr and not varIsAssigned(expr,body)

++ Implement simple-minded LET-inlining.  It seems we can't count
++ on Lisp implementations to do this simple transformation.
++ This transformation will probably be more effective when all
++ type informations are still around.   Which is why we should
++ have a type directed compilation throughout. 
optLET u ==
  -- Hands off non-simple cases.
  u isnt ["LET",inits,body] => u
  -- Inline functionally used local variables with their initializers.
  inits := [:newInit for (init := [var,expr]) in inits] where 
    newInit() ==
      canInlineVarDefinition(var,expr,body) =>
        body := substitute(expr,var,body)
        nil  -- remove this initialization
      [init] -- otherwwise keep it.
  null inits => body
  u.rest.first := inits
  u.rest.rest.first := body
  -- Avoid initialization forms that may not be floatable.
  not(and/[isFloatableVMForm init for [.,init] in inits]) => u
  -- Identity function.
  inits is [[=body,init]] => init
  -- Handle only most trivial operators.
  body isnt [op,:args] => u
  -- Well, with case-patterns, it is beneficial to try a bit harder
  -- with conditional forms.
  op = "COND" =>
    continue := true      -- shall be continue let-inlining?
    -- Since we do a single pass, we can't reuse the inits list
    -- as we may find later that we can't really inline into
    -- all forms due to excessive conversatism.  So we build a 
    -- substitution list ahead of time.
    substPairs := [[var,:init] for [var,init] in inits]
    for clauses in tails args while continue repeat
      clause := first clauses
      -- we do not attempt more complicated clauses yet.
      clause isnt [test,stmt] => continue := false
      -- Stop inlining at least one test is not simple
      not isSimpleVMForm test => continue := false
      clause.first := SUBLIS(substPairs,test)
      isSimpleVMForm stmt =>
        clause.rest.first := SUBLIS(substPairs,stmt)
      continue := false
    continue => body
    u
  not MEMQ(op,$simpleVMoperators) => u
  not(and/[isAtomicForm arg for arg in args]) => u
  -- Inline only if all parameters are used.  Get cute later.
  not(and/[MEMQ(x,args) for [x,.] in inits]) => u
  -- Munge inits into list of dotted-pairs.  Lovely Lisp.
  for defs in tails inits repeat
    def := first defs
    atom def => systemErrorHere ["optLET",def] -- cannot happen
    def.rest := second def
  SUBLIS(inits,body)

optLET_* form ==
  form isnt ["LET*",:.] => form
  ok := true
  while ok for [[var,.],:inits] in tails second form repeat
    if CONTAINED(var,inits) then ok := false
  not ok => form
  form.first := "LET"
  optLET form

optBind form ==
  form.first := "LET*"
  optLET_* form

optLIST form ==
  form is ["LIST"] => nil
  form

optCollectVector form ==
  [.,eltType,:iters,body] := form
  fromList := false      -- are we drawing from a list?
  vecSize := nil         -- size of vector
  index := nil           -- loop/vector index.
  for iter in iters while not fromList repeat
    [op,:.] := iter
    op in '(SUCHTHAT WHILE UNTIL) => fromList := true
    op in '(IN ON) => vecSize := [["SIZE",third iter],:vecSize]
    op in '(STEP ISTEP) =>
      -- pick a loop variable that we can use as the loop index.
      [.,var,lo,inc,:etc] := iter
      if lo = 0 and inc = 1 then
        index := var
      if [hi] := etc then
        sz :=
          inc = 1 =>
            lo = 1 => hi
            lo = 0 => MKQSADD1 hi
            MKQSADD1 ["-",hi,lo]
          lo = 1 => ["/",hi,inc]
          lo = 0 => ["/",MKQSADD1 hi,inc]
          ["/",["-",MKQSADD1 hi, lo],inc]
        vecSize := [sz, :vecSize]
    systemErrorHere ["optCollectVector", iter]
  -- if we draw from a list, then just build a list and convert to vector.
  fromList => 
    ["homogeneousListToVector",["getVMType",eltType], ['%collect,:iters,body]]
  vecSize = nil => systemErrorHere ["optCollectVector",form]
  -- get the actual size of the vector.
  vecSize :=
    vecSize is [hi] => hi
    ["MIN",:nreverse vecSize]
  -- if no suitable loop index was found, introduce one.
  if index = nil then
    index := gensym()
    iters := [:iters,["ISTEP",index,0,1]]
  vec := gensym()
  ["LET",[[vec,["makeSimpleArray",["getVMType",eltType],vecSize]]],
    ["REPEAT",:iters,["setSimpleArrayEntry",vec,index,body]], 
      vec]

++ Translate retraction of a value denoted by `e' to sub-domain `m'
++ defined by predicate `pred',
optRetract ["%Retract",e,m,pred] ==
  atom e => ["check-subtype",substitute(e,"#1",pred),MKQ m,e]
  g := gensym()
  ["LET",[[g,e]],["check-subtype",substitute(g,"#1",pred),MKQ m,g]]

lispize x == first optimize [x]
 
--% optimizer hash table
 
for x in '( (%Call         optCall) _
           (SEQ          optSEQ)_
           (LET          optLET)_
           (LET_*        optLET_*)_
           (%bind        optBind)_
           (LIST         optLIST)_
           (MINUS        optMINUS)_
           (QSMINUS      optQSMINUS)_
           (_-           opt_-)_
           (LESSP        optLESSP)_
           (SPADCALL     optSPADCALL)_
           (_|           optSuchthat)_
           (CATCH        optCatch)_
           (COND         optCond)_
           (%Retract     optRetract)_
           (%CollectV    optCollectVector)_
           (mkRecord     optMkRecord)_
           (RECORDELT    optRECORDELT)_
           (SETRECORDELT optSETRECORDELT)_
           (RECORDCOPY   optRECORDCOPY)) _
   repeat property(first x,'OPTIMIZE) := second x
       --much quicker to call functions if they have an SBC