diff options
Diffstat (limited to 'src/interp/nrunopt.boot')
| -rw-r--r-- | src/interp/nrunopt.boot | 908 |
1 files changed, 908 insertions, 0 deletions
diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot new file mode 100644 index 00000000..5ca437b3 --- /dev/null +++ b/src/interp/nrunopt.boot @@ -0,0 +1,908 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, 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" +)package "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 := GETREFV SIZE vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + newVec.index := + atom item => item + null atom 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,nil),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 := LENGTH $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,$isOpPackageName),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 CDR 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,$isOpPackageName),slot] + res + +orderBySubsumption items == + acc := subacc := nil + for x in items repeat + not MEMQ($op,'(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 := CADR u + u := assoc(b,acc) or systemError nil + if null CADR u then u := [CAR 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,$isOpPackageName) == [fn for x in sig] where +--$isOpPackageName = true only for an exported operation of a default package + fn() == + x = '_$_$ => 2 + x = '$ => 0 + not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] +-- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages + 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 := + VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style + bitVector := dollar.3 + predvec := CAR proto4 + packagevec := CADR proto4 + auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() == + null testBitVector(bitVector,predvec.i) => nil + packagevec.i or true + [auxvec,:CDDR proto4] + +getLookupFun infovec == + MAXINDEX infovec = 4 => infovec.4 + 'lookupIncomplete + +stuffSlot(dollar,i,item) == + dollar.i := + atom item => [SYMBOL_-FUNCTION item,:dollar] + item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] + item is ['CONS,.,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil +-- [dollar,i,:item] --old form +-- $isOpPackageName = 'T => SUBST(0,6,item) + item --new form +--======================================================================= +-- 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 OR or 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 NRTbuildFunctor + if $insideCategoryPackageIfTrue then + pl := union(pl,$categoryPredicateList) + $predGensymAlist := nil --bound by NRTbuildFunctor, 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) == + QSETREFV(dollar,3,value + QVELT(dollar,3)) + +isHasDollarPred pred == + pred is [op,:r] => + MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] + MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ + false + +stripOutNonDollarPreds pred == + pred is [op,:r] and MEMQ(op,'(AND and OR or 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 OR or 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 := QCAR x + MEMQ(op,'(HasCategory HasAttribute)) => x + EQ(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 QCAR 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 CAR 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/2) + +--======================================================================= +-- Generate Slot 4 Constructor Vectors +--======================================================================= +NRTmakeCategoryAlist() == + $depthAssocCache: local := MAKE_-HASHTABLE 'ID + $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 + RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR 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 VECP 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 := INTERN STRCONC(catname,'"&") + constructor? defname => defname +--MEMQ(defname,allConstructors()) => defname + nil + + +--======================================================================= +-- Generate Category Level Alist +--======================================================================= +orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) + +depthAssocList u == + u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 + REMDUP ("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] + MEMQ(op,'(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(<constructor name or abbreviation>,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 INTEGERP 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 := GETDATABASE(name,'OBJECT) 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 + VECP u => u --old style + CDR u --new style + +formatSlotDomain x == + x = 0 => ["$"] + x = 2 => ["$$"] + INTEGERP 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 := GETDATABASE(con,'PREDICATES) + 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 + '"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:= GETDATABASE(con,'PREDICATES) + 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:= GETDATABASE(con,'PREDICATES) + 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 + VECP CDDR u => dcCats1 con --old style slot4 + $predvec:= GETDATABASE(con,'PREDICATES) + catpredvec := CAR u + catinfo := CADR u + catvec := CADDR 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:= GETDATABASE(con,'PREDICATES) + u := $infovec.3 + catvec := CADR u + catinfo := CAR 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 := (PAIRP vec => CDR vec; vec) + sayBrightly ['"Information vector has ",SIZE vec,'" entries"] + dcData1 vec + +dcData1 vec == + n := MAXINDEX vec + tens := n / 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 := MEMQ('quiet,options) + full := MEMQ('full,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 + INTEGERP 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(SIZE infovec.1) + aSize := numberOfNodes infovec.2 + slot4 := infovec.3 + catvec := + VECP CDDR slot4 => CADR slot4 + CADDR slot4 + n := MAXINDEX catvec + cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), + nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) + codeVector := + VECP CDDR slot4 => CDDR slot4 + CDDDR slot4 + vSize := halfWordSize(SIZE 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() | null atom 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 / 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 getOperationAlistFromLisplib 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 + sayBrightly '"--------------non extending category----------------------" + sayBrightlyNT ['"..",:bright form2String domform,"of cat "] + PRINT u + sayBrightlyNT bright msg + if v then PRINT CAR v else TERPRI() + extends => 'lookupIncomplete + 'lookupComplete + +getExportCategory form == + [op,:argl] := form + op = 'Record => ['RecordCategory,:argl] + op = 'Union => ['UnionCategory,:argl] + functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) + [[.,target,:tl],:.] := functorModemap + EQSUBSTLIST(argl,$FormalMapVariableList,target) + +NRTextendsCategory1(domform,exCategory,addForm) == + addForm is ['Tuple,: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 + null atom c and isCategoryForm(c,nil) => + slot4 := uVec.4 + LASSOC(c,CADR 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 := CAR 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 CADR 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 + MEMQ(functorName, '(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) + ELT(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 + INTEGERP 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 => harhar() --template + template.index + |