Expand allocations for simpler intrinsics

core/classes/tuple/tuple.factor

@@ -22,18 +22,6 @@ ERROR: not-a-tuple object ;
 
 <PRIVATE
 
-: (tuple) ( layout -- tuple )
-    #! In non-optimized code, this word simply calls the
-    #! <tuple> 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 <tuple-boa>,
-    #! where this invariant is guaranteed to hold.
-    <tuple> ;
-
 : tuple-layout ( class -- layout )
     "layout" word-prop ;
 

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 ;

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -450,33 +450,28 @@ IN: cpu.ppc.intrinsics
     { +output+ { "tuple" } }
 } define-intrinsic
 
-\ <array> [
+\ (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) [
     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

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) [
     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) [
     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

core/inference/known-words/known-words.factor

@@ -540,9 +540,6 @@ set-primitive-effect
 \ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
 \ <tuple> make-flushable
 
-\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
-\ (tuple) make-flushable
-
 \ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
 \ <tuple-layout> make-foldable
 

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 } <effect> 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 <reversed>
+    [ [ 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 ;
+
+\ <tuple-boa> {
+    { [ t ] [ expand-tuple-boa ] }
+} define-optimizers
+
+: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } <effect> set-primitive-effect
+\ (array) make-flushable
+
+: <array>-quot ( n -- quot )
+    [
+        [ swap (array) ] %
+        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        \ nip ,
+    ] [ ] make ;
+
+: literal-<array>? ( #call -- ? )
+    first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+    dup first-input <array>-quot f splice-quot ;
+
+\ <array> {
+    { [ dup literal-<array>? ] [ expand-<array> ] }
+} define-optimizers
+
+: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
+\ (byte-array) make-flushable
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+: <byte-array>-quot ( n -- quot )
+    [
+        \ (byte-array) ,
+        bytes>cells [ cell * ] map
+        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+    ] [ ] make ;
+
+: literal-<byte-array>? ( #call -- ? )
+    first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- node )
+    dup first-input <byte-array>-quot f splice-quot ;
+
+\ <byte-array> {
+    { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
+} define-optimizers

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> <tuple-boa> (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 <reversed>
-    [ [ 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 ;
-
-\ <tuple-boa> {
-    { [ t ] [ expand-tuple-boa ] }
-} define-optimizers
-
 ! the output of clone has the same type as the input
 { clone (clone) } [
     [

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 ? )

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 ] }