From 87eee27996cc401e7d39f7f5c9a19841269f50fc Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sat, 4 Oct 2008 04:19:11 +0000
Subject: 	* interp/c-util.boot (clearReplacement): New. 
 (getFunctionReplacement): Likewise. 	(replaceSimpleFunctions): Likewise. 
 * interp/define.boot (spadCompileOrSetq): Use it.

---
 src/ChangeLog          |  7 +++++++
 src/interp/c-util.boot | 48 +++++++++++++++++++++++++++++++++++++++++++++++-
 src/interp/define.boot |  3 +++
 3 files changed, 57 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/ChangeLog b/src/ChangeLog
index f2303833..fe4e7bb4 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2008-10-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/c-util.boot (clearReplacement): New.
+	(getFunctionReplacement): Likewise.
+	(replaceSimpleFunctions): Likewise.
+	* interp/define.boot (spadCompileOrSetq): Use it.
+
 2008-10-03  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* algebra/Makefile.pamphlet: Turn non optimization for algbera build.
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 7bf1e1b9..28221176 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -35,6 +35,10 @@
 import g_-util
 namespace BOOT
 
+module c_-util where
+  clearReplacement: %Symbol -> %Thing
+  replaceSimpleFunctions: %Form -> %Form
+
 --% 
 ++ if true continue compiling after errors
 $scanIfTrue := false
@@ -830,7 +834,46 @@ ambiguousSignatureError(op, sigs) ==
   stackSemanticError(['"signature of lhs not unique.  Candidates are:",
     :displayAmbiguousSignatures($op,sigs)],nil)
 
---%
+--% 
+
+-- A function is simple if it looks like a super combinator, and it
+-- does not use its environment argument.  They can be safely replaced
+-- by more efficient (hopefully) functions.
+
+getFunctionReplacement: %Symbol -> %Form
+getFunctionReplacement name ==
+  GET(compileTimeBindingOf name, "SPADreplace")
+
+++ remove any replacement info possibly associated with `name'.
+clearReplacement name ==
+  REMPROP(name,"SPADreplace")
+
+++ Walk `form' and replace simple functions as appropriate.
+replaceSimpleFunctions form ==
+  atom form => form
+  form is ["QUOTE",:.] => form
+  -- process argument first.
+  for args in tails rest form repeat
+    arg' := replaceSimpleFunctions(arg := first args)
+    not EQ(arg',arg) =>
+      rplac(first args, arg')
+  -- now, see if we know something about this function.
+  [fun,:args] := form
+  atom fun =>
+    null (fun' := getFunctionReplacement fun) => form
+    -- the renaming case.
+    atom fun' =>
+      rplac(first form,fun')
+      NBUTLAST form
+    -- the substitution case; ignore for now.
+    form
+  fun' := replaceSimpleFunctions fun
+  not EQ(fun',fun) => rplac(first form,fun')
+  form
+    
+
+
+++ record optimizations permitted at level `level'.
 setCompilerOptimizations level ==
   level = nil => nil
   INTEGERP level =>
@@ -843,6 +886,9 @@ setCompilerOptimizations level ==
       $optReplaceSimpleFunctions := true
   coreError '"unknown optimization level request"
 
+
+--%
+
 ++ Proclaim the type of the capsule function `op' with signature `sig'.
 ++ Note that all capsule functions take an additional argument 
 ++ standing for the domain of computation object.
diff --git a/src/interp/define.boot b/src/interp/define.boot
index b607cd4b..5939cdcb 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1231,6 +1231,9 @@ spadCompileOrSetq (form is [nam,[lam,vl,body]]) ==
     renameParameter() ==
       NUMBERP v or IDENTP v or STRINGP v => v
       GENSYM '"flag"
+  clearReplacement nam   -- Make sure we have fresh info
+  if $optReplaceSimpleFunctions then
+    body := replaceSimpleFunctions body
   form := [nam,[lam,vl,body]]
 
   if vl is [:vl',E] and body is [nam',: =vl'] then
-- 
cgit v1.2.3