Adding missing optimizations to finalization pass

basis/compiler/intrinsics/intrinsics.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes.tuple classes.tuple.private math arrays 
 byte-arrays words stack-checker.known-words ;
-IN: compiler.tree.intrinsics
+IN: compiler.intrinsics
 
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;

basis/compiler/tree/cleanup/cleanup.factor

@@ -4,8 +4,9 @@ USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
-stack-checker.branches compiler.tree
+stack-checker.branches
-compiler.tree.intrinsics
+compiler.intrinsics
+compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -6,7 +6,7 @@ compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics namespaces compiler.tree.propagation.info
+compiler.intrinsics namespaces compiler.tree.propagation.info
 stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -4,8 +4,8 @@ USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;

basis/compiler/tree/finalization/finalization.factor

@@ -1,17 +1,32 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences words namespaces
+USING: kernel arrays accessors sequences sequences.private words
-classes.builtin
+fry namespaces math math.order memoize classes.builtin
+classes.tuple.private slots.private combinators layouts
+byte-arrays alien.accessors
+compiler.intrinsics
 compiler.tree
 compiler.tree.builder
 compiler.tree.normalization
 compiler.tree.propagation
+compiler.tree.propagation.info
 compiler.tree.cleanup
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.combinators ;
 IN: compiler.tree.finalization
 
+! This pass runs after propagation, so that it can expand
+! built-in type predicates and memory allocation; these cannot
+! be expanded before propagation since we need to see 'fixnum?'
+! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! We also delete empty stack shuffles and copies to facilitate
+! tail call optimization in the code generator. After this pass
+! runs, stack flow information is no longer accurate, since we
+! punt in 'splice-quot' and don't update everything that we
+! should; this simplifies the code, improves performance, and we
+! don't need the stack flow information after this pass anyway.
+
 GENERIC: finalize* ( node -- nodes )
 
 M: #copy finalize* drop f ;
@@ -21,9 +36,6 @@ M: #shuffle finalize*
     [ in>> ] [ out>> ] bi sequence=
     [ drop f ] when ;
 
-: builtin-predicate? ( word -- ? )
-    "predicating" word-prop builtin-class? ;
-
 : splice-quot ( quot -- nodes )
     [
         build-tree
@@ -35,10 +47,81 @@ M: #shuffle finalize*
         but-last
     ] with-scope ;
 
