From 1d9460d2c22682ac6cb649fd45d47f02bf1cf282 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 1 Jun 2013 22:02:47 +0000 Subject: Cache category objects some more. --- src/ChangeLog | 15 ++++++ src/interp/category.boot | 122 +++++++++++++++++++++++------------------------ src/interp/define.boot | 2 +- src/interp/functor.boot | 48 +++++++++---------- 4 files changed, 101 insertions(+), 86 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index f7892e25..af4680fb 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,18 @@ +2013-06-01 Gabriel Dos Reis + + * interp/category.boot (SigListUnion): Take a cache table. Adjust + callers. + (mkOr): Likewise. + (mkOr2): Likewise. + (mkAnd): Likewise. + (mkAnd2): Likewise. + (FindFundAncs): Likewise. + (CatEval): Likewise. + (ancestors?): Likewise. + (descendant?): Likewise. + (filterConditionalCategories): Likewise. + * interp/functor.boot (ICformat): Likewise. + 2013-06-01 Gabriel Dos Reis * interp/define.boot (getCategoryObject): New. diff --git a/src/interp/category.boot b/src/interp/category.boot index b018b875..cec0b2bb 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -137,7 +137,7 @@ DropImplementations a == [[:sig,'constant],pred] a -SigListUnion(extra,original,principal) == +SigListUnion(extra,original,principal,tbl) == --augments original %with everything in extra that is not in original for (o:=[[ofn,osig,:.],opred,:.]) in original repeat -- The purpose of this loop is to detect cases when the @@ -173,13 +173,13 @@ SigListUnion(extra,original,principal) == original := [x,:original] else original:= [[xsig,xpred,["Subsumed",:esig]],:original] - else epred := mkOr(epred,xpred,$e) + else epred := mkOr(epred,xpred,tbl,$e) -- this used always to be done, as noted below, but that's not safe if not(ximplem is [["Subsumed",:.],:.]) then eimplem:= ximplem if eimplem then esig:=[first esig,second esig] -- in case there's a constant marker e:= [esig,epred,:eimplem] --- e:= [esig,mkOr(xpred,epred,$e),:ximplem] +-- e:= [esig,mkOr(xpred,epred,tbl,$e),:ximplem] -- Original version -gets it wrong if the new operator is only -- present under certain conditions -- We must pick up the previous implementation, if any @@ -189,18 +189,18 @@ SigListUnion(extra,original,principal) == original:= [e,:original] original -mkOr: (%Form,%Form,%Env) -> %Form -mkOr(a,b,e) == +mkOr: (%Form,%Form,%Table,%Env) -> %Form +mkOr(a,b,tbl,e) == a=true => true b=true => true b=a => a l:= a is ["OR",:a'] => - (b is ["OR",:b'] => union(a',b'); mkOr2(b,a',e) ) - b is ["OR",:b'] => mkOr2(a,b',e) + (b is ["OR",:b'] => union(a',b'); mkOr2(b,a',tbl,e) ) + b is ["OR",:b'] => mkOr2(a,b',tbl,e) (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => - descendant?(acat,bcat,e) => [b] - descendant?(bcat,acat,e) => [a] + descendant?(acat,bcat,tbl,e) => [b] + descendant?(bcat,acat,tbl,e) => [a] [a,b] a is ['AND,:a'] and listMember?(b,a') => [b] b is ['AND,:b'] and listMember?(a,b') => [a] @@ -210,47 +210,47 @@ mkOr(a,b,e) == #l = 1 => first l ["OR",:l] -mkOr2: (%Form,%Form,%Env) -> %Form -mkOr2(a,b,e) == +mkOr2: (%Form,%Form,%Table,%Env) -> %Form +mkOr2(a,b,tbl,e) == --a is a condition, "b" a list of them listMember?(a,b) => b a is ["has",avar,acat] => aRedundant:=false for c in b | c is ["has",=avar,ccat] repeat - descendant?(acat,ccat,e) => + descendant?(acat,ccat,tbl,e) => return (aRedundant:=true) - if descendant?(ccat,acat,e) then b := remove(b,c) + if descendant?(ccat,acat,tbl,e) then b := remove(b,c) aRedundant => b [a,:b] [a,:b] -mkAnd: (%Form,%Form,%Env) -> %Form -mkAnd(a,b,e) == +mkAnd: (%Form,%Form,%Table,%Env) -> %Form +mkAnd(a,b,tbl,e) == a=true => b b=true => a b=a => a l:= a is ["AND",:a'] => - (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a',e) ) - b is ["AND",:b'] => mkAnd2(a,b',e) + (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a',tbl,e) ) + b is ["AND",:b'] => mkAnd2(a,b',tbl,e) (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => - descendant?(acat,bcat,e) => [a] - descendant?(bcat,acat,e) => [b] + descendant?(acat,bcat,tbl,e) => [a] + descendant?(bcat,acat,tbl,e) => [b] [a,b] [a,b] #l = 1 => first l ["AND",:l] -mkAnd2: (%Form,%Form,%Env) -> %Form -mkAnd2(a,b,e) == +mkAnd2: (%Form,%Form,%Table,%Env) -> %Form +mkAnd2(a,b,tbl,e) == --a is a condition, "b" a list of them listMember?(a,b) => b a is ["has",avar,acat] => aRedundant:=false for c in b | c is ["has",=avar,ccat] repeat - descendant?(ccat,acat,e) => + descendant?(ccat,acat,tbl,e) => return (aRedundant:=true) - if descendant?(acat,ccat,e) then b := remove(b,c) + if descendant?(acat,ccat,tbl,e) then b := remove(b,c) aRedundant => b [a,:b] [a,:b] @@ -294,68 +294,67 @@ MachineLevelSubset(a,b) == ++ Given a list `l' of 2-list [cat,pred] of category object and associated ++ predicate, return a list of similar structures of all fundamental ++ ancestors with appropriate conditions. -FindFundAncs(l,e) == +FindFundAncs(l,tbl,e) == l = nil => nil [hd:=[f1,p1],:l] := l - canonicalForm f1 = nil => FindFundAncs(l,e) - ans := FindFundAncs(l,e) - for u in FindFundAncs([[CatEval(first x,e),mkAnd(p1,second x,e)] - for x in categoryAncestors f1],e) repeat + canonicalForm f1 = nil => FindFundAncs(l,tbl,e) + ans := FindFundAncs(l,tbl,e) + for u in FindFundAncs([[CatEval(first x,tbl,e),mkAnd(p1,second x,tbl,e)] + for x in categoryAncestors f1],tbl,e) repeat x := objectAssoc(first u,ans) => - ans := [[first u,mkOr(second x,second u,e)],:remove(ans,x)] + ans := [[first u,mkOr(second x,second u,tbl,e)],:remove(ans,x)] ans := [u,:ans] --testing to see if hd is already there - x := objectAssoc(f1,ans) => [[f1,mkOr(p1,second x,e)],:remove(ans,x)] + x := objectAssoc(f1,ans) => [[f1,mkOr(p1,second x,tbl,e)],:remove(ans,x)] p1 is true => for x in categoryPrincipals f1 repeat - if y := objectAssoc(CatEval(x,e),ans) then ans := remove(ans,y) + if y := objectAssoc(CatEval(x,tbl,e),ans) then ans := remove(ans,y) [hd,:ans] for x in categoryPrincipals f1 repeat - if y := objectAssoc(CatEval(x,e),ans) then ans:= - [[first y,mkOr(p1,second y,e)],:remove(ans,y)] + if y := objectAssoc(CatEval(x,tbl,e),ans) then ans:= + [[first y,mkOr(p1,second y,tbl,e)],:remove(ans,y)] [hd,:ans] -- Our new thing may have, as an alternate view, a principal -- descendant of something previously added which is therefore -- subsumed -CatEval: (%Thing,%Env) -> %Shell -CatEval(x,e) == +CatEval: (%Thing,%Table,%Env) -> %Shell +CatEval(x,tbl,e) == vector? x => x if $InteractiveMode then e := $CategoryFrame - compMakeCategoryObject(x,e).expr + getCategoryObject(tbl,x,e) -ancestor?: (%Form,%List %Instantiation,%Env) -> %Form -ancestor?(xname,leaves,env) == +ancestor?: (%Form,%List %Instantiation,%Table,%Env) -> %Form +ancestor?(xname,leaves,tbl,env) == -- checks for being a principal ancestor of one of the leaves listMember?(xname,leaves) => xname for y in leaves repeat - listMember?(xname,categoryPrincipals CatEval(y,env)) => return y + listMember?(xname,categoryPrincipals CatEval(y,tbl,env)) => return y -CondAncestorP(xname,leaves,condition,env) == +conditionalAncestor?(xname,leaves,condition,tbl,env) == -- checks for being a principal ancestor of one of the leaves for u in leaves repeat u':=first u ucond:= null rest u => true second u - xname = u' or listMember?(xname,categoryPrincipals CatEval(u',env)) => + xname = u' or listMember?(xname,categoryPrincipals CatEval(u',tbl,env)) => predicateImplies(condition,ucond) => return u' ++ Returns true if the form `a' designates a category that is any ++ kind of descendant of the category designated by the form `b'. -descendant?: (%Form,%Form,%Env) -> %Boolean -descendant?(a,b,e) == +descendant?: (%Form,%Form,%Table,%Env) -> %Boolean +descendant?(a,b,tbl,e) == a=b => true a is ["ATTRIBUTE",:.] => false a is ["SIGNATURE",:.] => false - a:= CatEval(a,e) + a:= CatEval(a,tbl,e) b is ["ATTRIBUTE",b'] => (l := assoc(b',categoryAttributes a)) => TruthP second l listMember?(b,categoryPrincipals a) => true - ancestor?(b,[first u for u in categoryAncestors a],e) => true - false + ancestor?(b,[first u for u in categoryAncestors a],tbl,e) --% The implementation of Join @@ -367,7 +366,7 @@ descendant?(a,b,e) == ++ The end result is a 2-list, the first component being a list of ++ (catobj,pred) pairs and the second component being the list of ++ newly discovered unconditional categories. -filterConditionalCategories(l,e) == +filterConditionalCategories(l,tbl,e) == conditionals := nil unconditionals := nil for cat in l repeat @@ -379,20 +378,21 @@ filterConditionalCategories(l,e) == not isCategoryForm(at,e) => $Attributes := [first at,:$Attributes] listMember?(pred,get("$Information","special",e)) => --It's true, so we add it as unconditional - unconditionals := [CatEval(at,e),:unconditionals] + unconditionals := [CatEval(at,tbl,e),:unconditionals] pred isnt ["and",:.] => - conditionals := [[CatEval(at,e),pred],:conditionals] + conditionals := [[CatEval(at,tbl,e),pred],:conditionals] -- Predicate is a conjunctive; decompose it. pred' := [x for x in pred.args | not listMember?(x,get("$Information","special",e)) and x isnt true] - pred' = nil => unconditionals := [CatEval(at,e),:unconditionals] - pred' is [x] => conditionals := [[CatEval(at,e),x],:conditionals] - conditionals := [[CatEval(at,e),["and",:pred']],:conditionals] + pred' = nil => unconditionals := [CatEval(at,tbl,e),:unconditionals] + pred' is [x] => conditionals := [[CatEval(at,tbl,e),x],:conditionals] + conditionals := [[CatEval(at,tbl,e),["and",:pred']],:conditionals] [conditionals,reverse! unconditionals] JoinInner(l,$e) == - [CondList,uncondList] := filterConditionalCategories(l,$e) + tbl := makeTable function valueEq? + [CondList,uncondList] := filterConditionalCategories(l,tbl,$e) [principal,:l] := [:l,:uncondList] principal := mkBuffer principal l' := [:CondList,:[[u,true] for u in l]] @@ -405,12 +405,12 @@ JoinInner(l,$e) == if name := canonicalForm bufferData principal then FundamentalAncestors := [[name],:FundamentalAncestors] -- this skips buggy code which discards needed categories - for [b,condition] in FindFundAncs(l',$e) | bname := b.0 repeat - CondAncestorP(bname,FundamentalAncestors,condition,$e) => nil - f := ancestor?(bname,[first u for u in FundamentalAncestors],$e) => + for [b,condition] in FindFundAncs(l',tbl,$e) | bname := b.0 repeat + conditionalAncestor?(bname,FundamentalAncestors,condition,tbl,$e) => nil + f := ancestor?(bname,[first u for u in FundamentalAncestors],tbl,$e) => [.,.,index] := assoc(f,FundamentalAncestors) FundamentalAncestors := [[bname,condition,index],:FundamentalAncestors] - PrinAncb := categoryPrincipals CatEval(bname,$e) + PrinAncb := categoryPrincipals CatEval(bname,tbl,$e) --Principal Ancestors of b reallynew := true -- This loop implements Category Subsumption @@ -441,7 +441,7 @@ JoinInner(l,$e) == bufferRef(principal,n) := b.0 for b in l repeat sigl := SigListUnion([DropImplementations u for u in categoryExports b], - sigl,principal) + sigl,principal,tbl) attl := S_+(categoryAttributes b,attl) globalDomains := [:globalDomains,:S_-(categoryParameters b,globalDomains)] for b in CondList repeat @@ -455,11 +455,11 @@ JoinInner(l,$e) == second v is true => nil attl := remove(attl,v) attl := - second u is true => [[first u,mkOr(second v,newpred,$e)],:attl] - [[first u,mkOr(second v,mkAnd(newpred,second u,$e),$e)],:attl] + second u is true => [[first u,mkOr(second v,newpred,tbl,$e)],:attl] + [[first u,mkOr(second v,mkAnd(newpred,second u,tbl,$e),tbl,$e)],:attl] sigl := SigListUnion( [AddPredicate(DropImplementations u,newpred) - for u in categoryExports(first b)],sigl,principal) where + for u in categoryExports(first b)],sigl,principal,tbl) where AddPredicate(op is [sig,oldpred,:implem],newpred) == newpred is true => op oldpred is true => [sig,newpred,:implem] diff --git a/src/interp/define.boot b/src/interp/define.boot index 0ddfd5b6..a3c893d1 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -233,7 +233,7 @@ knownInfo(pred,env,tbl == makeTable function valueEq?) == -- previous line checks fundamental anscestors, we should check their -- principal anscestors but this requires instantiating categories - or/[ancestor?(cat,[first u],env) + or/[ancestor?(cat,[first u],tbl,env) for u in categoryAncestors vv | knownInfo(second u,env,tbl)] => tableValue(tbl,pred) := true false diff --git a/src/interp/functor.boot b/src/interp/functor.boot index b0def0eb..356c66de 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -587,9 +587,9 @@ InvestigateConditions(db,catvecListMaker,tbl,env) == $HackSlot4:= MinimalPrimary=MaximalPrimary => nil MaximalPrimaries := - [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,env)] + [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,tbl,env)] MinimalPrimaries := - [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,env)] + [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,tbl,env)] MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) [[x] for x in MaximalPrimaries] ($Conditions:= Conds($principal,nil)) where @@ -619,31 +619,31 @@ InvestigateConditions(db,catvecListMaker,tbl,env) == # u=1 => first u ['AND,:u] for [v,:.] in newS repeat - for v' in [v,:categoryPrincipals CatEval(v,env)] repeat + for v' in [v,:categoryPrincipals CatEval(v,tbl,env)] repeat if (w:=assoc(v',$HackSlot4)) then - w.rest := if rest w then mkOr(u,rest w,env) else u - (list:= update(list,u,secondaries,newS,env)) where - update(list,cond,secondaries,newS,env) == + w.rest := if rest w then mkOr(u,rest w,tbl,env) else u + (list:= update(list,u,secondaries,newS,tbl,env)) where + update(list,cond,secondaries,newS,tbl,env) == (list2:= - [flist(sec,newS,old,cond,env) for sec in secondaries for old in list]) where - flist(sec,newS,old,cond,env) == + [flist(sec,newS,old,cond,tbl,env) for sec in secondaries for old in list]) where + flist(sec,newS,old,cond,tbl,env) == old=true => old for [newS2,:morecond] in newS repeat old:= - not ancestor?(sec,[newS2],env) => old - cond2 := mkAnd(cond,morecond,env) + not ancestor?(sec,[newS2],tbl,env) => old + cond2 := mkAnd(cond,morecond,tbl,env) null old => cond2 - mkOr(cond2,old,env) + mkOr(cond2,old,tbl,env) old list2 - list:= [[sec,:ICformat(u,env)] for u in list for sec in secondaries] + list:= [[sec,:ICformat(u,tbl,env)] for u in list for sec in secondaries] pv:= getPossibleViews($principal,tbl) -- $HackSlot4 is used in SetVector4 to ensure that conditional -- extensions of the principal view are handles correctly -- here we build the code necessary to remove spurious extensions - ($HackSlot4:= [reshape(u,env) for u in $HackSlot4]) where - reshape(u,env) == - ['%when,[TryGDC ICformat(rest u,env)], + ($HackSlot4:= [reshape(u,tbl,env) for u in $HackSlot4]) where + reshape(u,tbl,env) == + ['%when,[TryGDC ICformat(rest u,tbl,env)], ['%otherwise,['RPLACA,'(CAR TrueDomain), ['delete, quote first u,'(CAAR TrueDomain)]]]] $supplementaries:= @@ -652,32 +652,32 @@ InvestigateConditions(db,catvecListMaker,tbl,env) == and not (true=rest u) and not listMember?(first u,pv)] [true,:[LASSOC(ms,list) for ms in masterSecondaries]] -ICformat(u,env) == +ICformat(u,tbl,env) == u isnt [.,:.] => u u is ["has",:.] => compHasFormat(u,env) u is ['AND,:l] or u is ['and,:l] => - l:= removeDuplicates [ICformat(v,env) for [v,:l'] in tails l + l:= removeDuplicates [ICformat(v,tbl,env) for [v,:l'] in tails l | not listMember?(v,l')] -- we could have duplicates after, even if not before # l=1 => first l l1:= first l for u in rest l repeat - l1 := mkAnd(u,l1,env) + l1 := mkAnd(u,l1,tbl,env) l1 u is ['OR,:l] => (l:= ORreduce l) - # l=1 => ICformat(first l,env) - l:= ORreduce removeDuplicates [ICformat(u,env) for u in l] + # l=1 => ICformat(first l,tbl,env) + l:= ORreduce removeDuplicates [ICformat(u,tbl,env) for u in l] --causes multiple ANDs to be squashed, etc. -- and duplicates that have been built up by tidying - (l:= Hasreduce(l,env)) where - Hasreduce(l,env) == + (l:= Hasreduce(l,tbl,env)) where + Hasreduce(l,tbl,env) == for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, cond] repeat --check that v causes descendants to go for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, cond2]] repeat - if descendant?(cond,cond2,env) then l:= remove(l,u) + if descendant?(cond,cond2,tbl,env) then l:= remove(l,u) --v subsumes u for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, @@ -685,7 +685,7 @@ ICformat(u,env) == --check that v causes descendants to go for v in l | v is ['HasCategory, =name,['QUOTE, cond2]] repeat - if descendant?(cond,cond2,env) then l:= remove(l,u) + if descendant?(cond,cond2,tbl,env) then l:= remove(l,u) --v subsumes u l # l=1 => first l -- cgit v1.2.3