diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 85e49d080e..1a8eae0643 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -158,8 +158,6 @@ M: #if emit-node init-phantoms ##prologue [ emit-nodes ] with-node-iterator - ##epilogue - ##return ] with-cfg-builder ] keep ; @@ -304,7 +302,8 @@ M: #return-recursive emit-node [ ##epilogue ##return ] unless stop-iterating ; ! #terminate -M: #terminate emit-node drop stop-iterating ; +M: #terminate emit-node + drop finalize-phantoms stop-iterating ; ! FFI : return-size ( ctype -- n ) diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index beb301d97a..62663bdad0 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -305,9 +305,7 @@ M: loc lazy-store : set-value-classes ( classes -- ) phantom-datastack get over length over add-locs - stack>> [ - [ value-class class-and ] keep set-value-class - ] 2reverse-each ; + stack>> [ set-value-class ] 2reverse-each ; : finalize-phantoms ( -- ) #! Commit all deferred stacking shuffling, and ensure the diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index f157ad1d15..d72d50c18d 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -144,7 +144,8 @@ M: _branch-t generate-insn M: ##dispatch-label generate-insn label>> %dispatch-label ; -M: ##dispatch generate-insn drop %dispatch ; +M: ##dispatch generate-insn + [ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ; : dst/src ( insn -- dst src ) [ dst>> v>operand ] [ src>> v>operand ] bi ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index f5a1a86ae3..530705af46 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -461,3 +461,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ; ] compile-call b>> ] unit-test + +: mutable-value-bug-1 ( a b -- c ) + swap [ + { tuple } declare 1 slot + ] [ + 0 slot + ] if ; + +[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test + +: mutable-value-bug-2 ( a b -- c ) + swap [ + 0 slot + ] [ + { tuple } declare 1 slot + ] if ; + +[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index c312cb68dc..e716849baa 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays accessors sequences sequences.private words -fry namespaces make math math.order memoize classes.builtin -classes.tuple.private slots.private combinators layouts -byte-arrays alien.accessors +fry namespaces make math math.private math.order memoize +classes.builtin classes.tuple.private classes.algebra +slots.private combinators layouts byte-arrays alien.accessors compiler.intrinsics compiler.tree compiler.tree.combinators @@ -23,6 +23,10 @@ IN: compiler.tree.finalization GENERIC: finalize* ( node -- nodes ) +: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ; + +: splice-final ( quot -- nodes ) splice-quot finalize ; + M: #copy finalize* drop f ; M: #shuffle finalize* @@ -34,30 +38,30 @@ M: #shuffle finalize* word>> "predicating" word-prop builtin-class? ; MEMO: builtin-predicate-expansion ( word -- nodes ) - def>> splice-quot ; + def>> splice-final ; : expand-builtin-predicate ( #call -- nodes ) word>> builtin-predicate-expansion ; -: first-literal ( #call -- obj ) node-input-infos first literal>> ; - -: last-literal ( #call -- obj ) node-input-infos peek literal>> ; - : expand-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ last-literal tuple-layout? ] [ drop f ] if ; -MEMO: (tuple-boa-expansion) ( n -- quot ) +MEMO: (tuple-boa-expansion) ( n -- nodes ) [ - [ 2 + ] map - [ '[ [ _ set-slot ] keep ] % ] each - ] [ ] make ; + [ '[ _ (tuple) ] % ] + [ + [ 2 + ] map + [ '[ [ _ set-slot ] keep ] % ] each + ] bi + ] [ ] make '[ _ dip ] splice-final ; : tuple-boa-expansion ( layout -- quot ) #! No memoization here since otherwise we'd hang on to #! tuple layout objects. - size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ; + size>> (tuple-boa-expansion) + [ over 1 set-slot ] splice-final append ; : expand-tuple-boa ( #call -- node ) last-literal tuple-boa-expansion ; @@ -65,14 +69,15 @@ MEMO: (tuple-boa-expansion) ( n -- quot ) MEMO: -expansion ( n -- quot ) [ [ swap (array) ] % - [ \ 2dup , , [ swap set-array-nth ] % ] each + [ '[ _ over 1 set-slot ] % ] + [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi \ nip , - ] [ ] make splice-quot ; + ] [ ] make splice-final ; : expand-? ( #call -- ? ) dup word>> \ eq? [ first-literal dup integer? - [ 0 32 between? ] [ drop f ] if + [ 0 8 between? ] [ drop f ] if ] [ drop f ] if ; : expand- ( #call -- node ) @@ -83,28 +88,62 @@ MEMO: -expansion ( n -- quot ) MEMO: -expansion ( n -- quot ) [ [ (byte-array) ] % - bytes>cells [ cell * ] map - [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each - ] [ ] make splice-quot ; + [ '[ _ over 1 set-slot ] % ] + [ + bytes>cells [ + cell * + '[ 0 over _ set-alien-unsigned-cell ] % + ] each + ] bi + ] [ ] make splice-final ; : expand-? ( #call -- ? ) dup word>> \ eq? [ first-literal dup integer? - [ 0 128 between? ] [ drop f ] if + [ 0 32 between? ] [ drop f ] if ] [ drop f ] if ; : expand- ( #call -- nodes ) first-literal -expansion ; +MEMO: -expansion ( -- quot ) + [ (ratio) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ; + +: expand- ( #call -- nodes ) + drop -expansion ; + +MEMO: -expansion ( -- quot ) + [ (complex) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ; + +: expand- ( #call -- nodes ) + drop -expansion ; + +MEMO: -expansion ( -- quot ) + [ (wrapper) [ 1 set-slot ] keep ] splice-final ; + +: expand- ( #call -- nodes ) + drop -expansion ; + +: expand-set-slot ( #call -- nodes ) + dup in-d>> first node-value-info class>> immediate class<= + [ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ? + splice-final ; + M: #call finalize* { { [ dup builtin-predicate? ] [ expand-builtin-predicate ] } { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] } { [ dup expand-? ] [ expand- ] } { [ dup expand-? ] [ expand- ] } - [ ] + [ + dup word>> { + { \ [ expand- ] } + { \ [ expand- ] } + { \ [ expand- ] } + { \ set-slot [ expand-set-slot ] } + [ drop ] + } case + ] } cond ; M: node finalize* ; - -: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index f4243eb987..deed160cc3 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -63,7 +63,7 @@ HOOK: %jump-f cpu ( label vreg -- ) ! Test if vreg is 't' or not HOOK: %jump-t cpu ( label vreg -- ) -HOOK: %dispatch cpu ( -- ) +HOOK: %dispatch cpu ( src temp -- ) HOOK: %dispatch-label cpu ( word -- ) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 90807ff4ce..d08ef85173 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -69,9 +69,9 @@ M: x86 stack-frame-size ( n -- i ) M: x86 %prologue ( n -- ) temp-reg-1 0 MOV rc-absolute-cell rel-this - dup cell + PUSH + dup PUSH temp-reg-1 PUSH - stack-reg swap 2 cells - SUB ; + stack-reg swap 3 cells - SUB ; : incr-stack-reg ( n -- ) dup 0 = [ drop ] [ stack-reg swap ADD ] if ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 511dcc6bbd..87d3024475 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -78,21 +78,23 @@ SYMBOL: quotations V{ } clone meta-r set d-in [ ] change ; -: infer-branch ( literal -- namespace ) +: infer-branch ( literal quot -- namespace ) [ copy-inference nest-visitor - [ value>> quotation set ] [ infer-literal-quot ] bi + [ [ value>> quotation set ] [ infer-literal-quot ] bi ] dip check->r + call ] H{ } make-assoc ; inline -: infer-branches ( branches -- input children data ) - [ pop-d ] dip - [ infer-branch ] map - [ stack-visitor branch-variable ] keep ; +: infer-branches ( branches quot -- input children data ) + [ pop-d ] 2dip + [ infer-branch ] curry map + [ stack-visitor branch-variable ] keep ; inline : (infer-if) ( branches -- ) - infer-branches [ first2 #if, ] dip compute-phi-function ; + [ ] infer-branches + [ first2 #if, ] dip compute-phi-function ; : infer-if ( -- ) 2 consume-d @@ -106,4 +108,5 @@ SYMBOL: quotations : infer-dispatch ( -- ) pop-literal nip [ ] map - infer-branches [ #dispatch, ] dip compute-phi-function ; + [ f #return, ] infer-branches + [ #dispatch, ] dip compute-phi-function ;