+: builtin-predicate? ( #call -- ? )
+    word>> "predicating" word-prop builtin-class? ;
+
+MEMO: builtin-predicate-expansion ( word -- nodes )
+    def>> splice-quot ;
+
+: 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>> \ <tuple-boa> eq? [
+        last-literal tuple-layout?
+    ] [ drop f ] if ;
+
+MEMO: (tuple-boa-expansion) ( n -- quot )
+    [
+        1- [ 3 + ] map <reversed>
+        [ '[ [ , set-slot ] keep ] % ] each
+        [ f over 2 set-slot ] %
+    ] [ ] make ;
+
+: tuple-boa-expansion ( layout -- quot )
+    #! No memoization here since otherwise we'd hang on to
+    #! tuple layout objects.
+    [ \ (tuple) , size>> (tuple-boa-expansion) % ] [ ] make splice-quot ;
+
+: expand-tuple-boa ( #call -- node )
+    last-literal tuple-boa-expansion ;
+
+MEMO: <array>-expansion ( n -- quot )
+    [
+        [ swap (array) ] %
+        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        \ nip ,
+    ] [ ] make splice-quot ;
+
+: expand-<array>? ( #call -- ? )
+    dup word>> \ <array> eq? [
+        first-literal dup integer?
+        [ 0 32 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+    first-literal <array>-expansion ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+MEMO: <byte-array>-expansion ( n -- quot )
+    [
+        [ (byte-array) ] %
+        bytes>cells [ cell * ] map
+        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+    ] [ ] make splice-quot ;
+
+: expand-<byte-array>? ( #call -- ? )
+    dup word>> \ <byte-array> eq? [
+        first-literal dup integer?
+        [ 0 128 between? ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- nodes )
+    first-literal <byte-array>-expansion ;
+
 M: #call finalize*
-    dup word>> builtin-predicate? [
+    {
-        word>> def>> splice-quot
+        { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
-    ] when ;
+        { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
+        { [ dup expand-<array>? ] [ expand-<array> ] }
+        { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
+        [ ]
+    } cond ;
 
 M: node finalize* ;
 

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -7,6 +7,7 @@ classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
 definitions
 stack-checker.state
+compiler.intrinsics
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -253,7 +254,7 @@ generic-comparison-ops [
     [ 2nip ] curry "outputs" set-word-prop
 ] each
 
-{ <tuple> <tuple-boa> } [
+{ <tuple> <tuple-boa> (tuple) } [
     [
         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -4,8 +4,8 @@ USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
 stack-checker.branches
+compiler.intrinsics
 compiler.tree
-compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.simple

basis/cpu/ppc/intrinsics/intrinsics.factor

@@ -4,11 +4,15 @@ USING: accessors alien alien.accessors alien.c-types arrays
 cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
 cpu.architecture kernel kernel.private math math.private
 namespaces sequences words generic quotations byte-arrays
-hashtables hashtables.private compiler.generator
+hashtables hashtables.private
-compiler.generator.registers compiler.generator.fixup
 sequences.private sbufs vectors system layouts
-math.floats.private classes slots.private combinators
+math.floats.private classes slots.private
-compiler.constants ;
+combinators
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.ppc.intrinsics
 
 : %slot-literal-known-tag ( -- out value offset )
@@ -437,44 +441,44 @@ IN: cpu.ppc.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells %allot
+    tuple "layout" get size>> 2 + cells %allot
-!     ! Store layout
+    ! Store layout
-!     "layout" get 12 load-indirect
+    "layout" get 12 load-indirect
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "tuple" get tuple %store-tagged
+    "tuple" get tuple %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } } }
+    { +scratch+ { { f "tuple" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells %allot
+    array "n" get 2 + cells %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + %allot
+    byte-array "n" get 2 cells + %allot
-!     ! Store length
+    ! Store length
-!     "n" operand 12 LI
+    "n" operand 12 LI
-!     12 11 cell STW
+    12 11 cell STW
-!     ! Store tagged ptr in reg
+    ! Store tagged ptr in reg
-!     "array" get object %store-tagged
+    "array" get object %store-tagged
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot

basis/cpu/x86/intrinsics/intrinsics.factor

@@ -4,10 +4,14 @@ USING: accessors alien alien.accessors arrays cpu.x86.assembler
 cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
 kernel.private math math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
-compiler.generator compiler.generator.registers
+sequences.private sbufs sbufs.private
-compiler.generator.fixup sequences.private sbufs sbufs.private
 vectors vectors.private layouts system strings.private
-slots.private compiler.constants ;
+slots.private 
+compiler.constants
+compiler.intrinsics
+compiler.generator
+compiler.generator.fixup
+compiler.generator.registers ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
@@ -289,45 +293,45 @@ IN: cpu.x86.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-! \ (tuple) [
+\ (tuple) [
-!     tuple "layout" get size>> 2 + cells [
+    tuple "layout" get size>> 2 + cells [
-!         ! Store layout
+        ! Store layout
-!         "layout" get "scratch" get load-literal
+        "layout" get "scratch" get load-literal
-!         1 object@ "scratch" operand MOV
+        1 object@ "scratch" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "tuple" get tuple %store-tagged
+        "tuple" get tuple %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "layout" } } }
+    { +input+ { { [ ] "layout" } } }
-!     { +scratch+ { { f "tuple" } { f "scratch" } } }
+    { +scratch+ { { f "tuple" } { f "scratch" } } }
-!     { +output+ { "tuple" } }
+    { +output+ { "tuple" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (array) [
+\ (array) [
-!     array "n" get 2 + cells [
+    array "n" get 2 + cells [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
-! 
+
-! \ (byte-array) [
+\ (byte-array) [
-!     byte-array "n" get 2 cells + [
+    byte-array "n" get 2 cells + [
-!         ! Store length
+        ! Store length
-!         1 object@ "n" operand MOV
+        1 object@ "n" operand MOV
-!         ! Store tagged ptr in reg
+        ! Store tagged ptr in reg
-!         "array" get object %store-tagged
+        "array" get object %store-tagged
-!     ] %allot
+    ] %allot
-! ] H{
+] H{
-!     { +input+ { { [ ] "n" } } }
+    { +input+ { { [ ] "n" } } }
-!     { +scratch+ { { f "array" } } }
+    { +scratch+ { { f "array" } } }
-!     { +output+ { "array" } }
+    { +output+ { "array" } }
-! } define-intrinsic
+} define-intrinsic
 
 \ <ratio> [
     ratio 3 cells [