* interp/g-opt.boot ($VMsideEffectFreeOperators): New.

	($simpleVMoperators): Augment it.
	(semiSimpleRelativeTo?): New.
	(isSimpleVMForm): Use it.
	* interp/c-util.boot (forwardingCall?): New.
	(usesVariablesLinearly?): Likewise.
	(expandableDefinition?): Likewise.
	(foldSpadcall): Tidy.
	(foldExportedFunctionReferences): If a function is discovered to
	be expandable, make it so.
	* interp/define.boot (spadCompileOrSetq): Tidy.

9 files changed, 151 insertions, 42 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 59e0a207..6874485c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,17 @@
+2010-03-06  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/g-opt.boot ($VMsideEffectFreeOperators): New.
+	($simpleVMoperators): Augment it.
+	(semiSimpleRelativeTo?): New.
+	(isSimpleVMForm): Use it.
+	* interp/c-util.boot (forwardingCall?): New.
+	(usesVariablesLinearly?): Likewise.
+	(expandableDefinition?): Likewise.
+	(foldSpadcall): Tidy.
+	(foldExportedFunctionReferences): If a function is discovered to
+	be expandable, make it so.
+	* interp/define.boot (spadCompileOrSetq): Tidy.
+
 2010-03-05  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/nruncomp.boot (optDeltaEntry): Silently fail for domains
diff --git a/src/algebra/strap/DFLOAT.lsp b/src/algebra/strap/DFLOAT.lsp
index 9795065f..61278b24 100644
--- a/src/algebra/strap/DFLOAT.lsp
+++ b/src/algebra/strap/DFLOAT.lsp
@@ -93,6 +93,9 @@
                     |%Boolean|)
                 |DFLOAT;<=;2$B;22|)) 
 
+(PUT '|DFLOAT;<=;2$B;22| '|SPADreplace|
+     '(XLAM (|x| |y|) (NOT (> |x| |y|)))) 
+
 (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%DoubleFloat| |%Shell|)
                     |%Boolean|)
                 |DFLOAT;>=;2$B;23|)) 
@@ -504,7 +507,9 @@
 
 (DEFUN |DFLOAT;>;2$B;21| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|)) 
 
-(DEFUN |DFLOAT;<=;2$B;22| (|x| |y| $) (NOT (> |x| |y|))) 
+(DEFUN |DFLOAT;<=;2$B;22| (|x| |y| $)
+  (DECLARE (IGNORE $))
+  (NOT (> |x| |y|))) 
 
 (DEFUN |DFLOAT;>=;2$B;23| (|x| |y| $)
   (DECLARE (IGNORE $))
diff --git a/src/algebra/strap/INT.lsp b/src/algebra/strap/INT.lsp
index 39bb22ff..8640f50b 100644
--- a/src/algebra/strap/INT.lsp
+++ b/src/algebra/strap/INT.lsp
@@ -160,6 +160,9 @@
 (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| |%Shell|) |%Boolean|)
                 |INT;<=;2$B;37|)) 
 
+(PUT '|INT;<=;2$B;37| '|SPADreplace|
+     '(XLAM (|x| |y|) (NOT (> |x| |y|)))) 
+
 (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| |%Shell|) |%Boolean|)
                 |INT;>=;2$B;38|)) 
 
@@ -411,7 +414,9 @@
 
 (DEFUN |INT;>;2$B;36| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|)) 
 
-(DEFUN |INT;<=;2$B;37| (|x| |y| $) (NOT (> |x| |y|))) 
+(DEFUN |INT;<=;2$B;37| (|x| |y| $)
+  (DECLARE (IGNORE $))
+  (NOT (> |x| |y|))) 
 
 (DEFUN |INT;>=;2$B;38| (|x| |y| $) (DECLARE (IGNORE $)) (>= |x| |y|)) 
 
diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp
index 70450c5b..24cf2826 100644
--- a/src/algebra/strap/ISTRING.lsp
+++ b/src/algebra/strap/ISTRING.lsp
@@ -9,9 +9,6 @@
 
 (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Thing|) |ISTRING;empty;$;2|)) 
 
-(PUT '|ISTRING;empty;$;2| '|SPADreplace|
-     '(XLAM NIL (MAKE-FULL-CVEC 0))) 
-
 (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Boolean|)
                 |ISTRING;empty?;$B;3|)) 
 
@@ -135,9 +132,7 @@
   (DECLARE (IGNORE $))
   (MAKE-FULL-CVEC |n| |c|)) 
 
