From 3f8bdbabb7bfcf9b021fe1529e603e931b57bf13 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 23 Feb 2010 05:22:37 +0000 Subject: 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. --- configure | 18 +++--- configure.ac | 2 +- configure.ac.pamphlet | 2 +- src/ChangeLog | 17 +++++- src/interp/c-util.boot | 146 ++++++++++++++++++++++++++++++++++++++++++++++- src/interp/compiler.boot | 6 +- src/interp/nruncomp.boot | 22 +++---- src/interp/nrunfast.boot | 5 +- src/interp/types.boot | 2 +- 9 files changed, 187 insertions(+), 33 deletions(-) diff --git a/configure b/configure index 22596d0c..e53d3631 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2010-02-20. +# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2010-02-22. # # Report bugs to . # @@ -745,8 +745,8 @@ SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='OpenAxiom' PACKAGE_TARNAME='openaxiom' -PACKAGE_VERSION='1.4.0-2010-02-20' -PACKAGE_STRING='OpenAxiom 1.4.0-2010-02-20' +PACKAGE_VERSION='1.4.0-2010-02-22' +PACKAGE_STRING='OpenAxiom 1.4.0-2010-02-22' PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net' ac_unique_file="src/Makefile.pamphlet" @@ -1511,7 +1511,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OpenAxiom 1.4.0-2010-02-20 to adapt to many kinds of systems. +\`configure' configures OpenAxiom 1.4.0-2010-02-22 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1581,7 +1581,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-02-20:";; + short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-02-22:";; esac cat <<\_ACEOF @@ -1688,7 +1688,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OpenAxiom configure 1.4.0-2010-02-20 +OpenAxiom configure 1.4.0-2010-02-22 generated by GNU Autoconf 2.63 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1702,7 +1702,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OpenAxiom $as_me 1.4.0-2010-02-20, which was +It was created by OpenAxiom $as_me 1.4.0-2010-02-22, which was generated by GNU Autoconf 2.63. Invocation command line was $ $0 $@ @@ -21165,7 +21165,7 @@ exec 6>&1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OpenAxiom $as_me 1.4.0-2010-02-20, which was +This file was extended by OpenAxiom $as_me 1.4.0-2010-02-22, which was generated by GNU Autoconf 2.63. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -21228,7 +21228,7 @@ Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_version="\\ -OpenAxiom config.status 1.4.0-2010-02-20 +OpenAxiom config.status 1.4.0-2010-02-22 configured by $0, generated by GNU Autoconf 2.63, with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac index 30fd65fc..f257c48e 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.4.0-2010-02-20], +AC_INIT([OpenAxiom], [1.4.0-2010-02-22], [open-axiom-bugs@lists.sf.net]) AC_CONFIG_AUX_DIR(config) diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet index b07464dc..009aa656 100644 --- a/configure.ac.pamphlet +++ b/configure.ac.pamphlet @@ -1200,7 +1200,7 @@ information: <>= sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.4.0-2010-02-20], +AC_INIT([OpenAxiom], [1.4.0-2010-02-22], [open-axiom-bugs@lists.sf.net]) @ 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 + + 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 * 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 +++ => 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 -- cgit v1.2.3