Expand support for domain inlining to non-niladic functors.

	* interp/compiler.boot (processInlineRequest): Now accept any
	functor.
	* interp/c-util.boot (lookupFunctionInstance): New.
	(isFormal): Likewise.
	(expandFormTemplate): Likewise.
	(equalFormTemplate): Likewise.
	(getFunctionTemplate): Likewise.
	(lookupInheritedDefiningFunction): Likewise.
	(lookupDefiningFunction): Likewise.
	* interp/nruncomp.boot (optDeltaEntry): Tidy.  Use
	lookupDefiningFunction. 

6 files changed, 176 insertions, 22 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 74841751..0010e2d3 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,10 +1,25 @@
+2010-02-22  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	Expand support for domain inlining to non-niladic functors.
+	* interp/compiler.boot (processInlineRequest): Now accept any
+	functor.
+	* interp/c-util.boot (lookupFunctionInstance): New.
+	(isFormal): Likewise.
+	(expandFormTemplate): Likewise.
+	(equalFormTemplate): Likewise.
+	(getFunctionTemplate): Likewise.
+	(lookupInheritedDefiningFunction): Likewise.
+	(lookupDefiningFunction): Likewise.
+	* interp/nruncomp.boot (optDeltaEntry): Tidy.  Use
+	lookupDefiningFunction. 
+
 2010-02-20  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* algebra/boolean.spad.pamphlet (PropositionalFormula):
 	Reimplement in terms of kernels.
 	* algebra/Makefile.pamphlet ($(OUT)/KERNEL.$(FASLEXT)): New
 	dependence rule.
-	($(OUT)PROPFRML.$(FASLEXT)): Likewise.
+	($(OUT)/PROPFRML.$(FASLEXT)): Likewise.
 	(axiom_algebra_layer_19): Move PROPFRML to...
 	(axiom_algebra_layer_6): ...here.
 
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 0214a1af..0f85c636 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -1529,3 +1529,147 @@ compileQuietly fn ==
   quietlyIfInteractive COMP370 fn
 
 
