Various fixes

db4
Slava Pestov 2008-08-09 23:00:27 -05:00
parent 0097b1d89d
commit ca57e4386c
17 changed files with 173 additions and 64 deletions

View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel sets namespaces accessors assocs
arrays combinators continuations
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.checker
! Check some invariants.
ERROR: check-use-error value message ;
: check-use ( value uses -- )
[ empty? [ "No use" check-use-error ] [ drop ] if ]
[ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
: check-def-use ( -- )
def-use get [ uses>> check-use ] assoc-each ;
GENERIC: check-node ( node -- )
M: #shuffle check-node
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
[ length ] map all-equal? [ "Bad lengths" throw ] unless ;
M: #copy check-node inputs/outputs 2array check-lengths ;
M: #>r check-node inputs/outputs 2array check-lengths ;
M: #r> check-node inputs/outputs 2array check-lengths ;
M: #return-recursive check-node inputs/outputs 2array check-lengths ;
M: #phi check-node
{
[ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
[ phi-in-d>> check-lengths ]
[ phi-in-r>> check-lengths ]
} cleave ;
M: #enter-recursive check-node
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
bi ;
M: #push check-node
out-d>> length 1 = [ "Bad #push" throw ] unless ;
M: node check-node drop ;
ERROR: check-node-error node error ;
: check-nodes ( nodes -- )
compute-def-use
check-def-use
[ [ check-node ] [ check-node-error ] recover ] each-node ;

View File

@ -105,10 +105,10 @@ SYMBOL: live-branches
M: #branch cleanup* M: #branch cleanup*
{ {
[ live-branches>> live-branches set ]
[ delete-unreachable-branches ] [ delete-unreachable-branches ]
[ cleanup-children ] [ cleanup-children ]
[ fold-only-branch ] [ fold-only-branch ]
[ live-branches>> live-branches set ]
} cleave ; } cleave ;
: cleanup-phi-in ( phi-in live-branches -- phi-in' ) : cleanup-phi-in ( phi-in live-branches -- phi-in' )
@ -122,7 +122,8 @@ M: #phi cleanup*
[ '[ , cleanup-phi-in ] change-phi-in-r ] [ '[ , cleanup-phi-in ] change-phi-in-r ]
[ '[ , cleanup-phi-in ] change-phi-info-d ] [ '[ , cleanup-phi-in ] change-phi-info-d ]
[ '[ , cleanup-phi-in ] change-phi-info-r ] [ '[ , cleanup-phi-in ] change-phi-info-r ]
} cleave ; } cleave
live-branches off ;
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ; : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs dequeues search-dequeues USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining compiler.tree kernel sequences words sets
compiler.tree.def-use compiler.tree.combinators ; stack-checker.branches stack-checker.inlining
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.dataflow-analysis IN: compiler.tree.dataflow-analysis
! Dataflow analysis ! Dataflow analysis
@ -34,5 +35,5 @@ SYMBOL: work-list
: dfa ( node mark-quot iterate-quot -- assoc ) : dfa ( node mark-quot iterate-quot -- assoc )
init-dfa init-dfa
[ each-node ] dip [ each-node ] dip
work-list get H{ { f f } } clone work-list get H{ { +bottom+ f } } clone
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

View File

