steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing remaining issues

db4
Slava Pestov 2008-08-22 17:38:23 -05:00
parent 9aa6d8ae04
commit 2440fc1ceb
26 changed files with 721 additions and 340 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/compiler/generator/generator.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays assocs classes combinators
cpu.architecture effects generic hashtables io kernel
kernel.private layouts math math.parser namespaces prettyprint
quotations sequences system threads words vectors sets dequeues
cursors continuations.private summary alien alien.c-types
continuations.private summary alien alien.c-types
alien.structs alien.strings alien.arrays libc compiler.errors
stack-checker.inlining
compiler.tree compiler.tree.builder compiler.tree.combinators
@ -60,7 +60,6 @@ SYMBOL: current-label-start
GENERIC: generate-node ( node -- next )
: generate-nodes ( nodes -- )
<sequence-cursor>
[ current-node generate-node ] iterate-nodes
end-basic-block ;
@ -216,20 +215,17 @@ M: #dispatch generate-node
2array 1array define-if-intrinsics ;
: do-if-intrinsic ( pair -- next )
<label> [
swap do-template
node> next dup >node
] keep generate-if ;
<label> [ swap do-template skip-next ] keep generate-if ;
: find-intrinsic ( #call -- pair/f )
intrinsics find-template ;
: find-if-intrinsic ( #call -- pair/f )
node@ next #if? [
if-intrinsics find-template
] [
drop f
] if ;
node@ {
{ [ dup length 2 < ] [ 2drop f ] }
{ [ dup second #if? ] [ drop if-intrinsics find-template ] }
[ 2drop f ]
} cond ;
M: #call generate-node
dup node-input-infos [ class>> ] map set-operand-classes

26
basis/compiler/generator/iterator/iterator.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences cursors kernel compiler.tree ;
USING: namespaces sequences kernel compiler.tree ;
IN: compiler.generator.iterator
SYMBOL: node-stack
@ -8,15 +8,15 @@ SYMBOL: node-stack
: >node ( cursor -- ) node-stack get push ;
: node> ( -- cursor ) node-stack get pop ;
: node@ ( -- cursor ) node-stack get peek ;
: current-node ( -- node ) node@ value ;
: iterate-next ( -- cursor ) node@ next ;
: current-node ( -- node ) node@ first ;
: iterate-next ( -- cursor ) node@ rest-slice ;
: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
: iterate-nodes ( cursor quot: ( -- ) -- )
over [
[ swap >node call node> drop ] keep iterate-nodes
] [
over empty? [
2drop
] [
[ swap >node call node> drop ] keep iterate-nodes
] if ; inline recursive
: with-node-iterator ( quot -- )
@ -25,21 +25,21 @@ SYMBOL: node-stack
DEFER: (tail-call?)
: tail-phi? ( cursor -- ? )
[ value #phi? ] [ next (tail-call?) ] bi and ;
[ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
: (tail-call?) ( cursor -- ? )
dup [
[ value [ #return? ] [ #terminate? ] bi or ]
dup empty? [ drop t ] [
[ first [ #return? ] [ #terminate? ] bi or ]
[ tail-phi? ]
bi or
] [ drop t ] if ;
] if ;
: tail-call? ( -- ? )
node-stack get [
next
rest-slice
dup [
[ (tail-call?) ]
[ value #terminate? not ]
[ first #terminate? not ]
bi and
] [ drop t ] if
] all? ;

8
basis/compiler/tests/alien.factor
View File

@ -1,9 +1,9 @@
IN: compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads
tools.test math ;
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test

358
basis/compiler/tests/optimizer.factor Executable file
View File

@ -0,0 +1,358 @@
USING: accessors arrays compiler.units generic hashtables
stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints
compiler.tree.builder compiler.tree.optimizer ;
IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled>> ] unit-test
! Test predicate inlining
: pred-test-1
dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if
] [
"not a fixnum"
] if ;
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
TUPLE: pred-test ;
: pred-test-2
dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3
dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if
] [
"not a tuple"
] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test
"nom" = ;
[ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test
! regression
: literal-not-branch 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test
! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test
! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test
! regression
: (double-recursion) ( start end -- )
< [
6 1 (double-recursion)
3 2 (double-recursion)
] when ; inline
: double-recursion ( -- ) 0 2 (double-recursion) ;
[ ] [ double-recursion ] unit-test
! regression
: double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled>> ] unit-test
[ breakage ] must-fail
! regression
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression
: constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression
: foo f ;
: bar ( -- ? ) foo 4 4 = and ;
[ f ] [ bar ] unit-test
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
M: integer foozul ;
M: slice foozul ;
[ t ] [
reversed \ foozul specific-method
reversed \ foozul method
eq?
] unit-test
! regression
: constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable
[ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test
: constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable
[ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj )
M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression
USE: sorting
USE: binary-search
USE: binary-search.private
: old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [
slice-from
] [
[ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ]
[ dup midpoint@ cut-slice old-binsearch ] if
] if ; inline
[ 10 ] [
10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
! Regression
TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 }
[
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-call
] unit-test
! Regression
: empty-compound ;
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
[ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
! Regression
: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
dup string? [ "a string" ] [
"error" throw
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- )
over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1
] [
over 0 < [
2drop
] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1
] if
] if ; inline
: lift-loop-tail-test-2
10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Forgot a recursive inline check
: recursive-inline-hang ( a -- a )
dup array? [ recursive-inline-hang ] when ;
HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
DEFER: recursive-inline-hang-3
: recursive-inline-hang-2 ( a -- a )
dup array? [ recursive-inline-hang-3 ] when ;
HINTS: recursive-inline-hang-2 array ;
: recursive-inline-hang-3 ( a -- a )
dup array? [ recursive-inline-hang-2 ] when ;
HINTS: recursive-inline-hang-3 array ;
! Regression
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test
! Wow
: counter-example ( a b c d -- a' b' c' d' )
dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
: counter-example' ( -- a' b' c' d' )
1 2 3.0 3 counter-example ;
[ 2 4 6.0 0 ] [ counter-example' ] unit-test
: member-test ( obj -- ? ) { + - * / /i } member? ;
\ member-test must-infer
[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
! Infinite expansion
TUPLE: cons car cdr ;
UNION: improper-list cons POSTPONE: f ;
PREDICATE: list < improper-list
[ cdr>> list instance? ] [ t ] if* ;
[ t ] [
T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
[ list instance? ] compile-call
] unit-test
! Regression
: interval-inference-bug ( obj -- obj x )
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
\ interval-inference-bug must-infer
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
[ 1 4 ] [ 1 interval-inference-bug ] unit-test
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
: aggressive-flush-regression ( a -- b )
f over >r <array> drop r> 1 + ;
[ 1.0 aggressive-flush-regression drop ] must-fail
[ 1 [ "hi" + drop ] compile-call ] must-fail
[ "hi" f [ <array> drop ] compile-call ] must-fail
TUPLE: some-tuple x ;
: allot-regression ( a -- b )
[ ] curry some-tuple boa ;
[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test

11
basis/compiler/tests/redefine1.factor
View File

@ -1,7 +1,7 @@
IN: compiler.tests
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
IN: compiler.tests
GENERIC: method-redefine-test ( a -- b )
@ -31,15 +31,6 @@ M: integer method-redefine-test 3 + ;
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled>> ] unit-test
! Just changing the stack effect didn't mark a word for recompilation
DEFER: change-effect
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
{ 1 1 } [ change-effect ] must-infer-as
[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
{ 1 0 } [ change-effect ] must-infer-as
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;

2
basis/compiler/tests/simple.factor
View File

@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
] unit-test
] times

26
basis/compiler/tree/builder/builder-docs.factor
View File

@ -2,26 +2,6 @@ USING: help.markup help.syntax sequences quotations words
compiler.tree stack-checker.errors ;
IN: compiler.tree.builder
ARTICLE: "specializers" "Word specializers"
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
$nl
"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
$nl
"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
$nl
"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code
"\\ append"
"{ { string string } { array array } }"
"\"specializer\" set-word-prop"
}
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
HELP: build-tree
{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
{ $description "Attempts to construct tree SSA IR from a quotation." }
@ -30,9 +10,5 @@ HELP: build-tree
HELP: build-tree-with
{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values, and outputting stack resulting at the end." }
{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: specialized-def
{ $values { "word" word } { "quot" quotation } }
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

51
basis/compiler/tree/builder/builder.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces assocs
words generic generic.standard generic.standard.engines arrays
kernel.private combinators vectors stack-checker
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
@ -29,49 +28,6 @@ IN: compiler.tree.builder
[ rot #copy suffix ]
if ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
[ drop ]
} cond ;
: (build-tree-from-word) ( word -- )
dup
[ "inline" word-prop ]
@ -99,6 +55,3 @@ IN: compiler.tree.builder
} cleave
] maybe-cannot-infer
] with-tree-builder ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

7
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -433,7 +433,7 @@ cell-bits 32 = [
] { >= fixnum>= } inlined?
] unit-test
[ ] [
[ t ] [
[
4 pick array-capacity?
[ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
@ -451,3 +451,8 @@ cell-bits 32 = [
if
] cleaned-up-tree drop
] unit-test
[ t ] [
[ [ 2array ] [ 0 3array ] if first ]
{ nth-unsafe < <= > >= } inlined?
] unit-test

10
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -3,7 +3,7 @@
USING: kernel accessors sequences sequences.deep combinators fry
classes.algebra namespaces assocs math math.private
math.partial-dispatch classes.tuple classes.tuple.private
stack-checker.branches
definitions stack-checker.state stack-checker.branches
compiler.tree
compiler.tree.intrinsics
compiler.tree.combinators
@ -42,14 +42,18 @@ GENERIC: cleanup* ( node -- node/nodes )
: cleanup-folding ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
[ word>> +inlined+ depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
]
[ in-d>> #drop ] bi prefix ;
[ in-d>> #drop ]
tri prefix ;
: cleanup-inlining ( #call -- nodes )
body>> cleanup ;
[ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
[ body>> cleanup ]
bi ;
! Removing overflow checks
: no-overflow-variant ( op -- fast-op )

11
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -5,7 +5,8 @@ compiler.tree.cleanup compiler.tree.escape-analysis
compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io
prettyprint words sequences.deep sequences.private ;
prettyprint words sequences.deep sequences.private arrays
classes kernel.private ;
IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
@ -173,3 +174,11 @@ IN: compiler.tree.dead-code.tests
[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
[ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
[ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test

23
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -1,13 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
fry locals compiler.tree stack-checker.backend
fry locals classes.algebra stack-checker.backend
compiler.tree
compiler.tree.propagation.info
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
: flushable? ( word -- ? )
[ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
"input-classes" word-prop dup [
[ node-input-infos ] dip
[ [ class>> ] dip class<= ] 2all?
] [ 2drop t ] if
] [ 2drop f ] if ;
M: #call mark-live-values*
dup word>> "flushable" word-prop
[ drop ] [ look-at-inputs ] if ;
dup flushable-call? [ drop ] [ look-at-inputs ] if ;
M: #alien-invoke mark-live-values* look-at-inputs ;
@ -80,8 +92,9 @@ M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
: dead-flushable-call? ( #call -- ? )
[ word>> "flushable" word-prop ]
[ out-d>> [ live-value? not ] all? ] bi and ;
dup flushable-call? [
out-d>> [ live-value? not ] all?
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
in-d>> #drop remove-dead-code* ;

24
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -143,10 +143,6 @@ IN: compiler.tree.propagation.tests
[ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ string } ] [
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
] unit-test
[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
@ -159,20 +155,12 @@ IN: compiler.tree.propagation.tests
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
[ V{ fixnum } ] [
@ -571,3 +559,15 @@ M: integer infinite-loop infinite-loop ;
: fold-throw-test ( a -- b ) "A" throw ; foldable
[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test

238
basis/compiler/tree/strength-reduction/strength-reduction-tests.factor
View File

@ -1,119 +1,119 @@
TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[ { declared-fixnum } declare [ 1 + ] change-x ]
{ + fixnum+ >fixnum } inlined?
] unit-test
[ t ] [
[ { declared-fixnum } declare x>> drop ]
{ slot } inlined?
] unit-test
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test
[ t ] [
[ dup hashtable eq? [ new ] when ] \ new inlined?
] unit-test
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ { integer } declare 127 bitand 3 + ]
{ + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
] unit-test
[ f ] [
[ { integer } declare 127 bitand 3 + ]
{ >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare
dup 0 >= [
615949 * 797807 + 20 2^ mod dup 19 2^ -
] [ dup ] if
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare
615949 * 797807 + 20 2^ mod dup 19 2^ -
] { >fixnum } inlined?
] unit-test
[ t ] [
[
{ integer } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ + inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
] unit-test
[ t ] [
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare 256 rem
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
! TUPLE: declared-fixnum { x fixnum } ;
!
! [ t ] [
! [ { declared-fixnum } declare [ 1 + ] change-x ]
! { + fixnum+ >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { declared-fixnum } declare x>> drop ]
! { slot } inlined?
! ] unit-test
!
! [ t ] [
! [ hashtable new ] \ new inlined?
! ] unit-test
!
! [ t ] [
! [ dup hashtable eq? [ new ] when ] \ new inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare -63 shift 4095 bitand ]
! \ shift inlined?
! ] unit-test
!
! [ t ] [
! [ { integer } declare 127 bitand 3 + ]
! { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
! ] unit-test
!
! [ f ] [
! [ { integer } declare 127 bitand 3 + ]
! { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare
! dup 0 >= [
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] [ dup ] if
! ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare
! 615949 * 797807 + 20 2^ mod dup 19 2^ -
! ] { >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
! ] unit-test
!
! [ t ] [
! [
! { fixnum } declare 0 swap
! [
! drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
! ] map
! ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
! ] unit-test
!
! [ t ] [
! [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
! ] unit-test
!
!
!
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
!
! [ f ] [
! [
! 256 mod
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ f ] [
! [
! dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare dup 0 >= [ 256 mod ] when
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare 256 rem
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 256 rem ] map
! ] { mod fixnum-mod rem } inlined?
! ] unit-test

15
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -4,7 +4,7 @@ IN: concurrency.mailboxes
USING: dlists dequeues threads sequences continuations
destructors namespaces random math quotations words kernel
arrays assocs init system concurrency.conditions accessors
debugger debugger.threads ;
debugger debugger.threads locals ;
TUPLE: mailbox threads data disposed ;
@ -23,13 +23,12 @@ M: mailbox dispose* threads>> notify-all ;
: wait-for-mailbox ( mailbox timeout -- )
>r threads>> r> "mailbox" wait ;
: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
pick check-disposed
pick data>> over dlist-contains? [
3drop
] [
>r 2dup wait-for-mailbox r> block-unless-pred
] if ; inline recursive
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox check-disposed
mailbox data>> pred dlist-contains? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred
] unless ; inline recursive
: block-if-empty ( mailbox timeout -- mailbox )
over check-disposed

8
basis/float-arrays/float-arrays.factor
View File

@ -47,16 +47,16 @@ M: float-array byte-length length "double" heap-size * ;
INSTANCE: float-array sequence
: 1float-array ( x -- array )
1 <float-array> [ set-first ] keep ; flushable
1 <float-array> [ set-first ] keep ; inline
: 2float-array ( x y -- array )
T{ float-array } 2sequence ; flushable
T{ float-array } 2sequence ; inline
: 3float-array ( x y z -- array )
T{ float-array } 3sequence ; flushable
T{ float-array } 3sequence ; inline
: 4float-array ( w x y z -- array )
T{ float-array } 4sequence ; flushable
T{ float-array } 4sequence ; inline
: F{ ( parsed -- parsed )
\ } [ >float-array ] parse-literal ; parsing

6
basis/help/lint/lint.factor
View File

@ -109,9 +109,9 @@ M: help-error error.
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
H{ } clone [
[
>r >r dup >link where dup
[ first r> at r> push-at ]
[ r> r> 2drop 2drop ]
[ dup >link where dup ] 2dip
[ first r> at r> push-at ] 2curry
[ 2drop ]
if
] 2curry each
] keep ;

29
basis/hints/hints-docs.factor Normal file
View File

@ -0,0 +1,29 @@
IN: hints
USING: help.markup help.syntax words ;
ARTICLE: "hints" "Compiler specialization hints"
"Specialization hints help the compiler generate efficient code."
$nl
"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
$nl
"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
$nl
"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
$nl
"Type hints are declared with a parsing word:"
{ $subsection POSTPONE: HINT: }
$nl
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
HELP: specialized-def
{ $values { "word" word } { "quot" quotation } }
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
{ $values { "word" word } { "hints..." "a list of sequences of classes" } }
{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
{ $code "HINTS: append { string string } { array array } ;" } } ;
ABOUT: "hints"

102
basis/hints/hints.factor
View File

@ -1,10 +1,110 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel ;
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math generic generic.standard generic.standard.engines ;
IN: hints
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
[ drop ]
} cond ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
: HINTS:
scan-word
[ +inlined+ changed-definition ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
! Default specializers
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
{ peek pop* pop push } [
{ vector } "specializer" set-word-prop
] each
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
\ append
{ { string string } { array array } }
"specializer" set-word-prop
\ subseq
{ { fixnum fixnum string } { fixnum fixnum array } }
"specializer" set-word-prop
\ reverse-here
{ { string } { array } }
"specializer" set-word-prop
\ mismatch
{ string string }
"specializer" set-word-prop
\ find-last-sep { string sbuf } "specializer" set-word-prop
\ >string { sbuf } "specializer" set-word-prop
\ >array { { string } { vector } } "specializer" set-word-prop
\ >vector { { array } { vector } } "specializer" set-word-prop
\ >sbuf { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop
\ memq? { array } "specializer" set-word-prop
\ member? { fixnum string } "specializer" set-word-prop
\ assoc-stack { vector } "specializer" set-word-prop
\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop

16
basis/math/ranges/ranges.factor
View File

@ -10,7 +10,7 @@ TUPLE: range
: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
range boa ;
range boa ; inline
M: range length ( seq -- n )
length>> ;
@ -26,19 +26,19 @@ INSTANCE: range immutable-sequence
: ,b) dup neg rot + swap ; inline
: [a,b] ( a b -- range ) twiddle <range> ; foldable
: [a,b] ( a b -- range ) twiddle <range> ; inline
: (a,b] ( a b -- range ) twiddle (a, <range> ; foldable
: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
: [a,b) ( a b -- range ) twiddle ,b) <range> ; foldable
: [a,b) ( a b -- range ) twiddle ,b) <range> ; inline
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; foldable
: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; inline
: [0,b] ( b -- range ) 0 swap [a,b] ; foldable
: [0,b] ( b -- range ) 0 swap [a,b] ; inline
: [1,b] ( b -- range ) 1 swap [a,b] ; foldable
: [1,b] ( b -- range ) 1 swap [a,b] ; inline
: [0,b) ( b -- range ) 0 swap [a,b) ; foldable
: [0,b) ( b -- range ) 0 swap [a,b) ; inline
: range-increasing? ( range -- ? )
step>> 0 > ;

4
basis/ui/freetype/freetype.factor
View File

@ -212,7 +212,7 @@ M: freetype-renderer draw-string ( font string loc -- )
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
M: freetype-renderer x>offset ( x open-font string -- n )
dup >r run-char-widths [ <= ] with find drop
[ r> drop ] [ r> length ] if* ;
[ run-char-widths [ <= ] with find drop ] keep swap
[ ] [ length ] ?if ;
T{ freetype-renderer } font-renderer set-global

8
core/arrays/arrays.factor
View File

@ -23,12 +23,12 @@ M: array equal?
INSTANCE: array sequence
: 1array ( x -- array ) 1 swap <array> ; flushable
: 1array ( x -- array ) 1 swap <array> ; inline
: 2array ( x y -- array ) { } 2sequence ; flushable
: 2array ( x y -- array ) { } 2sequence ; inline
: 3array ( x y z -- array ) { } 3sequence ; flushable
: 3array ( x y z -- array ) { } 3sequence ; inline
: 4array ( w x y z -- array ) { } 4sequence ; flushable
: 4array ( w x y z -- array ) { } 4sequence ; inline
PREDICATE: pair < array length 2 number= ;

2
core/classes/classes.factor
View File

@ -182,4 +182,4 @@ M: class forget* ( class -- )
GENERIC: class ( object -- class )
GENERIC: instance? ( object class -- ? )
GENERIC: instance? ( object class -- ? ) flushable

6
core/classes/tuple/tuple.factor
View File

@ -298,11 +298,9 @@ M: tuple-class (classes-intersect?)
[ swap classes-intersect? ]
} cond ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
M: tuple clone (clone) ;
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
M: tuple hashcode*
[

34
core/cursors/cursors.factor
View File

@ -1,34 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math accessors ;
IN: cursors
GENERIC: key ( cursor -- key )
GENERIC: value ( cursor -- value )
GENERIC: next ( cursor -- cursor/f )
TUPLE: sequence-cursor { i read-only } { seq read-only } ;
: (sequence-cursor) ( i seq -- cursor/f )
2dup bounds-check? [ sequence-cursor boa ] [ 2drop f ] if ;
inline
: <sequence-cursor> ( seq -- cursor/f )
0 swap (sequence-cursor) ; inline
: >sequence-cursor< ( cursor -- i seq ) [ i>> ] [ seq>> ] bi ;
M: sequence-cursor key
i>> ;
M: sequence-cursor value
>sequence-cursor< nth ;
M: sequence-cursor next
>sequence-cursor< [ 1+ ] dip (sequence-cursor) ;
: cursor-iterate ( cursor quot: ( cursor -- cursor' ) -- )
over [ call cursor-iterate ] [ 2drop ] if ; inline recursive
: cursor-each ( cursor quot -- )
[ keep ] curry cursor-iterate ; inline

18
core/generic/standard/standard.factor
View File

@ -21,27 +21,11 @@ M: generic method-declaration
M: quotation engine>quot
assumed get generic get method-declaration prepend ;
: unpickers
{
[ nip ]
[ >r nip r> swap ]
[ >r >r nip r> r> -rot ]
} ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over suffix ,
error-method \ drop prefix , \ if ,
] [ ] make ;
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
@ -137,7 +121,7 @@ PREDICATE: simple-generic < standard-generic
M: standard-generic extra-values drop 0 ;
M: standard-combination make-default-method
[ empty-method ] with-standard ;
[ error-method ] with-standard ;
M: standard-combination perform-combination
[ drop ] [ [ single-combination ] with-standard ] 2bi define ;