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

starting to update simplifier for vops

cvs
Slava Pestov 2005-05-09 06:34:15 +00:00
parent 6df17f0a7c
commit 4face990d7
20 changed files with 350 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.FACTOR.txt
View File

@ -25,11 +25,12 @@
- dipping seq-2nmap, seq-2each
- array sort
- tiled window manager
- PPC #box-float #unbox-float
- redo new compiler backend for PowerPC
- weird bug uncovered during bootstrap stress-test
- images saved from plugin do not work
- making an image from plugin hangs
- generic skip
- inference needs to be more robust with heavily recursive code
+ plugin:

5
library/alien/c-types.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler errors generic hashtables kernel lists
math namespaces parser sequences strings words ;
USING: assembler compiler compiler-backend errors generic
hashtables kernel lists math namespaces parser sequences strings
words ;
: <c-type> ( -- type )
<namespace> [

5
library/alien/compiler.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler errors generic inference kernel lists
math namespaces sequences stdio strings unparser words ;
USING: assembler compiler compiler-backend errors generic
inference kernel lists math namespaces sequences stdio strings
unparser words ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32

3
library/bootstrap/boot-stage3.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler io-internals kernel
lists namespaces parser sequences stdio unparser words ;
lists math namespaces parser sequences stdio unparser words ;
"Compiling base..." print
@ -31,6 +31,7 @@ init-assembler
compile? [
\ car compile
\ * compile
\ length compile
\ = compile
\ unparse compile

4
library/compiler/compiler.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2005 Slava Pestov.
IN: compiler
USING: errors inference kernel lists namespaces prettyprint
stdio words ;
USING: compiler-backend compiler-frontend errors inference
kernel lists namespaces prettyprint stdio words ;
: supported-cpu? ( -- ? )
cpu "unknown" = not ;

9
library/compiler/generator.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler errors inference kernel lists math namespaces
sequences strings vectors words ;
IN: compiler-backend
USING: assembler compiler errors inference kernel lists math
namespaces sequences strings vectors words ;
! Compile a VOP.
GENERIC: generate-node ( vop -- )
: generate-code ( word linear -- length )
compiled-offset >r

9
library/compiler/intrinsics.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler generic hashtables inference kernel
kernel-internals lists math math-internals namespaces sequences
words ;
IN: compiler-frontend
USING: assembler compiler-backend generic hashtables inference
kernel kernel-internals lists math math-internals namespaces
sequences words ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
@ -171,6 +171,7 @@ words ;
[[ fixnum< %fixnum< ]]
[[ fixnum>= %fixnum>= ]]
[[ fixnum> %fixnum> ]]
[[ eq? %eq? ]]
] [
uncons over intrinsic
[ literal, 0 , \ binary-op , ] make-list

16
library/compiler/linearizer.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: inference kernel lists math namespaces words strings
errors prettyprint kernel-internals ;
IN: compiler-frontend
USING: compiler-backend inference kernel lists math namespaces
words strings errors prettyprint kernel-internals ;
: >linear ( node -- )
#! Dataflow OPs have a linearizer word property. This
@ -21,12 +21,6 @@ errors prettyprint kernel-internals ;
#! rest is arguments.
[ %prologue , (linearize) ] make-list ;
: <label> ( -- label )
gensym dup t "label" set-word-prop ;
: label? ( obj -- ? )
dup word? [ "label" word-prop ] [ drop f ] ifte ;
: linearize-simple-label ( node -- )
#! Some labels become simple labels after the optimization
#! stage.
@ -46,7 +40,7 @@ errors prettyprint kernel-internals ;
#! not contain non-tail recursive calls to itself.
<label> dup %return-to , >r
linearize-simple-label
%return ,
f %return ,
r> %label , ;
#label [
@ -105,4 +99,4 @@ errors prettyprint kernel-internals ;
#values [ drop ] "linearizer" set-word-prop
#return [ drop %return , ] "linearizer" set-word-prop
#return [ drop f %return , ] "linearizer" set-word-prop

2
library/compiler/optimizer.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
IN: compiler-frontend
USING: inference kernel kernel-internals lists namespaces
sequences vectors words words ;

346
library/compiler/simplifier.factor
View File

@ -1,141 +1,217 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: inference kernel lists math namespaces prettyprint
strings words ;
IN: compiler-backend
USING: generic inference kernel lists math namespaces
prettyprint strings words ;
: simplify ;
! A peephole optimizer operating on the linear IR.
! The linear IR being simplified is stored in this variable.
! SYMBOL: simplifying
!
! : simplifiers ( linear -- list )
! #! A list of quotations with stack effect
! #! ( linear -- linear ? ) that can simplify the first node
! #! in the linear IR.
! car car "simplifiers" word-prop ;
!
! : simplify-node ( linear list -- linear ? )
! dup [
! uncons >r call [
! r> drop t
! ] [
! r> simplify-node
! ] ifte
! ] when ;
!
! : simplify-1 ( linear -- linear ? )
! #! Return a new linear IR.
! dup [
! dup simplifiers simplify-node
! [ uncons simplify-1 drop cons t ]
! [ uncons simplify-1 >r cons r> ] ifte
! ] [
! f
! ] ifte ;
!
! : simplify ( linear -- linear )
! #! Keep simplifying until simplify-1 returns f.
! [
! dup simplifying set simplify-1
! ] with-scope [ simplify ] when ;
!
! : label-called? ( label linear -- ? )
! [ uncons pick = swap #label = not and ] some? nip ;
!
! #label [
! [
! dup car cdr simplifying get label-called?
! [ f ] [ cdr t ] ifte
! ]
! ] "simplifiers" set-word-prop
!
! : next-physical? ( op linear -- ? )
! cdr dup [ car car = ] [ 2drop f ] ifte ;
!
! : cancel ( linear op -- linear param ? )
! #! If the following op is as given, remove it, and return
! #! its param.
! over next-physical? [ cdr unswons cdr t ] [ f f ] ifte ;
!
! \ drop [
! [
! #push-immediate cancel [
! #replace-immediate swons swons t
! ] when
! ] [
! #push-indirect cancel [
! #replace-indirect swons swons t
! ] when
! ]
! ] "simplifiers" set-word-prop
!
! : find-label ( label -- rest )
! simplifying get [
! uncons pick = swap #label = and
! ] some? nip ;
!
! : next-logical ( linear -- linear )
! dup car car "next-logical" word-prop call ;
!
! #label [
! cdr next-logical
! ] "next-logical" set-word-prop
!
! #jump-label [
! car cdr find-label cdr
! ] "next-logical" set-word-prop
!
! #target-label [
! car cdr find-label cdr
! ] "next-logical" set-word-prop
!
! : next-logical? ( op linear -- ? )
! next-logical dup [ car car = ] [ 2drop f ] ifte ;
!
! : reduce ( linear op new -- linear ? )
! >r over cdr next-logical? [
! unswons cdr r> swons swons t
! ] [
! r> drop f
! ] ifte ;
!
! #call [
! [ #return #jump reduce ]
! ] "simplifiers" set-word-prop
!
! #call-label [
! [ #return #jump-label reduce ]
! ] "simplifiers" set-word-prop
!
! : double-jump ( linear op1 op2 -- linear ? )
! #! A jump to a jump is just a jump. If the next logical node
! #! is a jump of type op1, replace the jump at the car of the
! #! list with a jump of type op2.
! swap pick next-logical? [
! over next-logical car cdr cons swap cdr cons t
! ] [
! drop f
! ] ifte ;
!
! : useless-jump ( linear -- linear ? )
! #! A jump to a label immediately following is not needed.
! dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
!
! : (dead-code) ( linear -- linear ? )
! #! Remove all nodes until the next #label.
! dup [
! dup car car #label = [
! f
! ] [
! cdr (dead-code) t or
! ] ifte
! ] [
! f
! ] ifte ;
!
! : dead-code ( linear -- linear ? )
! uncons (dead-code) >r cons r> ;
SYMBOL: simplifying
GENERIC: simplify-node ( linear vop -- linear ? )
! The next node following this node in terms of control flow, or
! f if this is a conditional.
GENERIC: next-logical ( linear vop -- linear )
! No delegation.
M: tuple simplify-node drop f ;
: simplify-1 ( list -- list ? )
#! Return a new linear IR.
dup [
dup car simplify-node
[ uncons simplify-1 drop cons t ]
[ uncons simplify-1 >r cons r> ] ifte
] [
f
] ifte ;
: simplify ( linear -- linear )
#! Keep simplifying until simplify-1 returns f.
[
dup simplifying set simplify-1
] with-scope [ simplify ] when ;
: label-called? ( label -- ? )
simplifying get [ calls-label? ] some-with? ;
M: %label simplify-node ( linear vop -- linear ? )
vop-label label-called? [ f ] [ cdr t ] ifte ;
: next-physical? ( linear class -- vop ? )
#! If the following op has given class, remove it and
#! return it.
over cdr dup [
car class = [ cdr car t ] [ f ] ifte
] [
3drop f f
] ifte ;
M: %inc-d simplify-node ( linear vop -- linear ? )
#! %inc-d cancels a following %inc-d.
>r dup \ %inc-d next-physical? [
vop-literal r> vop-literal + dup 0 = [
drop cdr cdr f
] [
%inc-d >r cdr cdr r> swons t
] ifte
] [
r> 2drop f
] ifte ;
: dead-load? ( linear vop -- ? )
#! Is the %replace-d followed by a %peek-d of the same
#! stack slot and vreg?
swap cdr car dup %peek-d? [
over vop-source over vop-dest = >r
swap vop-literal swap vop-literal = r> and
] [
2drop f
] ifte ;
: dead-store? ( linear n -- ? )
#! Is the %replace-d followed by a %dec-d, so the stored
#! value is lost?
swap \ %inc-d next-physical? [
vop-literal + 0 <
] [
2drop f
] ifte ;
M: %replace-d simplify-node ( linear vop -- linear ? )
2dup dead-load? [
drop uncons cdr cons t
] [
2dup vop-literal dead-store? [
drop cdr t
] [
drop f
] ifte
] ifte ;
M: %immediate-d simplify-node ( linear vop -- linear ? )
over 0 dead-store? [ drop cdr t ] [ drop f ] ifte ;
: pop? ( vop -- ? ) dup %inc-d? swap vop-literal -1 = and ;
: can-fast-branch? ( linear -- ? )
unswons class fast-branch [
unswons pop? [ car %jump-t? ] [ drop f ] ifte
] [
drop f
] ifte ;
: fast-branch-params ( linear -- src dest label linear )
uncons >r dup vop-source swap vop-dest r> cdr
uncons >r vop-label r> ;
M: %fixnum<= simplify-node ( linear vop -- linear ? )
drop dup can-fast-branch? [
fast-branch-params >r
%jump-fixnum<= >r -1 %inc-d r>
r> cons cons t
] [
f
] ifte ;
M: %eq? simplify-node ( linear vop -- linear ? )
drop dup can-fast-branch? [
fast-branch-params >r
%jump-eq? >r -1 %inc-d r>
r> cons cons t
] [
f
] ifte ;
: find-label ( label -- rest )
simplifying get [
dup %label? [ vop-label = ] [ 2drop f ] ifte
] some-with? ;
M: %label next-logical ( linear vop -- linear )
drop cdr dup car next-logical ;
M: %jump-label next-logical ( linear vop -- linear )
nip vop-label find-label cdr ;
M: %target-label next-logical ( linear vop -- linear )
nip vop-label find-label cdr ;
M: object next-logical ( linear vop -- linear )
drop ;
: next-logical? ( op linear -- ? )
dup car next-logical dup [ car class = ] [ 2drop f ] ifte ;
: reduce ( linear op new -- linear ? )
>r over cdr next-logical? [
dup car vop-label
r> execute swap cdr cons t
] [
r> drop f
] ifte ; inline
M: %call simplify-node ( linear vop -- ? )
#! Tail call optimization.
drop \ %return \ %jump reduce ;
M: %call-label simplify-node ( linear vop -- ? )
#! Tail call optimization.
drop \ %return \ %jump-label reduce ;
: double-jump ( linear op2 op1 -- linear ? )
#! A jump to a jump is just a jump. If the next logical node
#! is a jump of type op1, replace the jump at the car of the
#! list with a jump of type op2.
pick next-logical? [
>r dup dup car next-logical car vop-label
r> execute swap cdr cons t
] [
drop f
] ifte ; inline
: useless-jump ( linear -- linear ? )
#! A jump to a label immediately following is not needed.
dup car cdr find-label over cdr eq? [ cdr t ] [ f ] ifte ;
: (dead-code) ( linear -- linear ? )
#! Remove all nodes until the next #label.
dup [
dup car %label? [
f
] [
cdr (dead-code) t or
] ifte
] [
f
] ifte ;
: dead-code ( linear -- linear ? )
uncons (dead-code) >r cons r> ;
M: %jump-label simplify-node ( linear vop -- ? )
drop
\ %return dup double-jump [
t
] [
\ %jump-label dup double-jump [
t
] [
\ %jump dup double-jump
! [
! t
! ] [
! useless-jump [
! t
! ] [
! dead-code
! ] ifte
! ] ifte
] ifte
] ifte ;
!
! #jump-label [
! [ #return #return double-jump ]
@ -146,8 +222,8 @@ strings words ;
! ] "simplifiers" set-word-prop
!
! #target-label [
! [ #jump-label #target-label double-jump ]
! ! [ #jump #target double-jump ]
! [ #target-label #jump-label double-jump ]
! ! [ #target #jump double-jump ]
! ] "simplifiers" set-word-prop
!
! #jump [ [ dead-code ] ] "simplifiers" set-word-prop

50
library/compiler/vops.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: errors generic kernel namespaces parser ;
IN: compiler-backend
USING: errors generic hashtables kernel math namespaces parser
words ;
! The linear IR is the second of the two intermediate
! representations used by Factor. It is basically a high-level
@ -10,14 +11,22 @@ USING: errors generic kernel namespaces parser ;
! This file defines all the types of VOPs. A linear IR program
! is then just a list of VOPs.
: <label> ( -- label )
#! Make a label.
gensym dup t "label" set-word-prop ;
: label? ( obj -- ? )
dup word? [ "label" word-prop ] [ drop f ] ifte ;
! A virtual register
TUPLE: vreg n ;
! A virtual operation
TUPLE: vop source dest literal label ;
! Compile a VOP.
GENERIC: generate-node ( vop -- )
GENERIC: calls-label? ( label vop -- ? )
M: vop calls-label? vop-label = ;
: make-vop ( source dest literal label vop -- vop )
[ >r <vop> r> set-delegate ] keep ;
@ -40,8 +49,14 @@ VOP: %prologue
: %prologue empty-vop <%prologue> ;
VOP: %label
: %label label-vop <%label> ;
M: %label calls-label? 2drop f ;
! Return vops take a label that is ignored, to have the
! same stack effect as jumps. This is needed for the
! simplifier.
VOP: %return
: %return empty-vop <%return> ;
: %return ( label) label-vop <%return> ;
VOP: %return-to
: %return-to label-vop <%return-to> ;
VOP: %jump
@ -70,23 +85,23 @@ VOP: %end-dispatch
! stack operations
VOP: %peek-d
: %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
VOP: %dec-d
: %dec-d ( n -- ) literal-vop <%dec-d> ;
VOP: %replace-d
: %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
VOP: %inc-d
: %inc-d ( n -- ) literal-vop <%inc-d> ;
: %dec-d ( n -- ) neg %inc-d ;
VOP: %immediate
VOP: %immediate-d
: %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
VOP: %peek-r
: %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
VOP: %dec-r
: %dec-r ( n -- ) literal-vop <%dec-r> ;
VOP: %replace-r
: %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
VOP: %inc-r
: %inc-r ( n -- ) literal-vop <%inc-r> ;
! this exists, unlike %dec-d which does not, due to x86 quirks
VOP: %dec-r
: %dec-r ( n -- ) literal-vop <%dec-r> ;
: in-1 0 0 %peek-d , ;
: in-2 0 1 %peek-d , 1 0 %peek-d , ;
@ -128,13 +143,28 @@ VOP: %fixnum-bitor : %fixnum-bitor src/dest-vop <%fixnum-bitor> ;
VOP: %fixnum-bitxor : %fixnum-bitxor src/dest-vop <%fixnum-bitxor> ;
VOP: %fixnum-bitnot : %fixnum-bitnot <vreg> dest-vop <%fixnum-bitnot> ;
VOP: %fixnum-shift : %fixnum-shift src/dest-vop <%fixnum-shift> ;
VOP: %fixnum<= : %fixnum<= src/dest-vop <%fixnum<=> ;
VOP: %fixnum< : %fixnum< src/dest-vop <%fixnum<> ;
VOP: %fixnum>= : %fixnum>= src/dest-vop <%fixnum>=> ;
VOP: %fixnum> : %fixnum> src/dest-vop <%fixnum>> ;
VOP: %eq? : %eq? src/dest-vop <%eq?> ;
VOP: %jump-fixnum<= : %jump-fixnum<= f swap <%jump-fixnum<=> ;
VOP: %jump-fixnum< : %jump-fixnum< f swap <%jump-fixnum<> ;
VOP: %jump-fixnum>= : %jump-fixnum>= f swap <%jump-fixnum>=> ;
VOP: %jump-fixnum> : %jump-fixnum> f swap <%jump-fixnum>> ;
VOP: %jump-eq? : %jump-eq? f swap <%jump-eq?> ;
: fast-branch ( class -- class )
{{
[[ %fixnum<= %jump-fixnum<= ]]
[[ %fixnum< %jump-fixnum< ]]
[[ %fixnum>= %jump-fixnum>= ]]
[[ %fixnum> %jump-fixnum> ]]
[[ %eq? %jump-eq? ]]
}} hash ;
! some slightly optimized inline assembly
VOP: %type
: %type ( vreg ) <vreg> dest-vop <%type> ;

2
library/compiler/x86/alien.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
IN: compiler-backend
USING: alien assembler inference kernel kernel-internals lists
math memory namespaces words ;

25
library/compiler/x86/fixnum.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: assembler errors kernel math math-internals memory
namespaces words ;
IN: compiler-backend
USING: assembler compiler errors kernel math math-internals
memory namespaces words ;
: simple-overflow ( dest -- )
#! If the previous arithmetic operation overflowed, then we
@ -130,3 +130,22 @@ M: %fixnum>= generate-node ( vop -- )
M: %eq? generate-node ( vop -- )
fixnum-compare \ JE conditional ;
: fixnum-branch ( vop -- label )
dup vop-dest v>operand over vop-source v>operand CMP
vop-label ;
M: %jump-fixnum< generate-node ( vop -- )
fixnum-branch JL ;
M: %jump-fixnum<= generate-node ( vop -- )
fixnum-branch JLE ;
M: %jump-fixnum> generate-node ( vop -- )
fixnum-branch JG ;
M: %jump-fixnum>= generate-node ( vop -- )
fixnum-branch JGE ;
M: %jump-eq? generate-node ( vop -- )
fixnum-branch JE ;

6
library/compiler/x86/generator.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: alien assembler inference kernel kernel-internals lists
math memory namespaces sequences words ;
IN: compiler-backend
USING: alien assembler compiler inference kernel
kernel-internals lists math memory namespaces sequences words ;
GENERIC: v>operand
M: integer v>operand address ;

12
library/compiler/x86/stack.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: compiler
USING: alien assembler inference kernel lists math memory
sequences words ;
IN: compiler-backend
USING: alien assembler compiler inference kernel lists math
memory sequences words ;
: rel-cs ( -- )
#! Add an entry to the relocation table for the 32-bit
@ -20,14 +20,12 @@ sequences words ;
M: %peek-d generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal ds-op MOV ;
M: %dec-d generate-node ( vop -- )
vop-literal ESI swap cell * SUB ;
M: %replace-d generate-node ( vop -- )
dup vop-source v>operand swap vop-literal ds-op swap MOV ;
M: %inc-d generate-node ( vop -- )
vop-literal ESI swap cell * ADD ;
ESI swap vop-literal cell *
dup 0 > [ ADD ] [ neg SUB ] ifte ;
M: %immediate generate-node ( vop -- )
dup vop-dest v>operand swap vop-literal address MOV ;

5
library/generic/tuple.factor
View File

@ -68,8 +68,9 @@ UNION: arrayed array tuple ;
: tuple-predicate ( word -- )
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word swap [ swap class eq? ] cons
define-compound ;
dup predicate-word swap [
literal, [ swap class eq? ] %
] make-list define-compound ;
: check-shape ( word slots -- )
#! If the new list of slots is different from the previous,

14
library/inference/words.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: errors generic interpreter kernel lists math namespaces
sequences strings vectors words hashtables parser prettyprint ;
USING: errors generic interpreter kernel lists math
math-internals namespaces sequences strings vectors words
hashtables parser prettyprint ;
: with-dataflow ( param op [[ in# out# ]] quot -- )
#! Take input parameters, execute quotation, take output
@ -170,8 +171,17 @@ M: word apply-object ( word -- )
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
\ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
\ <= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ < [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ >= [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ > [ [ number number ] [ boolean ] ] "infer-effect" set-word-prop
\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
\ no-method t "terminator" set-word-prop
\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop

16
library/test/benchmark/fib.factor
View File

@ -20,3 +20,19 @@ USE: math-internals
compiled
[ 9227465 ] [ 34 fib ] unit-test
TUPLE: box i ;
: tuple-fib ( n -- n )
dup box-i 1 <= [
drop 1 <box>
] [
box-i 1 - <box>
dup tuple-fib
swap
box-i 1 - <box>
tuple-fib
swap box-i swap box-i + <box>
] ifte ; compiled
[ << box f 9227465 ] [ << box f 34 >> tuple-fib ] unit-test

3
library/test/compiler/intrinsics.factor
View File

@ -32,6 +32,9 @@ math-internals test words ;
[ 1 1 2 ] [ [ 1 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 [ 2 dupd ] compile-1 ] unit-test
[ 1 1 2 ] [ 1 2 [ dupd ] compile-1 ] unit-test
[ 2 ] [ [ 1 2 nip ] compile-1 ] unit-test
[ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
[ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
[ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test

5
library/test/tuple.factor
View File

@ -51,3 +51,8 @@ C: quuux-tuple-2
point-x
] unit-test
TUPLE: predicate-test ;
: predicate-test drop f ;
[ t ] [ <predicate-test> predicate-test? ] unit-test