@ -1,7 +1,9 @@
USING: accessors namespaces assocs kernel sequences math USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.def-use arrays kernel.private ; compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
sorting math.order binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests IN: compiler.tree.def-use.tests
\ compute-def-use must-infer \ compute-def-use must-infer
@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
} 1&& } 1&&
] unit-test ] unit-test
! compute-def-use checks for SSA violations, so we make sure : test-def-use ( quot -- )
! some common patterns are generated correctly. build-tree
normalize
propagate
cleanup
compute-def-use
check-nodes ;
! compute-def-use checks for SSA violations, so we use that to
! ensure we generate some common patterns correctly.
{ {
[ [ drop ] each-integer ] [ [ drop ] each-integer ]
[ [ 2drop ] curry each-integer ] [ [ 2drop ] curry each-integer ]
@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
[ [ 1 ] 2 [ + ] curry compose call + ] [ [ 1 ] 2 [ + ] curry compose call + ]
[ [ 1 ] [ call 2 ] curry call + ] [ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ] [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
[ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ } [
[ ] swap [ build-tree compute-def-use drop ] curry unit-test [ ] swap [ test-def-use ] curry unit-test
] each ] each

View File

@ -1,8 +1,11 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces assocs sequences kernel generic assocs USING: arrays namespaces assocs sequences kernel generic assocs
classes vectors accessors combinators sets stack-checker.state classes vectors accessors combinators sets
compiler.tree compiler.tree.combinators ; stack-checker.state
stack-checker.branches
compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.def-use IN: compiler.tree.def-use
SYMBOL: def-use SYMBOL: def-use
@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ; M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ; M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values M: #phi node-uses-values
[ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ; [ phi-in-d>> ] [ phi-in-r>> ] bi
append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ; M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ; M: node node-uses-values in-d>> ;
@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
[ dup node-uses-values [ use-value ] with each ] [ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ; [ dup node-defs-values [ def-value ] with each ] bi ;
: check-use ( uses -- )
[ empty? [ "No use" throw ] when ]
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
: check-def-use ( -- )
def-use get [ nip uses>> check-use ] assoc-each ;
: compute-def-use ( node -- node ) : compute-def-use ( node -- node )
H{ } clone def-use set H{ } clone def-use set
dup [ node-def-use ] each-node dup [ node-def-use ] each-node ;
check-def-use ;

View File

@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.branches IN: compiler.tree.escape-analysis.branches
M: #branch escape-analysis* M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ; [ in-d>> add-escaping-values ]
[ live-children sift [ (escape-analysis) ] each ]
bi ;
: (merge-allocations) ( values -- allocation ) : (merge-allocations) ( values -- allocation )
[ [
@ -25,7 +27,7 @@ M: #branch escape-analysis*
] map ; ] map ;
: merge-allocations ( in-values out-values -- ) : merge-allocations ( in-values out-values -- )
[ [ sift ] map ] dip [ [ remove-bottom ] map ] dip
[ [ merge-values ] 2each ] [ [ merge-values ] 2each ]
[ [ (merge-allocations) ] dip record-allocations ] [ [ (merge-allocations) ] dip record-allocations ]
2bi ; 2bi ;

View File

@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple ; prettyprint classes.tuple.private classes classes.tuple
compiler.tree.intrinsics ;
\ escape-analysis must-infer \ escape-analysis must-infer
@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ; out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations* M: #call count-unboxed-allocations*
dup word>> { <tuple-boa> <complex> } memq? dup word>> { <immutable-tuple-boa> <complex> } memq?
[ (count-unboxed-allocations) ] [ drop ] if ; [ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations* M: #push count-unboxed-allocations*

View File

@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
} cond ; } cond ;
: check-fixed-point ( node alloc1 alloc2 -- ) : check-fixed-point ( node alloc1 alloc2 -- )
[ congruent? ] 2all? [ drop ] [ [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
label>> f >>fixed-point drop
] if ;
: node-input-allocations ( node -- allocations ) : node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ; in-d>> [ allocation ] map ;
@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
] 2bi ; ] 2bi ;
M: #recursive escape-analysis* ( #recursive -- ) M: #recursive escape-analysis* ( #recursive -- )
[ { 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
child>> child>>
[ first out-d>> introduce-values ] [ first out-d>> introduce-values ]
[ first analyze-recursive-phi ] [ first analyze-recursive-phi ]
[ (escape-analysis) ] [ (escape-analysis) ]
tri tri
] until-fixed-point ; ] curry until-fixed-point ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- ) M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive #! Handled by #recursive

View File

@ -33,8 +33,10 @@ DEFER: record-literal-allocation
} cond ; } cond ;
: record-literal-allocation ( value object -- ) : record-literal-allocation ( value object -- )
object-slots dup object-slots
[ make-literal-slots swap record-allocation ] [ 2drop ] if ; [ make-literal-slots swap record-allocation ]
[ unknown-allocation ]
if* ;
M: #push escape-analysis* M: #push escape-analysis*
#! Delegation. #! Delegation.

View File