-(DEFUN |ISTRING;empty;$;2| ($)
-  (DECLARE (IGNORE $))
-  (MAKE-FULL-CVEC 0)) 
+(DEFUN |ISTRING;empty;$;2| ($) (MAKE-FULL-CVEC 0)) 
 
 (DEFUN |ISTRING;empty?;$B;3| (|s| $) (EQL (QCSIZE |s|) 0)) 
 
diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp
index fca0ec38..2d765749 100644
--- a/src/algebra/strap/OUTFORM.lsp
+++ b/src/algebra/strap/OUTFORM.lsp
@@ -355,8 +355,6 @@
 
 (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Thing|) |OUTFORM;empty;$;73|)) 
 
-(PUT '|OUTFORM;empty;$;73| '|SPADreplace| '(XLAM NIL (LIST 'NOTHING))) 
-
 (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Boolean|)
                 |OUTFORM;infix?;$B;74|)) 
 
@@ -518,6 +516,15 @@
 (PUT '|OUTFORM;int;4$;106| '|SPADreplace|
      '(XLAM (|a| |b| |c|) (LIST 'INTSIGN |b| |c| |a|))) 
 
+(PUT '|OUTFORM;postfix;3$;79| '|SPADreplace|
+     '(XLAM (|a| |b|) (LIST 'CONCAT |b| |a|))) 
+
+(PUT '|OUTFORM;dot;2$;83| '|SPADreplace|
+     '(XLAM (|a|) (LIST 'SUPERSUB |a| " " '|.|))) 
+
+(PUT '|OUTFORM;prime;2$;84| '|SPADreplace|
+     '(XLAM (|a|) (LIST 'SUPERSUB |a| " " '|,|))) 
+
 (DEFUN |OUTFORM;doubleFloatFormat;2S;1| (|s| $)
   (PROG (|ss|)
     (RETURN
@@ -539,7 +546,7 @@
 
 (DEFUN |OUTFORM;message;S$;7| (|s| $)
   (COND
-    ((SPADCALL |s| (|getShellEntry| $ 12)) (LIST 'NOTHING))
+    ((SPADCALL |s| (|getShellEntry| $ 12)) (|OUTFORM;empty;$;73| $))
     ('T |s|))) 
 
 (DEFUN |OUTFORM;messagePrint;SV;8| (|s| $)
@@ -615,15 +622,18 @@
     ((> |n| 0)
      (|OUTFORM;vconcat;3$;50| " " (|OUTFORM;vspace;I$;28| (- |n| 1) $)
          $))
-    ('T (LIST 'NOTHING)))) 
+    ('T (|OUTFORM;empty;$;73| $)))) 
 
 (DEFUN |OUTFORM;hspace;I$;29| (|n| $)
-  (COND ((> |n| 0) (|fillerSpaces| |n|)) ('T (LIST 'NOTHING)))) 
+  (COND
+    ((> |n| 0) (|fillerSpaces| |n|))
+    ('T (|OUTFORM;empty;$;73| $)))) 
 
 (DEFUN |OUTFORM;rspace;2I$;30| (|n| |m| $)
   (SEQ (COND
-         ((> |n| 0) (COND ((NOT (> |m| 0)) (EXIT (LIST 'NOTHING)))))
-         ('T (EXIT (LIST 'NOTHING))))
+         ((> |n| 0)
+          (COND ((NOT (> |m| 0)) (EXIT (|OUTFORM;empty;$;73| $)))))
+         ('T (EXIT (|OUTFORM;empty;$;73| $))))
        (EXIT (|OUTFORM;vconcat;3$;50| (|OUTFORM;hspace;I$;29| |n| $)
                  (|OUTFORM;rspace;2I$;30| |n| (- |m| 1) $) $)))) 
 
@@ -734,7 +744,7 @@
 (DEFUN |OUTFORM;supersub;$L$;47| (|a| |l| $)
   (SEQ (COND
          ((ODDP (LENGTH |l|))
-          (LETT |l| (APPEND |l| (LIST (LIST 'NOTHING)))
+          (LETT |l| (APPEND |l| (LIST (|OUTFORM;empty;$;73| $)))
                 |OUTFORM;supersub;$L$;47|)))
        (EXIT (CONS 'ALTSUPERSUB (CONS |a| |l|))))) 
 
@@ -836,7 +846,7 @@
   (DECLARE (IGNORE $))
   (LIST 'BINOMIAL |a| |b|)) 
 
-(DEFUN |OUTFORM;empty;$;73| ($) (DECLARE (IGNORE $)) (LIST 'NOTHING)) 
+(DEFUN |OUTFORM;empty;$;73| ($) (LIST 'NOTHING)) 
 
 (DEFUN |OUTFORM;infix?;$B;74| (|a| $)
   (PROG (#0=#:G1495 |e|)
@@ -866,7 +876,7 @@
 
 (DEFUN |OUTFORM;infix;$L$;77| (|a| |l| $)
   (COND
-    ((NULL |l|) (LIST 'NOTHING))
+    ((NULL |l|) (|OUTFORM;empty;$;73| $))
     ((NULL (CDR |l|)) (SPADCALL |l| (|getShellEntry| $ 78)))
     ((|OUTFORM;infix?;$B;74| |a| $) (CONS |a| |l|))
     ('T
@@ -880,7 +890,9 @@
     ((|OUTFORM;infix?;$B;74| |a| $) (LIST |a| |b| |c|))
     ('T (|OUTFORM;hconcat;L$;49| (LIST |b| |a| |c|) $)))) 
 
-(DEFUN |OUTFORM;postfix;3$;79| (|a| |b| $) (LIST 'CONCAT |b| |a|)) 
+(DEFUN |OUTFORM;postfix;3$;79| (|a| |b| $)
+  (DECLARE (IGNORE $))
+  (LIST 'CONCAT |b| |a|)) 
 
 (DEFUN |OUTFORM;string;2$;80| (|a| $)
   (DECLARE (IGNORE $))
@@ -894,9 +906,13 @@
   (DECLARE (IGNORE $))
   (LIST 'OVERBAR |a|)) 
 
-(DEFUN |OUTFORM;dot;2$;83| (|a| $) (LIST 'SUPERSUB |a| " " '|.|)) 
+(DEFUN |OUTFORM;dot;2$;83| (|a| $)
+  (DECLARE (IGNORE $))
+  (LIST 'SUPERSUB |a| " " '|.|)) 
 
-(DEFUN |OUTFORM;prime;2$;84| (|a| $) (LIST 'SUPERSUB |a| " " '|,|)) 
+(DEFUN |OUTFORM;prime;2$;84| (|a| $)
+  (DECLARE (IGNORE $))
+  (LIST 'SUPERSUB |a| " " '|,|)) 
 
 (DEFUN |OUTFORM;dot;$Nni$;85| (|a| |nn| $)
   (PROG (|s|)
@@ -975,7 +991,8 @@
                    (EXIT (|OUTFORM;super;3$;43| |a| (LIST 'PAREN |s|)
                              $))))))))) 
 
-(DEFUN |OUTFORM;sum;2$;98| (|a| $) (LIST 'SIGMA (LIST 'NOTHING) |a|)) 
+(DEFUN |OUTFORM;sum;2$;98| (|a| $)
+  (LIST 'SIGMA (|OUTFORM;empty;$;73| $) |a|)) 
 
 (DEFUN |OUTFORM;sum;3$;99| (|a| |b| $)
   (DECLARE (IGNORE $))
@@ -985,7 +1002,8 @@
   (DECLARE (IGNORE $))
   (LIST 'SIGMA2 |b| |c| |a|)) 
 
-(DEFUN |OUTFORM;prod;2$;101| (|a| $) (LIST 'PI (LIST 'NOTHING) |a|)) 
+(DEFUN |OUTFORM;prod;2$;101| (|a| $)
+  (LIST 'PI (|OUTFORM;empty;$;73| $) |a|)) 
 
 (DEFUN |OUTFORM;prod;3$;102| (|a| |b| $)
   (DECLARE (IGNORE $))
@@ -996,10 +1014,10 @@
   (LIST 'PI2 |b| |c| |a|)) 
 
 (DEFUN |OUTFORM;int;2$;104| (|a| $)
-  (LIST 'INTSIGN (LIST 'NOTHING) (LIST 'NOTHING) |a|)) 
+  (LIST 'INTSIGN (|OUTFORM;empty;$;73| $) (|OUTFORM;empty;$;73| $) |a|)) 
 
 (DEFUN |OUTFORM;int;3$;105| (|a| |b| $)
-  (LIST 'INTSIGN |b| (LIST 'NOTHING) |a|)) 
+  (LIST 'INTSIGN |b| (|OUTFORM;empty;$;73| $) |a|)) 
 
 (DEFUN |OUTFORM;int;4$;106| (|a| |b| |c| $)
   (DECLARE (IGNORE $))
diff --git a/src/algebra/strap/SINT.lsp b/src/algebra/strap/SINT.lsp
index 6f567c8e..840a7fcf 100644
--- a/src/algebra/strap/SINT.lsp
+++ b/src/algebra/strap/SINT.lsp
@@ -112,6 +112,9 @@
 (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Boolean|)
                 |SINT;<=;2$B;26|)) 
 
+(PUT '|SINT;<=;2$B;26| '|SPADreplace|
+     '(XLAM (|x| |y|) (NOT (> |x| |y|)))) 
+
 (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Boolean|)
                 |SINT;>=;2$B;27|)) 
 
@@ -239,12 +242,18 @@
 (DECLAIM (FTYPE (FUNCTION (|%Shell|) (|%IntegerSection| 0))
                 |SINT;size;Nni;52|)) 
 
+(PUT '|SINT;size;Nni;52| '|SPADreplace|
+     '(XLAM NIL (+ (- |$ShortMaximum| |$ShortMinimum|) 1))) 
+
 (DECLAIM (FTYPE (FUNCTION ((|%IntegerSection| 1) |%Shell|) |%Short|)
                 |SINT;index;Pi$;53|)) 
 
 (DECLAIM (FTYPE (FUNCTION (|%Short| |%Shell|) (|%IntegerSection| 1))
                 |SINT;lookup;$Pi;54|)) 
 
+(PUT '|SINT;lookup;$Pi;54| '|SPADreplace|
+     '(XLAM (|x|) (+ (- |x| |$ShortMinimum|) 1))) 
+
 (DECLAIM (FTYPE (FUNCTION (|%Thing| (|%Vector| *) |%Shell|) |%Pair|)
                 |SINT;reducedSystem;MVR;55|)) 
 
@@ -375,7 +384,9 @@
   (DECLARE (IGNORE $))
   (QSGREATERP |x| |y|)) 
 
-(DEFUN |SINT;<=;2$B;26| (|x| |y| $) (NOT (> |x| |y|))) 
+(DEFUN |SINT;<=;2$B;26| (|x| |y| $)
+  (DECLARE (IGNORE $))
+  (NOT (> |x| |y|))) 
 
 (DEFUN |SINT;>=;2$B;27| (|x| |y| $) (DECLARE (IGNORE $)) (>= |x| |y|)) 
 
@@ -458,6 +469,7 @@
   (QSMINUSP |x|)) 
 
 (DEFUN |SINT;size;Nni;52| ($)
+  (DECLARE (IGNORE $))
   (+ (- |$ShortMaximum| |$ShortMinimum|) 1)) 
 
 (DEFUN |SINT;index;Pi$;53| (|i| $)
@@ -467,7 +479,9 @@
                    |SINT;index;Pi$;53|)
         (|check-subtype| (SMINTP #0#) '(|SingleInteger|) #0#))))) 
 
-(DEFUN |SINT;lookup;$Pi;54| (|x| $) (+ (- |x| |$ShortMinimum|) 1)) 
+(DEFUN |SINT;lookup;$Pi;54| (|x| $)
+  (DECLARE (IGNORE $))
+  (+ (- |x| |$ShortMinimum|) 1)) 
 
 (DEFUN |SINT;reducedSystem;MVR;55| (|m| |v| $)
   (DECLARE (IGNORE $))
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 45afea96..4df0052f 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1105,11 +1105,50 @@ replaceSimpleFunctions form ==
   form
 
 
+++ We are processing a function definition with parameter list `vars'
+++ and body given by `body'.  If `body' is a forwarding function call, 
+++ return the target function.  Otherwise, return nil.
+forwardingCall?(vars,body) ==
+  vars is [:vars',.] and body is [fun,: =vars'] and IDENTP fun => fun
+  nil
+
+
+++ Return true if `form' has a linear usage of all variables in `vars'.
+usesVariablesLinearly?(form,vars) ==
+  isAtomicForm form => true
+  and/[numOfOccurencesOf(var,form) < 2 for var in vars] 
+
+++ We are processing a function definition with parameter list `vars'
+++ and body given by `body'.  If `body' is a form that can be inlined,
+++ then return the inline form.  Otherwise, return nil.
+expandableDefinition?(vars,body) ==
+  expand? :=
+    -- We definitely don't want to expand a form that uses
+    -- the domain of computation environment.
+    vars isnt [:vars',env] or CONTAINED(env,body) => false
+
+    -- Constants are currently implemented as niladic functions, and
+    -- we want to avoid disturbing object identity, so we rule
+    -- out use of side-effect full operators.  
+    -- FIXME: This should be done only for constant creators.
+    null vars' => semiSimpleRelativeTo?(body,$VMsideEffectFreeOperators)
+
+    isAtomicForm body => true
+    [op,:args] := body
+    not IDENTP op => false
+    and/[isAtomicForm x for x in args] 
+      or semiSimpleRelativeTo?(body,$simpleVMoperators) =>
+                usesVariablesLinearly?(body,vars')
+    false
+  expand? => ["XLAM",vars',body]
+  nil
+
 ++ Replace all SPADCALLs to operations defined in the current
 ++ domain.  Conditional operations are not folded.
 foldSpadcall: %Form -> %Form
 foldSpadcall form ==
-  isAtomicForm form => form
+  isAtomicForm form => form           -- leave atomic forms alone
+  form is ["DECLARE",:.] => form      -- don't walk declarations
   form is ["LET",inits,:body] =>
     mutateLETFormWithUnaryFunction(form,"foldSpadcall")
   form is ["COND",:stmts] =>
@@ -1129,8 +1168,13 @@ foldSpadcall form ==
 ++ with their corresponding linkage names.  
 foldExportedFunctionReferences defs ==
   for fun in defs repeat
-    foldSpadcall fun is [.,lamex] =>
-      rplac(third lamex, replaceSimpleFunctions third lamex)
+    fun isnt [name,lamex] => nil
+    lamex isnt ["LAM",vars,body] => nil
+    body := replaceSimpleFunctions foldSpadcall body
+    form := expandableDefinition?(vars,body) =>
+      registerFunctionReplacement(name,form)
+      rplac(second fun, ["LAM",vars,["DECLARE",["IGNORE",last vars]],body])
+    rplac(third lamex,body)
   defs
 
 ++ record optimizations permitted at level `level'.
diff --git a/src/interp/define.boot b/src/interp/define.boot
index d25302e8..5a8930ee 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1246,17 +1246,16 @@ spadCompileOrSetq (form is [nam,[lam,vl,body]]) ==
   if $optReplaceSimpleFunctions then
     body := replaceSimpleFunctions body
 
-  if vl is [:vl',E] and body is [nam',: =vl'] then
+  if nam' := forwardingCall?(vl,body) then
       registerFunctionReplacement(nam,nam')
       sayBrightly ['"     ",:bright nam,'"is replaced by",:bright nam']
-  else if (isAtomicForm body or and/[isAtomicForm x for x in body])
-         and vl is [:vl',E] and not CONTAINED(E,body) then
-           macform := ['XLAM,vl',body]
+  else if macform := expandableDefinition?(vl,body) then
            registerFunctionReplacement(nam,macform)
            sayBrightly ['"     ",:bright nam,'"is replaced by",:bright body]
 
   form := 
-    getFunctionReplacement nam => [nam,[lam,vl,["DECLARE",["IGNORE",E]],body]]
+    getFunctionReplacement nam => 
+      [nam,[lam,vl,["DECLARE",["IGNORE",last vl]],body]]
     [nam,[lam,vl,body]]
 
   $insideCapsuleFunctionIfTrue => 
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 8110587e..38613f11 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -392,16 +392,31 @@ optLESSP u ==
     ['GREATERP,b,a]
   u
  
-$simpleVMoperators == 
-  '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
-    SPADfirst QVELT _+ _- _* _< _= ASH INTEGER_-LENGTH
+++ 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)
+      MINUSP GREATERP ZEROP ODDP FLOAT_-RADIX FLOAT FLOAT_-SIGN FLOAT_-DIGITS
+       CGREATERP GGREATERP CHAR BOOLE GET BVEC_-GREATER FUNCALL)
 
-isSimpleVMForm form ==
+++ List of simple VM operators
+$simpleVMoperators == 
+  append($VMsideEffectFreeOperators,
+    ["CONS","LIST","VECTOR","STRINGIMAGE",
+      "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 is [op,:args] and MEMQ(op,$simpleVMoperators) 
-    and ("and"/[isAtomicForm arg for arg in args])
+  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.