+
+--%
+--% Compile Time operation lookup for the benefit of domain inlining.
+--%
+
+++ Subroutine of lookupDefiningFunction.
+++ Called when the domain of computation `dc' is closed (this is the
+++ case of niladic constructors) to lookup up the definition function
+++ of the operation `op' with signature `sig'.
+lookupFunctionInstance(op,sig,dc) ==
+  dom := eval dc
+  sig := MSUBST(devaluate dom,dc,sig)
+  compiledLookup(op,sig,dom)
+
+++ If `x' is a formal map variable, returns its position.
+++ Otherwise return nil.
+isFormal: %Symbol -> %Maybe %Short
+isFormal x ==
+  POSITION(x,$FormalMapVariableList,KEYWORD::TEST, function EQ)
+
+++ Expand the form at position `slot' in the domain template `shell'
+++ with argument list `args'.
+expandFormTemplate(shell,args,slot) ==
+  FIXP slot =>
+    slot = 0 => "$"
+    slot = 2 => "$$"
+    expandFormTemplate(shell,args,getShellEntry(shell,slot))
+  atom slot => slot
+  slot is ["local",parm] and (n := isFormal parm) => 
+    args.n   -- FIXME: we should probably expand with dual signature
+  slot is ["NRTEVAL",val] => val
+  slot is ["QUOTE",val] => 
+    STRINGP val => val
+    slot
+  [expandFormTemplate(shell,args,i) for i in slot]
+
+++ Compare the form at `slot' in the domain templare `shell'
+++ for equality with `form'.
+equalFormTemplate(shell,args,slot,form) ==
+  FIXP slot =>
+    slot = 0 => form = "$"
+    slot = 2 => form = "$$"
+    equalFormTemplate(shell,args,getShellEntry(shell,slot),form)
+  slot is ["local",parm] and (n := isFormal parm) => 
+    equalFormTemplate(shell,args,args.n,form)
+  slot is ["NTREVAL",val] => form = val
+  slot is ["QUOTE",val] => 
+     STRINGP val => val = form
+     slot = form
+  atom slot or atom form => form = slot
+  #slot ~= #form => false
+  and/[equalFormTemplate(shell,args,i,x) for i in slot for x in form]
+
+++ Subroutine of lookupDefiningFunction.
+++ Return the location of function templates with signature `sig',
+++ descriptor address in the range [start,end), in the domain 
+++ template `shell' whose local reference vector is `funDesc'.
+++ Return value:
+++    nil         => function not defined by `shell'.
+++    "ambiguous" => too many candidates
+++    <number>    => slot number of unique matching function.
+getFunctionTemplate(sig,start,end,shell,args,funDesc) ==
+  nargs := #rest sig
+  loc := nil                           -- candidate locations
+  while loc ~= "ambiguous" and start < end repeat
+    n := funDesc.start                 -- arity of current operator
+    PROGN
+      -- Skip if arity mismatch
+      i := start
+      n ~= nargs => nil
+      -- We are not interested in predicates, at this point.
+      -- Skip if this operator's signature does not match 
+      i := i + 2
+      or/[not equalFormTemplate(shell,args,funDesc.k,t) 
+           for k in i.. for t in sig] => nil
+      -- Grab the location of this match
+      loc := 
+        FIXP loc => "ambiguous"
+        funDesc.(i + n + 1)
+    start := start + n + 4
+  loc
+
+++ Subroutine of lookupDefiningFunction.
+lookupInheritedDefiningFunction(op,sig,shell,args,slot) ==
+  dom := expandFormTemplate(shell,args,slot)
+  atom dom or dom is ["local",:.] => nil
+  lookupDefiningFunction(op,sig,dom)
+
+++ Return the name of the function definition that explicitly implements
+++ the operation `op' with signature `sig' in the domain of 
+++ computation `dc'.  Otherwise, return nil.
+++ Note: Only a function defined by the domain template, or its add-chains,
+++       and that is unambiguous is returned.  In particular, this
+++       function defaulting packages.
+lookupDefiningFunction(op,sig,dc) ==
+  -- 1. Read domain information, if available.
+  [ctor,:args] := dc
+  -- 1.1. Niladic constructors don't need approximation.
+  null args => lookupFunctionInstance(op,sig,dc)
+  -- 1.2. Don't look into defaulting package
+  isDefaultPackageName ctor => nil
+  -- 1.2. Silently give up if the constructor is just not there
+  loadLibIfNotLoaded ctor
+  infovec := GET(ctor, "infovec") or return nil
+  -- 1.3. We need information about the original domain template
+  shell := first infovec               -- domain template
+  opTable := second infovec            -- operator-code table
+  opTableLength := #opTable
+  forgetful := infovec.4 = "lookupIncomplete"
+
+  -- 2. Get the address range of op's descriptor set
+  [.,.,.,:funDesc] := fourth infovec
+  index := getOpCode(op, opTable, opTableLength - 1)
+  -- 2.1. For a forgetful functor, try the add chain
+  index = nil =>
+    forgetful and lookupInheritedDefiningFunction(op,sig,shell,args,5)
+  -- 2.2. The operation is either defined here, or is available
+  --      from category package defaults.
+  limit := 
+    index + 2 < opTableLength => opTable.(index + 2)
+    #funDesc 
+
+  -- 3. Locate the descriptor with matching signature
+  loc := getFunctionTemplate(sig,opTable.index,limit,shell,args,funDesc)
+
+  -- 4. Look into the add-chain if necessary
+  loc = nil => lookupInheritedDefiningFunction(op,sig,shell,args,shell.5)
+
+  -- 5. Give up if the operation is overloaded on semantics predicates.
+  loc = "ambiguous" => nil
+
+  -- 6. We have a location to a function descriptor.
+  fun := shell.loc
+  -- 6.1. A constant producing functions?
+  fun is [.,.,[.,["dispatchFunction",fun'],.]] => fun'
+  -- 6.2. An inherited function?
+  fun is [idx,:.] => 
+    not FIXP idx => nil          -- a UFO?
+    loc := funDesc.(idx + 1)
+    if loc = 0 then loc := 5
+    shell.loc = nil => nil
+    lookupInheritedDefiningFunction(op,sig,shell,args,shell.loc)
+  -- 6.3. Whatever.
+  fun
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index cefcbc4e..44145fe9 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -2230,10 +2230,8 @@ processInlineRequest(t,e) ==
     stackAndThrow('"%1b does not designate a domain",[t])
   atom T.expr =>
     stackWarning('"inline request for type variable %1bp is meaningless",[t])
-  T.expr is [ctor] =>
-    $optimizableConstructorNames := [ctor,:$optimizableConstructorNames]
-  -- Don't try too hard; the current domain evaluation is insane.
-  stackWarning('"Ignoring inline arequest for non-niladic type %1bp",[t])
+  [ctor,:.] := T.expr
+  $optimizableConstructorNames := [ctor,:$optimizableConstructorNames]
 
 
 --%
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 1b969ae2..dce086dc 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -161,16 +161,8 @@ optDeltaEntry(op,sig,dc,eltOrConst) ==
     dc
   sig := MSUBST(ndc,dc,sig)
   not MEMQ(KAR ndc,$optimizableConstructorNames) => nil
-  dcval := optCallEval ndc
-  -- MSUBST guarantees to use EQUAL testing
-  sig := MSUBST(devaluate dcval, ndc, sig)
-  if rest ndc then
-     for new in rest devaluate dcval for old in rest ndc repeat
-       sig := MSUBST(new,old,sig)
-     -- optCallEval sends (List X) to (LIst (Integer)) etc,
-     -- so we should make the same transformation
-  fn := compiledLookup(op,sig,dcval)
-  if null fn then
+  fun := lookupDefiningFunction(op,sig,ndc)
+  if fun = nil then
     -- following code is to handle selectors like first, rest
      nsig := [quoteSelector tt for tt in sig] where
        quoteSelector(x) ==
@@ -178,10 +170,12 @@ optDeltaEntry(op,sig,dc,eltOrConst) ==
          get(x,'value,$e) => x
          x='$ => x
          MKQ x
-     fn := compiledLookup(op,nsig,dcval)
-     if null fn then return nil
-  eltOrConst="CONST" => ['XLAM,'ignore, SPADCALL fn]
-  GETL(compileTimeBindingOf first fn,'SPADreplace)
+     fun := lookupDefiningFunction(op,nsig,ndc)
+  fun = nil => nil
+  if CONSP fun then
+    eltOrConst = "CONST" => return ['XLAM,'ignore, SPADCALL fun]
+    fun := first fun
+  GETL(compileTimeBindingOf fun,'SPADreplace)
 
 genDeltaEntry opMmPair ==
 --called from compApplyModemap
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 813dab7d..7f9e5266 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2009, Gabriel Dos Reis.
+-- Copyright (C) 2007-2010, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -35,6 +35,9 @@
 import c_-util
 namespace BOOT
 
+module nrunfast where
+  getOpCode: (%Symbol, %Vector %Thing, %Short) -> %Maybe %Short
+
 ++
 $doNotCompressHashTableIfTrue := false
 
diff --git a/src/interp/types.boot b/src/interp/types.boot
index 505fbc30..0fe9d04d 100644
--- a/src/interp/types.boot
+++ b/src/interp/types.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2007-2009 Gabriel Dos Reis
+-- Copyright (C) 2007-2010 Gabriel Dos Reis
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without