From b751bf4b87bb5f784e3a08185e69a43efac23e48 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 5 Mar 2011 14:17:54 +0000 Subject: * interp/nrunopt.boot: Move content to define.boot, interop.boot, lisplib.boot, nruncomp.boot, showimp.boot. Delete. --- src/ChangeLog | 5 + src/interp/Makefile.in | 5 +- src/interp/define.boot | 275 ++++++++++++++ src/interp/interop.boot | 60 ++++ src/interp/lisplib.boot | 154 ++++++++ src/interp/nruncomp.boot | 50 ++- src/interp/nrunopt.boot | 918 ----------------------------------------------- src/interp/showimp.boot | 347 ++++++++++++++++++ 8 files changed, 891 insertions(+), 923 deletions(-) delete mode 100644 src/interp/nrunopt.boot (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index f18f74f7..c7e8d399 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,8 @@ +2011-03-04 Gabriel Dos Reis + + * interp/nrunopt.boot: Move content to define.boot, interop.boot, + lisplib.boot, nruncomp.boot, showimp.boot. Delete. + 2011-03-02 Gabriel Dos Reis * interp/nrungo.boot: Move content to buildom.boot, i-map.boot, diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index a4b5f730..8934bad6 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -105,7 +105,6 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ msgdb.$(FASLEXT) \ newaux.$(FASLEXT) newfort.$(FASLEXT) \ nrunfast.$(FASLEXT) \ - nrunopt.$(FASLEXT) \ osyscmd.$(FASLEXT) \ packtran.$(FASLEXT) \ pf2sex.$(FASLEXT) \ @@ -348,10 +347,8 @@ setvart.$(FASLEXT): macros.$(FASLEXT) wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT) wi1.$(FASLEXT): macros.$(FASLEXT) compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT) -nrunopt.$(FASLEXT): c-util.$(FASLEXT) nrunfast.$(FASLEXT): c-util.$(FASLEXT) -nruncomp.$(FASLEXT): nrunopt.$(FASLEXT) profile.$(FASLEXT) \ - simpbool.$(FASLEXT) functor.$(FASLEXT) +nruncomp.$(FASLEXT): profile.$(FASLEXT) simpbool.$(FASLEXT) functor.$(FASLEXT) nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT) define.$(FASLEXT): g-error.$(FASLEXT) modemap.$(FASLEXT) \ nruncomp.$(FASLEXT) database.$(FASLEXT) diff --git a/src/interp/define.boot b/src/interp/define.boot index 695a1ac8..66608c6b 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -113,6 +113,281 @@ compDefineAddSignature: (%Form,%Signature,%Env) -> %Env DomainSubstitutionFunction: (%List,%Form) -> %Form +--% + +--======================================================================= +-- Generate Code to Create Infovec +--======================================================================= +getInfovecCode() == +--Function called by compDefineFunctor1 to create infovec at compile time + ['LIST, + MKQ makeDomainTemplate $template, + MKQ makeCompactDirect $NRTslot1Info, + MKQ NRTgenFinalAttributeAlist(), + NRTmakeCategoryAlist(), + MKQ $lookupFunction] + +--======================================================================= +-- Generation of Domain Vector Template (Compile Time) +--======================================================================= +makeDomainTemplate vec == +--NOTES: This function is called at compile time to create the template +-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 + newVec := newShell # vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + newVec.index := + atom item => item + cons? first item => makeGoGetSlot(item,index) + item + $byteVec := "append"/nreverse $byteVec + newVec + +makeGoGetSlot(item,index) == +--NOTES: creates byte vec strings for LATCH slots +--these parts of the $byteVec are created first; see also makeCompactDirect + [sig,whereToGo,op,:flag] := item + n := #sig - 1 + newcode := [n,whereToGo,:makeCompactSigCode sig,index] + $byteVec := [newcode,:$byteVec] + curAddress := $byteAddress + $byteAddress := $byteAddress + n + 4 + [curAddress,:op] + +--======================================================================= +-- Generate OpTable at Compile Time +--======================================================================= +--> called by getInfovecCode (see top of this file) from compDefineFunctor1 +makeCompactDirect u == + $predListLength :local := # $NRTslot1PredicateList + $byteVecAcc: local := nil + [nam,[addForm,:opList]] := u + --pp opList + d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] + $byteVec := [:$byteVec,:"append"/nreverse $byteVecAcc] + LIST2VEC ("append"/d) + +makeCompactDirect1(op,items) == +--NOTES: creates byte codes for ops implemented by the domain + curAddress := $byteAddress + $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) + newcodes := + "append"/[u for y in orderBySubsumption items | u := fn y] or return nil + $byteVecAcc := [newcodes,:$byteVecAcc] + curAddress + where fn y == + [sig,:r] := y + r = ['Subsumed] => + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + [n,0,:makeCompactSigCode sig,0] --always followed by subsuming signature + --identified by a 0 in slot position + if r is [n,:s] then + slot := + n is [p,:.] => p --the rest is linenumber of function definition + n + predCode := + s is [pred,:.] => predicateBitIndex pred + 0 + --> drop items which are not present (predCode = -1) + predCode = -1 => return nil + --> drop items with NIL slots if lookup function is incomplete + if null slot then + $lookupFunction = 'lookupIncomplete => return nil + slot := 1 --signals that operation is not present + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + res := [n,predCode,:makeCompactSigCode sig,slot] + res + +orderBySubsumption items == + acc := subacc := nil + for x in items repeat + not $op in '(Zero One) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] + acc := [x,:acc] + y := z := nil + for [a,b,:.] in subacc | b repeat + --NOTE: b = nil means that the signature a will appear in acc, that this + -- entry is be ignored (e.g. init: -> $ in ULS) + while (u := assoc(b,subacc)) repeat b := second u + u := assoc(b,acc) or systemError nil + if null second u then u := [first u,1] --mark as missing operation + y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed + z := insert(b,z) --mark a signature as already present + [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming + +makeCompactSigCode sig == [fn for x in sig] where + fn() == + x = "$$" => 2 + x = "$" => 0 + not integer? x => + systemError ['"code vector slot is ",x,'"; must be number"] + x + +--======================================================================= +-- Generate Slot 4 Constructor Vectors +--======================================================================= +NRTmakeCategoryAlist() == + $depthAssocCache: local := hashTable 'EQ + $catAncestorAlist: local := NIL + pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] + $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] + opcAlist := nreverse SORTBY(function NRTcatCompare,pcAlist) + newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] + slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) + | (k := predicateBitIndex b) ~= -1] + slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] + sixEtc := [5 + i for i in 1..#$pairlis] + formals := ASSOCRIGHT $pairlis + for x in slot1 repeat + x.first := EQSUBSTLIST(["$$",:sixEtc],['$,:formals],first x) + -----------code to make a new style slot4 ----------------- + predList := ASSOCRIGHT slot1 --is list of predicate indices + maxPredList := "MAX"/predList + catformvec := ASSOCLEFT slot1 + maxElement := "MAX"/$byteVec + ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], + ['CONS, MKQ LIST2VEC slot0, + ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], + ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] + --NOTE: this is new form: old form satisfies vector? CDDR form + +encodeCatform x == + k := NRTassocIndex x => k + atom x or atom rest x => x + [first x,:[encodeCatform y for y in rest x]] + +NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) + +hasDefaultPackage catname == + defname := makeSymbol strconc(catname,'"&") + constructor? defname => defname + nil + + +--======================================================================= +-- Compute the lookup function (complete or incomplete) +--======================================================================= +NRTgetLookupFunction(domform,exCategory,addForm) == + domform := SUBLIS($pairlis,domform) + addForm := SUBLIS($pairlis,addForm) + $why: local := nil + atom addForm => 'lookupComplete + extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) + if null extends then + [u,msg,:v] := $why + SAY '"--------------non extending category----------------------" + sayPatternMsg('"%1p of category %2p", [domform,u]) + if v ~= nil then + sayPatternMsg('"%1b %2p",[msg,first v]) + else + sayPatternMsg('"%1b",[msg]) + SAY '"----------------------------------------------------------" + extends => 'lookupIncomplete + 'lookupComplete + +getExportCategory form == + [op,:argl] := form + op = 'Record => ['RecordCategory,:argl] + op = 'Union => ['UnionCategory,:argl] + functorModemap := getConstructorModemapFromDB op + [[.,target,:tl],:.] := functorModemap + EQSUBSTLIST(argl,$FormalMapVariableList,target) + +NRTextendsCategory1(domform,exCategory,addForm) == + addForm is ["%Comma",:r] => + and/[extendsCategory(domform,exCategory,x) for x in r] + extendsCategory(domform,exCategory,addForm) + +--======================================================================= +-- Compute if a domain constructor is forgetful functor +--======================================================================= +extendsCategory(dom,u,v) == + --does category u extend category v (yes iff u contains everything in v) + --is dom of category u also of category v? + u=v => true + v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) + v := substSlotNumbers(v,$template,$functorForm) + extendsCategoryBasic0(dom,u,v) => true + $why := + v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] + [u,'" has no",v] + nil + +extendsCategoryBasic0(dom,u,v) == + v is ['IF,p,['ATTRIBUTE,c],.] => + uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr + cons? c and isCategoryForm(c,nil) => + slot4 := uVec.4 + LASSOC(c,second slot4) is [=p,:.] + slot2 := uVec.2 + LASSOC(c,slot2) is [=p,:.] + extendsCategoryBasic(dom,u,v) + +extendsCategoryBasic(dom,u,v) == + u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] + u = v => true + uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr + isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) + v is ['SIGNATURE,op,sig] => + or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] + u is ['CATEGORY,.,:l] => + v is ['IF,:.] => member(v,l) + nil + nil + +catExtendsCat?(u,v,uvec) == + u = v => true + uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr + slot4 := uvec.4 + prinAncestorList := first slot4 + member(v,prinAncestorList) => true + vOp := KAR v + if similarForm := assoc(vOp,prinAncestorList) then + PRINT u + sayBrightlyNT '" extends " + PRINT similarForm + sayBrightlyNT '" but not " + PRINT v + or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT second slot4] + +substSlotNumbers(form,template,domain) == + form is [op,:.] and + MEMQ(op,allConstructors()) => expandType(form,template,domain) + form is ['SIGNATURE,op,sig] => + ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] + form is ['CATEGORY,k,:u] => + ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] + expandType(form,template,domain) + +expandType(lazyt,template,domform) == + atom lazyt => expandTypeArgs(lazyt,template,domform) + [functorName,:argl] := lazyt + functorName in '(Record Union) and first argl is [":",:.] => + [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] + for [.,tag,dom] in argl]] + lazyt is ['local,x] => + n := POSN1(x,$FormalMapVariableList) + domform.(1 + n) + [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] + +expandTypeArgs(u,template,domform) == + u = '$ => u --template.0 -------eliminate this as $ is rep by 0 + integer? u => expandType(templateVal(template, domform, u), template,domform) + u is ['NRTEVAL,y] => y --eval y + u is ['QUOTE,y] => y + atom u => u + expandType(u,template,domform) + +templateVal(template,domform,index) == +--returns a domform or a lazy slot + index = 0 => BREAK() --template + template.index + + --% Subdomains ++ We are defining a functor with head given by `form', as a subdomain diff --git a/src/interp/interop.boot b/src/interp/interop.boot index 0d076bfa..90049e8e 100644 --- a/src/interp/interop.boot +++ b/src/interp/interop.boot @@ -261,6 +261,66 @@ $attributeDispatch := [function attributeNthParent]) -- 1 indexed +--======================================================================= +-- Generate Category Level Alist +--======================================================================= +orderCatAnc x == + nreverse ASSOCLEFT SORTBY(function rest,rest depthAssoc x) + +depthAssocList u == + u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 + removeDuplicates ("append"/[depthAssoc(y) for y in u]) + +depthAssoc x == + y := HGET($depthAssocCache,x) => y + x is ['Join,:u] or (u := getCatAncestors x) => + v := depthAssocList u + HPUT($depthAssocCache,x,[[x,:n],:v]) + where n() == 1 + "MAX"/[rest y for y in v] + HPUT($depthAssocCache,x,[[x,:0]]) + +getCatAncestors x == [CAAR y for y in parentsOf opOf x] + +listOfEntries form == + atom form => form + form is [op,:l] => + op = 'Join => "append"/[listOfEntries x for x in l] + op = 'CATEGORY => listOfCategoryEntries rest l + op = 'PROGN => listOfCategoryEntries l + op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] + op in '(ATTRIBUTE SIGNATURE) => nil + [form] + categoryFormatError() + +listOfCategoryEntries l == + null l => nil + l is [[op,:u],:v] => + firstItemList:= + op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => + [first u] + op in '(ATTRIBUTE SIGNATURE) => nil + op = 'IF and u is [pred,conseq,alternate] => + listOfCategoryEntriesIf(pred,conseq,alternate) + categoryFormatError() + [:firstItemList,:listOfCategoryEntries v] + l is ['PROGN,:l] => listOfCategoryEntries l + l is '(NIL) => nil + sayBrightly '"unexpected category format encountered:" + pp l + +listOfCategoryEntriesIf(pred,conseq,alternate) == + alternate in '(%noBranch NIL) => + conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) + [fn for x in listOfEntries conseq] where fn() == + x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] + ['IF,pred,x] + notPred := makePrefixForm(pred,'NOT) + conseq is ['IF,p,c,a] => + listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) + [gn for x in listOfEntries conseq] where gn() == + x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] + ['IF,notPred,x] + orderedDefaults(conform,domform) == $depthAssocCache : local := hashTable 'EQ conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op] diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 7b9c556a..4d754bbe 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -43,6 +43,160 @@ module lisplib ++ $functionLocations := [] +--======================================================================= +-- Generate Slot 2 Attribute Alist +--======================================================================= +NRTgenInitialAttributeAlist attributeList == + --alist has form ((item pred)...) where some items are constructor forms + alist := [x for x in attributeList | -- throw out constructors + not MEMQ(opOf first x,allConstructors())] + $lisplibAttributes := simplifyAttributeAlist + [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ~= 'nothing] + +simplifyAttributeAlist al == + al is [[a,:b],:r] => + u := [x for x in r | x is [=a,:b]] + null u => [first al,:simplifyAttributeAlist rest al] + pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + s := [x for x in r | x isnt [=a,:b]] + [[a,:pred],:simplifyAttributeAlist s] + nil + +NRTgenFinalAttributeAlist() == + [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ~= -1] + +predicateBitIndex x == + pn(x,false) where + pn(x,flag) == + u := simpBool transHasCode x + u = 'T => 0 + u = nil => -1 + p := POSN1(u,$NRTslot1PredicateList) => p + 1 + not flag => pn(predicateBitIndexRemop x,true) + systemError nil + +predicateBitIndexRemop p== +--transform attribute predicates taken out by removeAttributePredicates + p is [op,:argl] and op in '(AND and %and OR or %or NOT not %not) => + simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) + p is ["has",'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) + p + +predicateBitRef x == + x = 'T => 'T + ['testBitVector,'pv_$,predicateBitIndex x] + +makePrefixForm(u,op) == + u := MKPF(u,op) + u = ''T => 'T + u + +--======================================================================= +-- Generate Slot 3 Predicate Vector +--======================================================================= +makePredicateBitVector pl == --called by buildFunctor + if $insideCategoryPackageIfTrue then + pl := union(pl,$categoryPredicateList) + $predGensymAlist := nil --bound by buildFunctor, used by optHas + for p in removeAttributePredicates pl repeat + pred := simpBool transHasCode p + atom pred => 'skip --skip over T and NIL + if isHasDollarPred pred then + lasts := insert(pred,lasts) + for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) + else + firsts := insert(pred,firsts) + firstPl := SUBLIS($pairlis,nreverse orderByContainment firsts) + lastPl := SUBLIS($pairlis,nreverse orderByContainment lasts) + firstCode:= + ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] + lastCode := augmentPredCode(# firstPl,lastPl) + $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates + [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 + +augmentPredCode(n,lastPl) == + ['%list,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) + delta := 2 ** n + l := [(u := MKPF([x,['augmentPredVector,"$",delta]],'AND); + delta:=2 * delta; u) for x in pl] + +augmentPredVector(dollar,value) == + vectorRef(dollar,3) := value + vectorRef(dollar,3) + +isHasDollarPred pred == + pred is [op,:r] => + op in '(AND and %and OR or %or NOT not %not) => + or/[isHasDollarPred x for x in r] + op in '(HasCategory HasAttribute) => first r = '$ + false + +stripOutNonDollarPreds pred == + pred is [op,:r] and op in '(AND and %and OR or %or NOT not %not) => + "append"/[stripOutNonDollarPreds x for x in r] + not isHasDollarPred pred => [pred] + nil + +removeAttributePredicates pl == + [fn p for p in pl] where + fn p == + p is [op,:argl] and op in '(AND and %and OR or %or NOT not %not) => + makePrefixForm(fnl argl,op) + p is ["has",'$,['ATTRIBUTE,a]] => + sayBrightlyNT '"Predicate: " + PRINT p + sayBrightlyNT '" replaced by: " + PRINT LASSOC(a,$NRTattributeAlist) + p + fnl p == [fn x for x in p] + +transHasCode x == + atom x => x + op := x.op + op in '(HasCategory HasAttribute) => x + op="has" => compHasFormat x + [transHasCode y for y in x] + +mungeAddGensyms(u,gal) == + ['%list,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == + atom x => x + g := LASSOC(x,gal) => + n = 0 => ["%LET",g,x] + g + [first x,:[fn(y,gal,n + 1) for y in rest x]] + +orderByContainment pl == + null pl or null rest pl => pl + max := first pl + for x in rest pl repeat + if (y := CONTAINED(max,x)) then + if null assoc(max,$predGensymAlist) + then $predGensymAlist := [[max,:gensym()],:$predGensymAlist] + else if CONTAINED(x,max) + then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:gensym()],:$predGensymAlist] + if y then max := x + [max,:orderByContainment delete(max,pl)] + +buildBitTable(:l) == fn(reverse l,0) where fn(l,n) == + null l => n + n := n + n + if first l then n := n + 1 + fn(rest l,n) + +buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == + null l => acc + if first l then acc := acc + n + fn(acc,n + n,rest l) + +testBitVector(vec,i) == +--bit vector indices are always 1 larger than position in vector + i = 0 => true + LOGBITP(i - 1,vec) + +bitsOf n == + n = 0 => 0 + 1 + bitsOf(n quo 2) + --% Standard Library Creation Functions readLib(fn,ft) == readLib1(fn,ft,"*") diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 48e18254..e9709f63 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -32,7 +32,6 @@ -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -import nrunopt import simpbool import profile import functor @@ -404,6 +403,55 @@ washFunctorBody form == main form where x is ['%list] => nil x +--======================================================================= +-- Instantiation Code (Stuffslots) +--======================================================================= +stuffSlot(dollar,i,item) == + dollar.i := + atom item => [symbolFunction item,:dollar] + item is [n,:op] and integer? n => ['newGoGet,dollar,:item] + item is ['CONS,.,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil + item + +stuffDomainSlots dollar == + domname := devaluate dollar + infovec := GETL(opOf domname,'infovec) + lookupFunction := getLookupFun infovec + lookupFunction := + lookupFunction = 'lookupIncomplete => function lookupIncomplete + function lookupComplete + template := infovec.0 + if template.5 then stuffSlot(dollar,5,template.5) + for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat + stuffSlot(dollar,i,item) + dollar.1 := LIST(lookupFunction,dollar,infovec.1) + dollar.2 := infovec.2 + proto4 := infovec.3 + dollar.4 := + vector? CDDR proto4 => [COPY_-SEQ first proto4,:rest proto4] --old style + bitVector := dollar.3 + predvec := first proto4 + packagevec := second proto4 + auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() == + not testBitVector(bitVector,predvec.i) => nil + packagevec.i or true + [auxvec,:CDDR proto4] + +getLookupFun infovec == + MAXINDEX infovec = 4 => infovec.4 + 'lookupIncomplete + +makeSpadConstant [fn,dollar,slot] == + val := FUNCALL(fn,dollar) + u:= dollar.slot + u.first := function IDENTITY + u.rest := val + val + buildFunctor($definition is [name,:args],sig,code,$locals,$e) == --PARAMETERS -- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot deleted file mode 100644 index fb525a68..00000000 --- a/src/interp/nrunopt.boot +++ /dev/null @@ -1,918 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, Gabriel Dos Reis. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical Algorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import c_-util -namespace BOOT - ---======================================================================= --- Generate Code to Create Infovec ---======================================================================= -getInfovecCode() == ---Function called by compDefineFunctor1 to create infovec at compile time - ['LIST, - MKQ makeDomainTemplate $template, - MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist(), - NRTmakeCategoryAlist(), - MKQ $lookupFunction] - ---======================================================================= --- Generation of Domain Vector Template (Compile Time) ---======================================================================= -makeDomainTemplate vec == ---NOTES: This function is called at compile time to create the template --- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 - newVec := newShell # vec - for index in 0..MAXINDEX vec repeat - item := vec.index - null item => nil - newVec.index := - atom item => item - cons? first item => makeGoGetSlot(item,index) - item - $byteVec := "append"/nreverse $byteVec - newVec - -makeGoGetSlot(item,index) == ---NOTES: creates byte vec strings for LATCH slots ---these parts of the $byteVec are created first; see also makeCompactDirect - [sig,whereToGo,op,:flag] := item - n := #sig - 1 - newcode := [n,whereToGo,:makeCompactSigCode sig,index] - $byteVec := [newcode,:$byteVec] - curAddress := $byteAddress - $byteAddress := $byteAddress + n + 4 - [curAddress,:op] - ---======================================================================= --- Generate OpTable at Compile Time ---======================================================================= ---> called by getInfovecCode (see top of this file) from compDefineFunctor1 -makeCompactDirect u == - $predListLength :local := # $NRTslot1PredicateList - $byteVecAcc: local := nil - [nam,[addForm,:opList]] := u - --pp opList - d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] - $byteVec := [:$byteVec,:"append"/nreverse $byteVecAcc] - LIST2VEC ("append"/d) - -makeCompactDirect1(op,items) == ---NOTES: creates byte codes for ops implemented by the domain - curAddress := $byteAddress - $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) - newcodes := - "append"/[u for y in orderBySubsumption items | u := fn y] or return nil - $byteVecAcc := [newcodes,:$byteVecAcc] - curAddress - where fn y == - [sig,:r] := y - r = ['Subsumed] => - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - [n,0,:makeCompactSigCode sig,0] --always followed by subsuming signature - --identified by a 0 in slot position - if r is [n,:s] then - slot := - n is [p,:.] => p --the rest is linenumber of function definition - n - predCode := - s is [pred,:.] => predicateBitIndex pred - 0 - --> drop items which are not present (predCode = -1) - predCode = -1 => return nil - --> drop items with NIL slots if lookup function is incomplete - if null slot then - $lookupFunction = 'lookupIncomplete => return nil - slot := 1 --signals that operation is not present - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - res := [n,predCode,:makeCompactSigCode sig,slot] - res - -orderBySubsumption items == - acc := subacc := nil - for x in items repeat - not $op in '(Zero One) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] - acc := [x,:acc] - y := z := nil - for [a,b,:.] in subacc | b repeat - --NOTE: b = nil means that the signature a will appear in acc, that this - -- entry is be ignored (e.g. init: -> $ in ULS) - while (u := assoc(b,subacc)) repeat b := second u - u := assoc(b,acc) or systemError nil - if null second u then u := [first u,1] --mark as missing operation - y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed - z := insert(b,z) --mark a signature as already present - [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming - -makeCompactSigCode sig == [fn for x in sig] where - fn() == - x = "$$" => 2 - x = "$" => 0 - not integer? x => - systemError ['"code vector slot is ",x,'"; must be number"] - x - ---======================================================================= --- Instantiation Code (Stuffslots) ---======================================================================= -stuffDomainSlots dollar == - domname := devaluate dollar - infovec := GETL(opOf domname,'infovec) - lookupFunction := getLookupFun infovec - lookupFunction := - lookupFunction = 'lookupIncomplete => function lookupIncomplete - function lookupComplete - template := infovec.0 - if template.5 then stuffSlot(dollar,5,template.5) - for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat - stuffSlot(dollar,i,item) - dollar.1 := LIST(lookupFunction,dollar,infovec.1) - dollar.2 := infovec.2 - proto4 := infovec.3 - dollar.4 := - vector? CDDR proto4 => [COPY_-SEQ first proto4,:rest proto4] --old style - bitVector := dollar.3 - predvec := first proto4 - packagevec := second proto4 - auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() == - not testBitVector(bitVector,predvec.i) => nil - packagevec.i or true - [auxvec,:CDDR proto4] - -getLookupFun infovec == - MAXINDEX infovec = 4 => infovec.4 - 'lookupIncomplete - -makeSpadConstant [fn,dollar,slot] == - val := FUNCALL(fn,dollar) - u:= dollar.slot - u.first := function IDENTITY - u.rest := val - val - -stuffSlot(dollar,i,item) == - dollar.i := - atom item => [symbolFunction item,:dollar] - item is [n,:op] and integer? n => ['newGoGet,dollar,:item] - item is ['CONS,.,['FUNCALL,a,b]] => - b = '$ => ['makeSpadConstant,eval a,dollar,i] - sayBrightlyNT '"Unexpected constant environment!!" - pp devaluate b - nil - item - ---======================================================================= --- Generate Slot 2 Attribute Alist ---======================================================================= -NRTgenInitialAttributeAlist attributeList == - --alist has form ((item pred)...) where some items are constructor forms - alist := [x for x in attributeList | -- throw out constructors - not MEMQ(opOf first x,allConstructors())] - $lisplibAttributes := simplifyAttributeAlist - [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ~= 'nothing] - -simplifyAttributeAlist al == - al is [[a,:b],:r] => - u := [x for x in r | x is [=a,:b]] - null u => [first al,:simplifyAttributeAlist rest al] - pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - s := [x for x in r | x isnt [=a,:b]] - [[a,:pred],:simplifyAttributeAlist s] - nil - -NRTgenFinalAttributeAlist() == - [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ~= -1] - -predicateBitIndex x == - pn(x,false) where - pn(x,flag) == - u := simpBool transHasCode x - u = 'T => 0 - u = nil => -1 - p := POSN1(u,$NRTslot1PredicateList) => p + 1 - not flag => pn(predicateBitIndexRemop x,true) - systemError nil - -predicateBitIndexRemop p== ---transform attribute predicates taken out by removeAttributePredicates - p is [op,:argl] and op in '(AND and %and OR or %or NOT not %not) => - simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) - p is ["has",'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) - p - -predicateBitRef x == - x = 'T => 'T - ['testBitVector,'pv_$,predicateBitIndex x] - -makePrefixForm(u,op) == - u := MKPF(u,op) - u = ''T => 'T - u ---======================================================================= --- Generate Slot 3 Predicate Vector ---======================================================================= -makePredicateBitVector pl == --called by buildFunctor - if $insideCategoryPackageIfTrue then - pl := union(pl,$categoryPredicateList) - $predGensymAlist := nil --bound by buildFunctor, used by optHas - for p in removeAttributePredicates pl repeat - pred := simpBool transHasCode p - atom pred => 'skip --skip over T and NIL - if isHasDollarPred pred then - lasts := insert(pred,lasts) - for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) - else - firsts := insert(pred,firsts) - firstPl := SUBLIS($pairlis,nreverse orderByContainment firsts) - lastPl := SUBLIS($pairlis,nreverse orderByContainment lasts) - firstCode:= - ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] - lastCode := augmentPredCode(# firstPl,lastPl) - $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates - [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 - -augmentPredCode(n,lastPl) == - ['%list,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) - delta := 2 ** n - l := [(u := MKPF([x,['augmentPredVector,"$",delta]],'AND); - delta:=2 * delta; u) for x in pl] - -augmentPredVector(dollar,value) == - vectorRef(dollar,3) := value + vectorRef(dollar,3) - -isHasDollarPred pred == - pred is [op,:r] => - op in '(AND and %and OR or %or NOT not %not) => - or/[isHasDollarPred x for x in r] - op in '(HasCategory HasAttribute) => first r = '$ - false - -stripOutNonDollarPreds pred == - pred is [op,:r] and op in '(AND and %and OR or %or NOT not %not) => - "append"/[stripOutNonDollarPreds x for x in r] - not isHasDollarPred pred => [pred] - nil - -removeAttributePredicates pl == - [fn p for p in pl] where - fn p == - p is [op,:argl] and op in '(AND and %and OR or %or NOT not %not) => - makePrefixForm(fnl argl,op) - p is ["has",'$,['ATTRIBUTE,a]] => - sayBrightlyNT '"Predicate: " - PRINT p - sayBrightlyNT '" replaced by: " - PRINT LASSOC(a,$NRTattributeAlist) - p - fnl p == [fn x for x in p] - -transHasCode x == - atom x => x - op := x.op - op in '(HasCategory HasAttribute) => x - op="has" => compHasFormat x - [transHasCode y for y in x] - -mungeAddGensyms(u,gal) == - ['%list,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == - atom x => x - g := LASSOC(x,gal) => - n = 0 => ["%LET",g,x] - g - [first x,:[fn(y,gal,n + 1) for y in rest x]] - -orderByContainment pl == - null pl or null rest pl => pl - max := first pl - for x in rest pl repeat - if (y := CONTAINED(max,x)) then - if null assoc(max,$predGensymAlist) - then $predGensymAlist := [[max,:gensym()],:$predGensymAlist] - else if CONTAINED(x,max) - then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:gensym()],:$predGensymAlist] - if y then max := x - [max,:orderByContainment delete(max,pl)] - -buildBitTable(:l) == fn(reverse l,0) where fn(l,n) == - null l => n - n := n + n - if first l then n := n + 1 - fn(rest l,n) - -buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == - null l => acc - if first l then acc := acc + n - fn(acc,n + n,rest l) - -testBitVector(vec,i) == ---bit vector indices are always 1 larger than position in vector - i = 0 => true - LOGBITP(i - 1,vec) - -bitsOf n == - n = 0 => 0 - 1 + bitsOf(n quo 2) - ---======================================================================= --- Generate Slot 4 Constructor Vectors ---======================================================================= -NRTmakeCategoryAlist() == - $depthAssocCache: local := hashTable 'EQ - $catAncestorAlist: local := NIL - pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] - $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] - opcAlist := nreverse SORTBY(function NRTcatCompare,pcAlist) - newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] - slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) - | (k := predicateBitIndex b) ~= -1] - slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] - sixEtc := [5 + i for i in 1..#$pairlis] - formals := ASSOCRIGHT $pairlis - for x in slot1 repeat - x.first := EQSUBSTLIST(["$$",:sixEtc],['$,:formals],first x) - -----------code to make a new style slot4 ----------------- - predList := ASSOCRIGHT slot1 --is list of predicate indices - maxPredList := "MAX"/predList - catformvec := ASSOCLEFT slot1 - maxElement := "MAX"/$byteVec - ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], - ['CONS, MKQ LIST2VEC slot0, - ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], - ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] - --NOTE: this is new form: old form satisfies vector? CDDR form - -encodeCatform x == - k := NRTassocIndex x => k - atom x or atom rest x => x - [first x,:[encodeCatform y for y in rest x]] - -NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) - -hasDefaultPackage catname == - defname := makeSymbol strconc(catname,'"&") - constructor? defname => defname - nil - - ---======================================================================= --- Generate Category Level Alist ---======================================================================= -orderCatAnc x == - nreverse ASSOCLEFT SORTBY(function rest,rest depthAssoc x) - -depthAssocList u == - u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 - removeDuplicates ("append"/[depthAssoc(y) for y in u]) - -depthAssoc x == - y := HGET($depthAssocCache,x) => y - x is ['Join,:u] or (u := getCatAncestors x) => - v := depthAssocList u - HPUT($depthAssocCache,x,[[x,:n],:v]) - where n() == 1 + "MAX"/[rest y for y in v] - HPUT($depthAssocCache,x,[[x,:0]]) - -getCatAncestors x == [CAAR y for y in parentsOf opOf x] - -listOfEntries form == - atom form => form - form is [op,:l] => - op = 'Join => "append"/[listOfEntries x for x in l] - op = 'CATEGORY => listOfCategoryEntries rest l - op = 'PROGN => listOfCategoryEntries l - op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] - op in '(ATTRIBUTE SIGNATURE) => nil - [form] - categoryFormatError() - -listOfCategoryEntries l == - null l => nil - l is [[op,:u],:v] => - firstItemList:= - op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => - [first u] - op in '(ATTRIBUTE SIGNATURE) => nil - op = 'IF and u is [pred,conseq,alternate] => - listOfCategoryEntriesIf(pred,conseq,alternate) - categoryFormatError() - [:firstItemList,:listOfCategoryEntries v] - l is ['PROGN,:l] => listOfCategoryEntries l - l is '(NIL) => nil - sayBrightly '"unexpected category format encountered:" - pp l - -listOfCategoryEntriesIf(pred,conseq,alternate) == - alternate in '(%noBranch NIL) => - conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) - [fn for x in listOfEntries conseq] where fn() == - x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] - ['IF,pred,x] - notPred := makePrefixForm(pred,'NOT) - conseq is ['IF,p,c,a] => - listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) - [gn for x in listOfEntries conseq] where gn() == - x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] - ['IF,notPred,x] - ---======================================================================= --- Display Template ---======================================================================= -dc(:r) == - con := KAR r - options := KDR r - ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) - null ok => - sayBrightly '"Format is: dc(,option)" - sayBrightly - '"options are: all (default), slots, atts, cats, data, ops, optable" - option := KAR options - option = 'all or null option => dcAll con - option = 'slots => dcSlots con - option = 'atts => dcAtts con - option = 'cats => dcCats con - option = 'data => dcData con - option = 'ops => dcOps con - option = 'size => dcSize( con,'full) - option = 'optable => dcOpTable con - -dcSlots con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - for i in 5..MAXINDEX template repeat - sayBrightlyNT bright i - item := template.i - item is [n,:op] and integer? n => dcOpLatchPrint(op,n) - null item and i > 5 => sayBrightly ['"arg ",strconc('"#",STRINGIMAGE(i - 5))] - atom item => sayBrightly ['"fun ",item] - item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] - sayBrightly concat('"lazy ",form2String formatSlotDomain i) - -dcOpLatchPrint(op,index) == - numvec := getCodeVector() - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := dcSig(numvec,index + 1,numOfArgs) - index := index + numOfArgs + 1 - namePart := concat(bright "from", - dollarPercentTran form2String formatSlotDomain whereNumber) - sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] - -getInfovec name == - u := GETL(name,'infovec) => u - GETL(name,'LOADED) => nil - fullLibName := getConstructorModuleFromDB name or return nil - startTimingProcess 'load - loadLibNoUpdate(name, name, fullLibName) - GETL(name,'infovec) - -getOpSegment index == - numOfArgs := (vec := getCodeVector()).index - [vec.i for i in index..(index + numOfArgs + 3)] - -getCodeVector() == - proto4 := $infovec.3 - u := CDDR proto4 - vector? u => u --old style - rest u --new style - -formatSlotDomain x == - x = 0 => ["$"] - x = 2 => ["$$"] - integer? x => - val := $infovec.0.x - null val => [strconc('"#",STRINGIMAGE (x - 5))] - formatSlotDomain val - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatSlotDomain y for y in rest x]] - ---======================================================================= --- Display OpTable ---======================================================================= -dcOpTable con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - $predvec: local := getConstructorPredicatesFromDB con - opTable := $infovec.1 - for i in 0..MAXINDEX opTable repeat - op := opTable.i - i := i + 1 - startIndex := opTable.i - stopIndex := - i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() - opTable.(i + 2) - curIndex := startIndex - while curIndex < stopIndex repeat - curIndex := dcOpPrint(op,curIndex) - -dcOpPrint(op,index) == - numvec := getCodeVector() - segment := getOpSegment index - numOfArgs := numvec.index - index := index + 1 - predNumber := numvec.index - index := index + 1 - signumList := dcSig(numvec,index,numOfArgs) - index := index + numOfArgs + 1 - slotNumber := numvec.index - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - namePart := bright - slotNumber = 0 => '"subsumed by next entry" - slotNumber = 1 => '"missing" - name := $infovec.0.slotNumber - atom name => name - name is ["CONS","IDENTITY", - ["FUNCALL", ["dispatchFunction", impl],"$"]] => impl - '"looked up" - sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] - index + 1 - -dcSig(numvec,index,numOfArgs) == - [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] - -dcPreds con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= getConstructorPredicatesFromDB con - for i in 0..MAXINDEX $predvec repeat - sayBrightlyNT bright (i + 1) - sayBrightly pred2English $predvec.i - -dcAtts con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= getConstructorPredicatesFromDB con - attList := $infovec.2 - for [a,:predNumber] in attList for i in 0.. repeat - sayBrightlyNT bright i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - sayBrightly [a,:suffix] - -dcCats con == - name := abbreviation? con or con - $infovec: local := getInfovec name - u := $infovec.3 - vector? CDDR u => dcCats1 con --old style slot4 - $predvec:= getConstructorPredicatesFromDB con - catpredvec := first u - catinfo := second u - catvec := third u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - form := catvec.i - predNumber := catpredvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcCats1 con == - $predvec:= getConstructorPredicatesFromDB con - u := $infovec.3 - catvec := second u - catinfo := first u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - [form,:predNumber] := catvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcData con == - name := abbreviation? con or con - $infovec: local := getInfovec name - sayBrightly '"Operation data from slot 1" - PRINT_-FULL $infovec.1 - vec := getCodeVector() - vec := (cons? vec => rest vec; vec) - sayBrightly ['"Information vector has ",# vec,'" entries"] - dcData1 vec - -dcData1 vec == - n := MAXINDEX vec - tens := n quo 10 - for i in 0..tens repeat - start := 10*i - sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) - sayBrightlyNT '" |" - for j in start..MIN(start + 9,n) repeat - sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) - sayNewLine() - vec - -dcSize(:options) == - con := KAR options - options := rest options - null con => dcSizeAll() - quiet := 'quiet in options - full := 'full in options - name := abbreviation? con or con - infovec := getInfovec name - template := infovec.0 - maxindex := MAXINDEX template - latch := 0 --# of go get slots - lazy := 0 --# of lazy domain slots - fun := 0 --# of function slots - lazyNodes := 0 --# of nodes needed for lazy domain slots - for i in 5..maxindex repeat - atom (item := template.i) => fun := fun + 1 - integer? first item => latch := latch + 1 - 'T => - lazy := lazy + 1 - lazyNodes := lazyNodes + numberOfNodes item - tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) - -- functions are free in the template vector - oSize := vectorSize(# infovec.1) - aSize := numberOfNodes infovec.2 - slot4 := infovec.3 - catvec := - vector? CDDR slot4 => second slot4 - third slot4 - n := MAXINDEX catvec - cSize := sum(nodeSize(2),vectorSize(# first slot4),vectorSize(n + 1), - nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) - codeVector := - vector? CDDR slot4 => CDDR slot4 - CDDDR slot4 - vSize := halfWordSize(# codeVector) - itotal := sum(tSize,oSize,aSize,cSize,vSize) - if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] - if null quiet then - lookupFun := getLookupFun infovec - suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") - sayBrightly ['"template = ",tSize] - sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] - sayBrightly ['"attributes = ",aSize] - sayBrightly ['"categories = ",cSize] - sayBrightly ['"data vector = ",vSize] - if null quiet then - sayBrightly ['"number of function slots (one extra node) = ",fun] - sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] - sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] - sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] - vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) - vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) - --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm - if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] - etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) - if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] - vtotal - -dcSizeAll() == - count := 0 - total := 0 - for x in allConstructors() | cons? GETL(x,'infovec) repeat - count := count + 1 - s := dcSize(x,'quiet) - sayBrightly [s,'" : ",x] - total := total + s - sayBrightly '"------------total-------------" - sayBrightly [count," constructors; ",total," BYTES"] - -sum(:l) == +/l - -nodeSize(n) == 12 * n - -vectorSize(n) == 4 * (1 + n) - -halfWordSize(n) == - n < 128 => n quo 2 - n < 256 => n - 2 * n - -numberOfNodes(x) == - atom x => 0 - 1 + numberOfNodes first x + numberOfNodes rest x - -template con == - con := abbreviation? con or con - ppTemplate getInfovec(con).0 - -ppTemplate vec == - for i in 0..MAXINDEX vec repeat - sayBrightlyNT bright i - pp vec.i - -infovec con == - con := abbreviation? con or con - u := getInfovec con - sayBrightly '"---------------slot 0 is template-------------------" - ppTemplate u.0 - sayBrightly '"---------------slot 1 is op table-------------------" - PRINT_-FULL u.1 - sayBrightly '"---------------slot 2 is attribute list-------------" - PRINT_-FULL u.2 - sayBrightly '"---------------slot 3.0 is catpredvec---------------" - PRINT_-FULL u.3.0 - sayBrightly '"---------------slot 3.1 is catinfovec---------------" - PRINT_-FULL u.3.1 - sayBrightly '"---------------slot 3.2 is catvec-------------------" - PRINT_-FULL u.3.2 - sayBrightly '"---------------tail of slot 3 is datavector---------" - dcData1 CDDDR u.3 - 'done - -dcAll con == - con := abbreviation? con or con - $infovec : local := getInfovec con - complete? := - #$infovec = 4 => false - $infovec.4 = 'lookupComplete - sayBrightly '"----------------Template-----------------" - dcSlots con - sayBrightly - complete? => '"----------Complete Ops----------------" - '"----------Incomplete Ops---------------" - dcOpTable con - sayBrightly '"----------------Atts-----------------" - dcAtts con - sayBrightly '"----------------Preds-----------------" - dcPreds con - sayBrightly '"----------------Cats-----------------" - dcCats con - sayBrightly '"----------------Data------------------" - dcData con - sayBrightly '"----------------Size------------------" - dcSize(con,'full) - 'done - -dcOps conname == - for [op,:u] in reverse getConstructorOperationsFromDB conname repeat - for [sig,slot,pred,key,:.] in u repeat - suffix := - atom pred => nil - concat('" if ",pred2English pred) - key = 'Subsumed => - sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] - sayBrightly [:formatOpSignature(op,sig),:suffix] - ---======================================================================= --- Compute the lookup function (complete or incomplete) ---======================================================================= -NRTgetLookupFunction(domform,exCategory,addForm) == - domform := SUBLIS($pairlis,domform) - addForm := SUBLIS($pairlis,addForm) - $why: local := nil - atom addForm => 'lookupComplete - extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) - if null extends then - [u,msg,:v] := $why - SAY '"--------------non extending category----------------------" - sayPatternMsg('"%1p of category %2p", [domform,u]) - if v ~= nil then - sayPatternMsg('"%1b %2p",[msg,first v]) - else - sayPatternMsg('"%1b",[msg]) - SAY '"----------------------------------------------------------" - extends => 'lookupIncomplete - 'lookupComplete - -getExportCategory form == - [op,:argl] := form - op = 'Record => ['RecordCategory,:argl] - op = 'Union => ['UnionCategory,:argl] - functorModemap := getConstructorModemapFromDB op - [[.,target,:tl],:.] := functorModemap - EQSUBSTLIST(argl,$FormalMapVariableList,target) - -NRTextendsCategory1(domform,exCategory,addForm) == - addForm is ["%Comma",:r] => - and/[extendsCategory(domform,exCategory,x) for x in r] - extendsCategory(domform,exCategory,addForm) - ---======================================================================= --- Compute if a domain constructor is forgetful functor ---======================================================================= -extendsCategory(dom,u,v) == - --does category u extend category v (yes iff u contains everything in v) - --is dom of category u also of category v? - u=v => true - v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) - v := substSlotNumbers(v,$template,$functorForm) - extendsCategoryBasic0(dom,u,v) => true - $why := - v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] - [u,'" has no",v] - nil - -extendsCategoryBasic0(dom,u,v) == - v is ['IF,p,['ATTRIBUTE,c],.] => - uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr - cons? c and isCategoryForm(c,nil) => - slot4 := uVec.4 - LASSOC(c,second slot4) is [=p,:.] - slot2 := uVec.2 - LASSOC(c,slot2) is [=p,:.] - extendsCategoryBasic(dom,u,v) - -extendsCategoryBasic(dom,u,v) == - u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] - u = v => true - uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr - isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) - v is ['SIGNATURE,op,sig] => - or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] - u is ['CATEGORY,.,:l] => - v is ['IF,:.] => member(v,l) - nil - nil - -catExtendsCat?(u,v,uvec) == - u = v => true - uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr - slot4 := uvec.4 - prinAncestorList := first slot4 - member(v,prinAncestorList) => true - vOp := KAR v - if similarForm := assoc(vOp,prinAncestorList) then - PRINT u - sayBrightlyNT '" extends " - PRINT similarForm - sayBrightlyNT '" but not " - PRINT v - or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT second slot4] - -substSlotNumbers(form,template,domain) == - form is [op,:.] and - MEMQ(op,allConstructors()) => expandType(form,template,domain) - form is ['SIGNATURE,op,sig] => - ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] - form is ['CATEGORY,k,:u] => - ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] - expandType(form,template,domain) - -expandType(lazyt,template,domform) == - atom lazyt => expandTypeArgs(lazyt,template,domform) - [functorName,:argl] := lazyt - functorName in '(Record Union) and first argl is [":",:.] => - [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] - for [.,tag,dom] in argl]] - lazyt is ['local,x] => - n := POSN1(x,$FormalMapVariableList) - domform.(1 + n) - [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] - -expandTypeArgs(u,template,domform) == - u = '$ => u --template.0 -------eliminate this as $ is rep by 0 - integer? u => expandType(templateVal(template, domform, u), template,domform) - u is ['NRTEVAL,y] => y --eval y - u is ['QUOTE,y] => y - atom u => u - expandType(u,template,domform) - -templateVal(template,domform,index) == ---returns a domform or a lazy slot - index = 0 => BREAK() --template - template.index - diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot index b608d024..47260bb3 100644 --- a/src/interp/showimp.boot +++ b/src/interp/showimp.boot @@ -254,3 +254,350 @@ formatLazyDomainForm(dom,x) == +--======================================================================= +-- Display Template +--======================================================================= +dc(:r) == + con := KAR r + options := KDR r + ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) + null ok => + sayBrightly '"Format is: dc(,option)" + sayBrightly + '"options are: all (default), slots, atts, cats, data, ops, optable" + option := KAR options + option = 'all or null option => dcAll con + option = 'slots => dcSlots con + option = 'atts => dcAtts con + option = 'cats => dcCats con + option = 'data => dcData con + option = 'ops => dcOps con + option = 'size => dcSize( con,'full) + option = 'optable => dcOpTable con + +dcSlots con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + for i in 5..MAXINDEX template repeat + sayBrightlyNT bright i + item := template.i + item is [n,:op] and integer? n => dcOpLatchPrint(op,n) + null item and i > 5 => sayBrightly ['"arg ",strconc('"#",STRINGIMAGE(i - 5))] + atom item => sayBrightly ['"fun ",item] + item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] + sayBrightly concat('"lazy ",form2String formatSlotDomain i) + +dcOpLatchPrint(op,index) == + numvec := getCodeVector() + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := dcSig(numvec,index + 1,numOfArgs) + index := index + numOfArgs + 1 + namePart := concat(bright "from", + dollarPercentTran form2String formatSlotDomain whereNumber) + sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] + +getInfovec name == + u := GETL(name,'infovec) => u + GETL(name,'LOADED) => nil + fullLibName := getConstructorModuleFromDB name or return nil + startTimingProcess 'load + loadLibNoUpdate(name, name, fullLibName) + GETL(name,'infovec) + +getOpSegment index == + numOfArgs := (vec := getCodeVector()).index + [vec.i for i in index..(index + numOfArgs + 3)] + +getCodeVector() == + proto4 := $infovec.3 + u := CDDR proto4 + vector? u => u --old style + rest u --new style + +formatSlotDomain x == + x = 0 => ["$"] + x = 2 => ["$$"] + integer? x => + val := $infovec.0.x + null val => [strconc('"#",STRINGIMAGE (x - 5))] + formatSlotDomain val + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatSlotDomain y for y in rest x]] + +--======================================================================= +-- Display OpTable +--======================================================================= +dcOpTable con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + $predvec: local := getConstructorPredicatesFromDB con + opTable := $infovec.1 + for i in 0..MAXINDEX opTable repeat + op := opTable.i + i := i + 1 + startIndex := opTable.i + stopIndex := + i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() + opTable.(i + 2) + curIndex := startIndex + while curIndex < stopIndex repeat + curIndex := dcOpPrint(op,curIndex) + +dcOpPrint(op,index) == + numvec := getCodeVector() + segment := getOpSegment index + numOfArgs := numvec.index + index := index + 1 + predNumber := numvec.index + index := index + 1 + signumList := dcSig(numvec,index,numOfArgs) + index := index + numOfArgs + 1 + slotNumber := numvec.index + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + namePart := bright + slotNumber = 0 => '"subsumed by next entry" + slotNumber = 1 => '"missing" + name := $infovec.0.slotNumber + atom name => name + name is ["CONS","IDENTITY", + ["FUNCALL", ["dispatchFunction", impl],"$"]] => impl + '"looked up" + sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] + index + 1 + +dcSig(numvec,index,numOfArgs) == + [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] + +dcPreds con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= getConstructorPredicatesFromDB con + for i in 0..MAXINDEX $predvec repeat + sayBrightlyNT bright (i + 1) + sayBrightly pred2English $predvec.i + +dcAtts con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= getConstructorPredicatesFromDB con + attList := $infovec.2 + for [a,:predNumber] in attList for i in 0.. repeat + sayBrightlyNT bright i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + sayBrightly [a,:suffix] + +dcCats con == + name := abbreviation? con or con + $infovec: local := getInfovec name + u := $infovec.3 + vector? CDDR u => dcCats1 con --old style slot4 + $predvec:= getConstructorPredicatesFromDB con + catpredvec := first u + catinfo := second u + catvec := third u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + form := catvec.i + predNumber := catpredvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcCats1 con == + $predvec:= getConstructorPredicatesFromDB con + u := $infovec.3 + catvec := second u + catinfo := first u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + [form,:predNumber] := catvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcData con == + name := abbreviation? con or con + $infovec: local := getInfovec name + sayBrightly '"Operation data from slot 1" + PRINT_-FULL $infovec.1 + vec := getCodeVector() + vec := (cons? vec => rest vec; vec) + sayBrightly ['"Information vector has ",# vec,'" entries"] + dcData1 vec + +dcData1 vec == + n := MAXINDEX vec + tens := n quo 10 + for i in 0..tens repeat + start := 10*i + sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) + sayBrightlyNT '" |" + for j in start..MIN(start + 9,n) repeat + sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) + sayNewLine() + vec + +dcSize(:options) == + con := KAR options + options := rest options + null con => dcSizeAll() + quiet := 'quiet in options + full := 'full in options + name := abbreviation? con or con + infovec := getInfovec name + template := infovec.0 + maxindex := MAXINDEX template + latch := 0 --# of go get slots + lazy := 0 --# of lazy domain slots + fun := 0 --# of function slots + lazyNodes := 0 --# of nodes needed for lazy domain slots + for i in 5..maxindex repeat + atom (item := template.i) => fun := fun + 1 + integer? first item => latch := latch + 1 + 'T => + lazy := lazy + 1 + lazyNodes := lazyNodes + numberOfNodes item + tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) + -- functions are free in the template vector + oSize := vectorSize(# infovec.1) + aSize := numberOfNodes infovec.2 + slot4 := infovec.3 + catvec := + vector? CDDR slot4 => second slot4 + third slot4 + n := MAXINDEX catvec + cSize := sum(nodeSize(2),vectorSize(# first slot4),vectorSize(n + 1), + nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) + codeVector := + vector? CDDR slot4 => CDDR slot4 + CDDDR slot4 + vSize := halfWordSize(# codeVector) + itotal := sum(tSize,oSize,aSize,cSize,vSize) + if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] + if null quiet then + lookupFun := getLookupFun infovec + suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") + sayBrightly ['"template = ",tSize] + sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] + sayBrightly ['"attributes = ",aSize] + sayBrightly ['"categories = ",cSize] + sayBrightly ['"data vector = ",vSize] + if null quiet then + sayBrightly ['"number of function slots (one extra node) = ",fun] + sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] + sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] + sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] + vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) + vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) + --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm + if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] + etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) + if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] + vtotal + +dcSizeAll() == + count := 0 + total := 0 + for x in allConstructors() | cons? GETL(x,'infovec) repeat + count := count + 1 + s := dcSize(x,'quiet) + sayBrightly [s,'" : ",x] + total := total + s + sayBrightly '"------------total-------------" + sayBrightly [count," constructors; ",total," BYTES"] + +sum(:l) == +/l + +nodeSize(n) == 12 * n + +vectorSize(n) == 4 * (1 + n) + +halfWordSize(n) == + n < 128 => n quo 2 + n < 256 => n + 2 * n + +numberOfNodes(x) == + atom x => 0 + 1 + numberOfNodes first x + numberOfNodes rest x + +template con == + con := abbreviation? con or con + ppTemplate getInfovec(con).0 + +ppTemplate vec == + for i in 0..MAXINDEX vec repeat + sayBrightlyNT bright i + pp vec.i + +infovec con == + con := abbreviation? con or con + u := getInfovec con + sayBrightly '"---------------slot 0 is template-------------------" + ppTemplate u.0 + sayBrightly '"---------------slot 1 is op table-------------------" + PRINT_-FULL u.1 + sayBrightly '"---------------slot 2 is attribute list-------------" + PRINT_-FULL u.2 + sayBrightly '"---------------slot 3.0 is catpredvec---------------" + PRINT_-FULL u.3.0 + sayBrightly '"---------------slot 3.1 is catinfovec---------------" + PRINT_-FULL u.3.1 + sayBrightly '"---------------slot 3.2 is catvec-------------------" + PRINT_-FULL u.3.2 + sayBrightly '"---------------tail of slot 3 is datavector---------" + dcData1 CDDDR u.3 + 'done + +dcAll con == + con := abbreviation? con or con + $infovec : local := getInfovec con + complete? := + #$infovec = 4 => false + $infovec.4 = 'lookupComplete + sayBrightly '"----------------Template-----------------" + dcSlots con + sayBrightly + complete? => '"----------Complete Ops----------------" + '"----------Incomplete Ops---------------" + dcOpTable con + sayBrightly '"----------------Atts-----------------" + dcAtts con + sayBrightly '"----------------Preds-----------------" + dcPreds con + sayBrightly '"----------------Cats-----------------" + dcCats con + sayBrightly '"----------------Data------------------" + dcData con + sayBrightly '"----------------Size------------------" + dcSize(con,'full) + 'done + +dcOps conname == + for [op,:u] in reverse getConstructorOperationsFromDB conname repeat + for [sig,slot,pred,key,:.] in u repeat + suffix := + atom pred => nil + concat('" if ",pred2English pred) + key = 'Subsumed => + sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] + sayBrightly [:formatOpSignature(op,sig),:suffix] + -- cgit v1.2.3