@ -1,6 +1,6 @@
IN: compiler.tree.normalization.tests IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization USING: compiler.tree.builder compiler.tree.normalization
compiler.tree sequences accessors tools.test kernel ; compiler.tree sequences accessors tools.test kernel math ;
\ count-introductions must-infer \ count-introductions must-infer
\ fixup-enter-recursive must-infer \ fixup-enter-recursive must-infer
@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
[ recursive-inputs ] [ recursive-inputs ]
[ normalize recursive-inputs ] bi [ normalize recursive-inputs ] bi
] unit-test ] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test

View File

@ -1,7 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays USING: fry namespaces sequences math accessors kernel arrays
stack-checker.backend stack-checker.inlining compiler.tree stack-checker.backend
stack-checker.branches
stack-checker.inlining
compiler.tree
compiler.tree.combinators ; compiler.tree.combinators ;
IN: compiler.tree.normalization IN: compiler.tree.normalization
@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
bi ; bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' ) : eliminate-phi-introductions ( introductions seq terminated -- seq' )
[ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ; [ flip ] dip [
[ nip ] [
dup [ +bottom+ eq? ] left-trim
[ [ length ] bi@ - tail* ] keep append
] if
] 3map flip ;
M: #phi eliminate-introductions* M: #phi eliminate-introductions*
remaining-introductions get swap dup terminated>> remaining-introductions get swap dup terminated>>

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators math.intervals arrays classes.algebra combinators
stack-checker.branches
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.combinators compiler.tree.combinators
@ -59,7 +60,14 @@ SYMBOL: infer-children-data
: compute-phi-input-infos ( phi-in -- phi-info ) : compute-phi-input-infos ( phi-in -- phi-info )
infer-children-data get infer-children-data get
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ; '[
, [
[
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind
] 2map
] map ;
: annotate-phi-inputs ( #phi -- ) : annotate-phi-inputs ( #phi -- )
dup phi-in-d>> compute-phi-input-infos >>phi-info-d dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
M: #phi propagate-after ( #phi -- ) M: #phi propagate-after ( #phi -- )
condition-value get [ condition-value get [
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
3array flip [ [
first3 [ possible-boolean-values ] map [ possible-boolean-values ] map
branch-phi-constraints branch-phi-constraints
] each ] 3each
] [ drop ] if ; ] [ drop ] if ;
M: #phi propagate-around ( #phi -- ) M: #phi propagate-around ( #phi -- )

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences assocs math kernel accessors fry USING: namespaces sequences assocs math kernel accessors fry
combinators sets locals combinators sets locals
stack-checker.branches
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.combinators ; compiler.tree.combinators ;
@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
#! An output is a copy of every input if all inputs are #! An output is a copy of every input if all inputs are
#! copies of the same original value. #! copies of the same original value.
[ [
swap sift [ resolve-copy ] map swap remove-bottom [ resolve-copy ] map
dup [ all-equal? ] [ empty? not ] bi and dup [ all-equal? ] [ empty? not ] bi and
[ first swap is-copy-of ] [ 2drop ] if [ first swap is-copy-of ] [ 2drop ] if
] 2each ; ] 2each ;

View File

@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
: unify-recursive-stacks ( stacks initial -- infos ) : unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [ over empty? [ nip ] [
[ [
[ sift value-infos-union ] dip [ value-infos-union ] dip
[ generalize-counter ] keep [ generalize-counter ] keep
value-info-union value-info-union
] 2map ] 2map

View File

@ -1,24 +1,22 @@
IN: compiler.tree.tuple-unboxing.tests IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree.tuple-unboxing USING: tools.test compiler.tree.tuple-unboxing compiler.tree
compiler.tree compiler.tree.builder compiler.tree.normalization compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup compiler.tree.propagation compiler.tree.cleanup
compiler.tree.escape-analysis compiler.tree.tuple-unboxing compiler.tree.escape-analysis compiler.tree.tuple-unboxing
compiler.tree.def-use kernel accessors sequences math compiler.tree.checker compiler.tree.def-use kernel accessors
sorting math.order binary-search ; sequences math math.private sorting math.order binary-search
sequences.private slots.private ;
\ unbox-tuples must-infer \ unbox-tuples must-infer
: test-unboxing ( quot -- ) : test-unboxing ( quot -- )
#! Just make sure it doesn't throw errors; compute def use
#! for kicks.
build-tree build-tree
normalize normalize
propagate propagate
cleanup cleanup
escape-analysis escape-analysis
unbox-tuples unbox-tuples
compute-def-use check-nodes ;
drop ;
TUPLE: cons { car read-only } { cdr read-only } ; TUPLE: cons { car read-only } { cdr read-only } ;
@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
[ cons boa [ car>> ] [ cdr>> ] bi ] [ cons boa [ car>> ] [ cdr>> ] bi ]
[ [ 1 cons boa ] [ 2 cons boa ] if car>> ] [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ] [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
[ 2 cons boa { [ ] [ ] } dispatch ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
[ [ ] [ ] curry curry call ]
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ] [ [ <=> ] sort ]
[ [ <=> ] with search ] [ [ <=> ] with search ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each } [ [ ] swap [ test-unboxing ] curry unit-test ] each

View File

@ -3,6 +3,7 @@
USING: namespaces assocs accessors kernel combinators USING: namespaces assocs accessors kernel combinators
classes.algebra sequences sequences.deep slots.private classes.algebra sequences sequences.deep slots.private
classes.tuple.private math math.private arrays classes.tuple.private math math.private arrays
stack-checker.branches
compiler.tree compiler.tree
compiler.tree.intrinsics compiler.tree.intrinsics
compiler.tree.combinators compiler.tree.combinators
@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
: flatten-values ( values -- values' ) : flatten-values ( values -- values' )
(flatten-values) flatten ; (flatten-values) flatten ;
: flatten-value ( values -- values )
[ unboxed-allocation ] [ 1array ] bi or ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values ) : prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> first flatten-value ] [ in-d>> flatten-values ]
[ out-d>> flatten-values ] [ out-d>> flatten-values ]
[ [
out-d>> first slot-accesses get at out-d>> first slot-accesses get at
[ slot#>> ] [ value>> ] bi allocation nth flatten-value [ slot#>> ] [ value>> ] bi allocation nth
1array flatten-values
] tri ; ] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle ) : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
@ -73,7 +72,8 @@ M: #call unbox-tuples*
} case ; } case ;
M: #declare unbox-tuples* M: #declare unbox-tuples*
[ unzip [ flatten-values ] dip zip ] change-declaration ; #! We don't look at declarations after propagation anyway.
f >>declaration ;
M: #copy unbox-tuples* M: #copy unbox-tuples*
[ flatten-values ] change-in-d [ flatten-values ] change-in-d
@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
[ flatten-values ] change-in-d ; [ flatten-values ] change-in-d ;
M: #phi unbox-tuples* M: #phi unbox-tuples*
[ flip [ flatten-values ] map flip ] change-phi-in-d [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
[ flip [ flatten-values ] map flip ] change-phi-in-r [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
[ flatten-values ] change-out-d [ flatten-values ] change-out-d
[ flatten-values ] change-out-r ; [ flatten-values ] change-out-r ;
M: #recursive unbox-tuples* M: #recursive unbox-tuples*

View File

@ -9,21 +9,30 @@ IN: stack-checker.branches
: balanced? ( pairs -- ? ) : balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ; [ second ] filter [ first2 length - ] map all-equal? ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) SYMBOL: +bottom+
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-f ( seq -- newseq ) : unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ length ] map supremum '[ , f pad-left ] map ; dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
'[ , +bottom+ pad-left ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq ) : phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [ dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map swap '[ , _ first2 unify-inputs ] map
pad-with-f pad-with-bottom
flip flip
] if ; ] if ;
: remove-bottom ( seq -- seq' )
+bottom+ swap remove ;
: unify-values ( values -- phi-out ) : unify-values ( values -- phi-out )
sift dup empty? [ drop <value> ] [ remove-bottom
dup empty? [ drop <value> ] [
[ known ] map dup all-eq? [ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if [ first make-known ] [ drop <value> ] if
] if ; ] if ;