diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 71c5f3efe6..ff8d2157da 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -22,18 +22,6 @@ ERROR: not-a-tuple object ; primitive. In optimized code, an intrinsic - #! is generated which allocates a tuple but does not set - #! any of its slots. This means that any code that uses - #! (tuple) must fill in the slots before the next - #! call to GC. - #! - #! This word is only used in the expansion of , - #! where this invariant is guaranteed to hold. - ; - : tuple-layout ( class -- layout ) "layout" word-prop ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index bd6f639415..56b4630962 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -162,8 +162,6 @@ PREDICATE: small-slot < integer cells small-enough? ; PREDICATE: small-tagged < integer v>operand small-enough? ; -PREDICATE: inline-array < integer 32 < ; - : if-small-struct ( n size true false -- ? ) >r >r over not over struct-small-enough? and [ nip r> call r> drop ] [ r> drop r> call ] if ; diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index c9c4432d52..5a39cbca71 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -450,33 +450,28 @@ IN: cpu.ppc.intrinsics { +output+ { "tuple" } } } define-intrinsic -\ [ +\ (array) [ array "n" get 2 + cells %allot ! Store length "n" operand 12 LI 12 11 cell STW - ! Store initial element - "n" get [ "initial" operand 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "array" get object %store-tagged ] H{ - { +input+ { { [ inline-array? ] "n" } { f "initial" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic -\ [ +\ (byte-array) [ byte-array "n" get 2 cells + %allot ! Store length "n" operand 12 LI 12 11 cell STW - ! Store initial element - 0 12 LI - "n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each ! Store tagged ptr in reg "array" get object %store-tagged ] H{ - { +input+ { { [ inline-array? ] "n" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index d19749ae39..3cf131087e 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -6,8 +6,7 @@ kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system -classes.tuple.private strings.private slots.private -compiler.constants ; +strings.private slots.private compiler.constants optimizer.allot ; IN: cpu.x86.intrinsics ! Type checks @@ -298,37 +297,33 @@ IN: cpu.x86.intrinsics "tuple" get tuple %store-tagged ] %allot ] H{ - { +input+ { { [ tuple-layout? ] "layout" } } } + { +input+ { { [ ] "layout" } } } { +scratch+ { { f "tuple" } { f "scratch" } } } { +output+ { "tuple" } } } define-intrinsic -\ [ +\ (array) [ array "n" get 2 + cells [ ! Store length 1 object@ "n" operand MOV - ! Zero out the rest of the tuple - "n" get [ 2 + object@ "initial" operand MOV ] each ! Store tagged ptr in reg "array" get object %store-tagged ] %allot ] H{ - { +input+ { { [ inline-array? ] "n" } { f "initial" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic -\ [ +\ (byte-array) [ byte-array "n" get 2 cells + [ ! Store length 1 object@ "n" operand MOV - ! Store initial element - "n" get cell align cell /i [ 2 + object@ 0 MOV ] each ! Store tagged ptr in reg "array" get object %store-tagged ] %allot ] H{ - { +input+ { { [ inline-array? ] "n" } } } + { +input+ { { [ ] "n" } } } { +scratch+ { { f "array" } } } { +output+ { "array" } } } define-intrinsic diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 1c9138fe0b..3636a01963 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -540,9 +540,6 @@ set-primitive-effect \ { tuple-layout } { tuple } set-primitive-effect \ make-flushable -\ (tuple) { tuple-layout } { tuple } set-primitive-effect -\ (tuple) make-flushable - \ { word fixnum array fixnum } { tuple-layout } set-primitive-effect \ make-foldable diff --git a/core/optimizer/allot/allot.factor b/core/optimizer/allot/allot.factor new file mode 100644 index 0000000000..d89e3c5f84 --- /dev/null +++ b/core/optimizer/allot/allot.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors sequences sequences.private classes.tuple +classes.tuple.private kernel effects words quotations namespaces +definitions math math.order layouts alien.accessors +slots.private arrays byte-arrays inference.dataflow +inference.known-words inference.state optimizer.inlining +optimizer.backend ; +IN: optimizer.allot + +! Expand memory allocation primitives into simpler constructs +! to simplify the backend. + +: first-input ( #call -- obj ) dup in-d>> first node-literal ; + +: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ; + +\ (tuple) { tuple-layout } { tuple } set-primitive-effect +\ (tuple) make-flushable + +! if the input to new is a literal tuple class, we can expand it +: literal-new? ( #call -- ? ) + first-input tuple-class? ; + +: new-quot ( class -- quot ) + dup all-slots 1 tail ! delegate slot + [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ; + +: expand-new ( #call -- node ) + dup first-input + [ +inlined+ depends-on ] [ new-quot ] bi + f splice-quot ; + +\ new { + { [ dup literal-new? ] [ expand-new ] } +} define-optimizers + +: tuple-boa-quot ( layout -- quot ) + [ (tuple) ] + swap size>> 1 - [ 3 + ] map + [ [ set-slot ] curry [ keep ] curry ] map concat + [ f over 2 set-slot ] + 3append ; + +: expand-tuple-boa ( #call -- node ) + dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; + +\ { + { [ t ] [ expand-tuple-boa ] } +} define-optimizers + +: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ; + +\ (array) { integer } { array } set-primitive-effect +\ (array) make-flushable + +: -quot ( n -- quot ) + [ + [ swap (array) ] % + [ \ 2dup , , [ swap set-array-nth ] % ] each + \ nip , + ] [ ] make ; + +: literal-? ( #call -- ? ) + first-input dup integer? [ 0 32 between? ] [ drop f ] if ; + +: expand- ( #call -- node ) + dup first-input -quot f splice-quot ; + +\ { + { [ dup literal-? ] [ expand- ] } +} define-optimizers + +: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ; + +\ (byte-array) { integer } { byte-array } set-primitive-effect +\ (byte-array) make-flushable + +: bytes>cells ( m -- n ) cell align cell /i ; + +: -quot ( n -- quot ) + [ + \ (byte-array) , + bytes>cells [ cell * ] map + [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each + ] [ ] make ; + +: literal-? ( #call -- ? ) + first-input dup integer? [ 0 128 between? ] [ drop f ] if ; + +: expand- ( #call -- node ) + dup first-input -quot f splice-quot ; + +\ { + { [ dup literal-? ] [ expand- ] } +} define-optimizers diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 7527199fe9..cd5ec7fda2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -9,7 +9,7 @@ classes.tuple classes.predicate classes.tuple.private classes classes.algebra sequences.private combinators byte-arrays byte-vectors slots.private inference.dataflow inference.state inference.class optimizer.def-use optimizer.backend -optimizer.pattern-match optimizer.inlining ; +optimizer.pattern-match optimizer.inlining optimizer.allot ; IN: optimizer.known-words { (tuple) } [ @@ -25,37 +25,6 @@ IN: optimizer.known-words dup class? [ drop tuple ] unless 1array f ] "output-classes" set-word-prop -! if the input to new is a literal tuple class, we can expand it -: literal-new? ( #call -- ? ) - dup in-d>> first node-literal tuple-class? ; - -: new-quot ( class -- quot ) - dup all-slots 1 tail ! delegate slot - [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ; - -: expand-new ( #call -- node ) - dup dup in-d>> first node-literal - [ +inlined+ depends-on ] [ new-quot ] bi - f splice-quot ; - -\ new { - { [ dup literal-new? ] [ expand-new ] } -} define-optimizers - -: tuple-boa-quot ( layout -- quot ) - [ (tuple) ] - swap size>> 1 - [ 3 + ] map - [ [ set-slot ] curry [ keep ] curry ] map concat - [ f over 2 set-slot ] - 3append ; - -: expand-tuple-boa ( #call -- node ) - dup in-d>> peek value-literal tuple-boa-quot f splice-quot ; - -\ { - { [ t ] [ expand-tuple-boa ] } -} define-optimizers - ! the output of clone has the same type as the input { clone (clone) } [ [ diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor index 23cba3ea4c..d3c5a3ab91 100755 --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math optimizer.control -optimizer.collect optimizer.inlining inference.class ; +optimizer.known-words optimizer.math optimizer.allot +optimizer.control optimizer.collect optimizer.inlining +inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) diff --git a/extra/optimizer/debugger/debugger.factor b/extra/optimizer/debugger/debugger.factor index 2a79d8977f..fdae538896 100755 --- a/extra/optimizer/debugger/debugger.factor +++ b/extra/optimizer/debugger/debugger.factor @@ -58,6 +58,7 @@ MATCH-VARS: ?a ?b ?c ; { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } { { { ?a ?b } { ?a ?b ?a } } [ over ] } { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }