diff --git a/basis/compiler/tree/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor similarity index 95% rename from basis/compiler/tree/intrinsics/intrinsics.factor rename to basis/compiler/intrinsics/intrinsics.factor index 5bcc58626b..b995e6d737 100644 --- a/basis/compiler/tree/intrinsics/intrinsics.factor +++ b/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 ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 8056e75b3e..cc5f0619cd 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/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 -compiler.tree.intrinsics +stack-checker.branches +compiler.intrinsics +compiler.tree compiler.tree.combinators compiler.tree.propagation.info compiler.tree.propagation.branches ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 0b7db5b36a..f51046c6cb 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/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 diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index d69f6cab9e..e143fb75ed 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/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 ; diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index f08116b936..4de81306cc 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/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 -classes.builtin +USING: kernel arrays accessors sequences sequences.private words +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>> \ eq? [ + last-literal tuple-layout? + ] [ drop f ] if ; + +MEMO: (tuple-boa-expansion) ( n -- quot ) + [ + 1- [ 3 + ] map + [ '[ [ , 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: -expansion ( n -- quot ) + [ + [ swap (array) ] % + [ \ 2dup , , [ swap set-array-nth ] % ] each + \ nip , + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 32 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- node ) + first-literal -expansion ; + +: bytes>cells ( m -- n ) cell align cell /i ; + +MEMO: -expansion ( n -- quot ) + [ + [ (byte-array) ] % + bytes>cells [ cell * ] map + [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each + ] [ ] make splice-quot ; + +: expand-? ( #call -- ? ) + dup word>> \ eq? [ + first-literal dup integer? + [ 0 128 between? ] [ drop f ] if + ] [ drop f ] if ; + +: expand- ( #call -- nodes ) + first-literal -expansion ; + M: #call finalize* - dup word>> builtin-predicate? [ - word>> def>> splice-quot - ] when ; + { + { [ dup builtin-predicate? ] [ expand-builtin-predicate ] } + { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] } + { [ dup expand-? ] [ expand- ] } + { [ dup expand-? ] [ expand- ] } + [ ] + } cond ; M: node finalize* ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 4d3d2c781c..d31de354d1 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/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) } [ [ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if [ clear ] dip diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 97b4e2aee2..6fc0e76310 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/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 diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor index 191baf1e0a..4b026a9af0 100755 --- a/basis/cpu/ppc/intrinsics/intrinsics.factor +++ b/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 -compiler.generator.registers compiler.generator.fixup +hashtables hashtables.private sequences.private sbufs vectors system layouts -math.floats.private classes slots.private combinators -compiler.constants ; +math.floats.private classes slots.private +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 "layout" get size>> 2 + cells %allot -! ! Store layout -! "layout" get 12 load-indirect -! 12 11 cell STW -! ! Store tagged ptr in reg -! "tuple" get tuple %store-tagged -! ] H{ -! { +input+ { { [ ] "layout" } } } -! { +scratch+ { { f "tuple" } } } -! { +output+ { "tuple" } } -! } define-intrinsic -! -! \ (array) [ -! array "n" get 2 + cells %allot -! ! Store length -! "n" operand 12 LI -! 12 11 cell STW -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] H{ -! { +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 tagged ptr in reg -! "array" get object %store-tagged -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic +\ (tuple) [ + tuple "layout" get size>> 2 + cells %allot + ! Store layout + "layout" get 12 load-indirect + 12 11 cell STW + ! Store tagged ptr in reg + "tuple" get tuple %store-tagged +] H{ + { +input+ { { [ ] "layout" } } } + { +scratch+ { { f "tuple" } } } + { +output+ { "tuple" } } +} define-intrinsic + +\ (array) [ + array "n" get 2 + cells %allot + ! Store length + "n" operand 12 LI + 12 11 cell STW + ! Store tagged ptr in reg + "array" get object %store-tagged +] H{ + { +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 tagged ptr in reg + "array" get object %store-tagged +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic \ [ ratio 3 cells %allot diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor index 536b914f39..a0cfd1b01e 100755 --- a/basis/cpu/x86/intrinsics/intrinsics.factor +++ b/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 -compiler.generator.fixup sequences.private sbufs sbufs.private +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 "layout" get size>> 2 + cells [ -! ! Store layout -! "layout" get "scratch" get load-literal -! 1 object@ "scratch" operand MOV -! ! Store tagged ptr in reg -! "tuple" get tuple %store-tagged -! ] %allot -! ] H{ -! { +input+ { { [ ] "layout" } } } -! { +scratch+ { { f "tuple" } { f "scratch" } } } -! { +output+ { "tuple" } } -! } define-intrinsic -! -! \ (array) [ -! array "n" get 2 + cells [ -! ! Store length -! 1 object@ "n" operand MOV -! ! Store tagged ptr in reg -! "array" get object %store-tagged -! ] %allot -! ] H{ -! { +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 tagged ptr in reg -! "array" get object %store-tagged -! ] %allot -! ] H{ -! { +input+ { { [ ] "n" } } } -! { +scratch+ { { f "array" } } } -! { +output+ { "array" } } -! } define-intrinsic +\ (tuple) [ + tuple "layout" get size>> 2 + cells [ + ! Store layout + "layout" get "scratch" get load-literal + 1 object@ "scratch" operand MOV + ! Store tagged ptr in reg + "tuple" get tuple %store-tagged + ] %allot +] H{ + { +input+ { { [ ] "layout" } } } + { +scratch+ { { f "tuple" } { f "scratch" } } } + { +output+ { "tuple" } } +} define-intrinsic + +\ (array) [ + array "n" get 2 + cells [ + ! Store length + 1 object@ "n" operand MOV + ! Store tagged ptr in reg + "array" get object %store-tagged + ] %allot +] H{ + { +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 tagged ptr in reg + "array" get object %store-tagged + ] %allot +] H{ + { +input+ { { [ ] "n" } } } + { +scratch+ { { f "array" } } } + { +output+ { "array" } } +} define-intrinsic \ [ ratio 3 cells [