diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 17 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 146 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 6 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 22 | ||||
| -rw-r--r-- | src/interp/nrunfast.boot | 5 | ||||
| -rw-r--r-- | src/interp/types.boot | 2 |
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 |