* interp/g-opt.boot (groupTranscients!): New.

	(reduceXLAM!): Likewise.
	(optimizeFunctionDef): Call them before simplifyVMForm.
	* interp/g-util.boot (mkSeq): New.
	(abstraction?): Likewise.
	(walkWith!): Likewise.

3 files changed, 51 insertions, 1 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index f4814f71..8a6b7a9c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,14 @@
 2011-12-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/g-opt.boot (groupTranscients!): New.
+	(reduceXLAM!): Likewise.
+	(optimizeFunctionDef): Call them before simplifyVMForm.
+	* interp/g-util.boot (mkSeq): New.
+	(abstraction?): Likewise.
+	(walkWith!): Likewise.
+
+2011-12-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/compiler.boot (compReduce1): Tidy.
 	* interp/define.boot (compDefineCategory2): Likewise.
 	* interp/nruncomp.boot (buildFunctor): Likewise.
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index d5eaa8be..1bf11beb 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -194,6 +194,26 @@ groupVariableDefinitions form ==
     ['%seq,:stmts,['%exit,val]]
   mkBind(defs,expr)
 
+++ Group all %LET-definitions of artificial/temporary variables
+++ into %bind-forms, appropriate for inlining in later stages.
+groupTranscients! x == walkWith!(x,function f) where
+  f x ==
+    x is ['%scope,tag,y] and y is ['%seq,:.] =>
+      defs := [s.args for s in y.args while s is ['%LET,z,u]
+                 and gensym? z and hasNoLeave?(u,tag)]
+      defs = nil => x
+      resetTo(x,mkBind(defs,mkScope(tag,mkSeq drop(#defs,y.args))))
+    x
+
+++ Reduce all applications of XLAM-abstractions to arguments.
+++ This is done before simplifyVMForm to expose more opportunities
+++ for further reductions.
+reduceXLAM! x == walkWith!(x,function f) where
+  f x ==
+    x is ['%call,y,:args] and y is ['XLAM,:.] =>
+     resetTo(x,doInlineCall(args,y.absParms,copyTree y.absBody))
+    x
+
 optimizeFunctionDef(def) ==
   if $reportOptimization then
     sayBrightlyI bright '"Original LISP code:"
@@ -201,7 +221,7 @@ optimizeFunctionDef(def) ==
  
   expr := copyTree second def
   changeVariableDefinitionToStore(expr.absBody,expr.absParms)
-  expr := simplifyVMForm expr
+  expr := simplifyVMForm reduceXLAM! groupTranscients! expr
  
   if $reportOptimization then
     sayBrightlyI bright '"Intermediate VM code:"
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 7e15d637..a43ff7c7 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -38,6 +38,7 @@ import daase
 namespace BOOT
 
 module g_-util where
+  abstraction?: %Form -> %Boolean
   getTypeOfSyntax: %Form -> %Mode
   pairList: (%List %Form,%List %Form) -> %List %Pair(%Form,%Form)
   mkList: %List %Form -> %Form
@@ -46,9 +47,13 @@ module g_-util where
   isDefaultPackageName: %Symbol -> %Boolean
   makeDefaultPackageName: %String -> %Symbol
   spliceSeqArgs: %List %Code -> %Code
+  mkSeq: %List %Code -> %Code
 
 --%
 
+abstraction? x ==
+  x is [op,:.] and ident? op and abstractionOperator? op
+
 hasNoLeave?(expr,g) ==
   expr is ['%leave, =g,:.] => false
   expr isnt [.,:.] => true
@@ -68,6 +73,10 @@ mkBind(inits,expr) ==
     mkBind([:inits,:inits'],expr')
   ['%bind,inits,expr]
 
+mkSeq stmts ==
+  stmts is [s] => s
+  ['%seq,:stmts]
+
 ++ Given a (possibly multiple) assignment expression `u', return
 ++ the list of all assignment sub-expressions that must be evaluated before
 ++ effecting the toplevel assignment indicated by `u'.  In that case,
@@ -101,6 +110,18 @@ spliceSeqArgs l ==
   l.rest := spliceSeqArgs rest l
   l
 
+++ Apply the function `f' on all non-atomic subforms of `x' in
+++ depth-first walk.  Mutate `x' in place, replacing each sub-form
+++ with the result of applying `f' to that subform.
+walkWith!(x,f) ==
+  atomic? x => x
+  abstraction? x =>
+    x.absBody := walkWith!(x.absBody,f)
+    x
+  for ys in tails x | not atomic? first ys repeat
+    ys.first := walkWith!(first ys,f)
+  apply(f,x,nil)
+
 --%
 
 ++ List of category constructors that do not have entries in the