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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-04-20 17:28:50 -03:00
parent 1135f4bd5e c564481cc5
commit 915e65fa7f
137 changed files with 3269 additions and 948 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
core/alien/compiler/compiler-tests.factor
View File

@ -3,7 +3,7 @@ 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 ;
tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -280,6 +280,10 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
@ -354,3 +358,14 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

1
core/alien/compiler/compiler.factor
View File

@ -403,7 +403,6 @@ TUPLE: callback-context ;
: generate-callback ( node -- )
dup xt>> dup [
init-templates
%save-word-xt
%prologue-later
dup alien-stack-frame [
dup registers>objects

51
core/bootstrap/primitives.factor
View File

@ -58,16 +58,13 @@ num-types get f <array> builtins set
"alien.accessors"
"arrays"
"bit-arrays"
"bit-vectors"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
"float-vectors"
"generator"
"growable"
"hashtables"
@ -455,54 +452,6 @@ tuple
}
} define-tuple-class
"byte-vector" "byte-vectors" create
tuple
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"bit-vector" "bit-vectors" create
tuple
{
{
{ "bit-array" "bit-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"float-vector" "float-vectors" create
tuple
{
{
{ "float-array" "float-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create
tuple
{

4
core/bootstrap/stage2.factor
View File

@ -27,10 +27,6 @@ SYMBOL: bootstrap-time
diff
[ "bootstrap." prepend require ] each ;
! : compile-remaining ( -- )
! "Compiling remaining words..." print flush
! vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;

3
core/bootstrap/syntax.factor
View File

@ -14,16 +14,13 @@ IN: bootstrap.syntax
";"
"<PRIVATE"
"?{"
"?V{"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
"FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"

44
core/classes/algebra/algebra-tests.factor
View File

@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private ;
random inference effects kernel.private sbufs ;
: class= [ class< ] 2keep swap class< and ;
@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
[ f ] [ null class-not null class= ] unit-test
[ t ] [
fixnum class-not
fixnum fixnum class-not class-or
class<
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
[ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs?
: random-class classes random ;

7
core/classes/algebra/algebra.factor
View File

@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
@ -193,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
over [ classes-intersect? ] curry subset
dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;

10
core/compiler/tests/simple.factor
View File

@ -1,6 +1,6 @@
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
alien arrays memory vocabs parser ;
IN: compiler.tests
! Test empty word
@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
! Regression
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
] unit-test
] times

11
core/compiler/tests/templates.factor
View File

@ -3,7 +3,7 @@ USING: arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ;
words definitions compiler.units io combinators vectors ;
IN: compiler.tests
! Oops!
@ -246,3 +246,12 @@ TUPLE: my-tuple ;
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

5
core/cpu/architecture/architecture.factor
View File

@ -56,7 +56,7 @@ HOOK: %call cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t cpu ( label -- )
HOOK: %jump-f cpu ( label -- )
HOOK: %dispatch cpu ( -- )
@ -187,6 +187,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )

17
core/cpu/ppc/allot/allot.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
@ -7,7 +7,7 @@ cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
"nursery" f pick %load-dlsym dup 0 LWZ ;
>r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
@ -25,6 +25,19 @@ IN: cpu.ppc.allot
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot

4
core/cpu/ppc/architecture/architecture.factor
View File

@ -106,8 +106,8 @@ M: ppc %call ( label -- ) BL ;
M: ppc %jump-label ( label -- ) B ;
M: ppc %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
M: ppc %jump-f ( label -- )
0 "flag" operand f v>operand CMPI BEQ ;
M: ppc %dispatch ( -- )
[

20
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -217,11 +217,11 @@ IN: cpu.ppc.intrinsics
2array define-if-intrinsics ;
{
{ fixnum< BLT }
{ fixnum<= BLE }
{ fixnum> BGT }
{ fixnum>= BGE }
{ eq? BEQ }
{ fixnum< BGE }
{ fixnum<= BGT }
{ fixnum> BLE }
{ fixnum>= BLT }
{ eq? BNE }
} [
first2 define-fixnum-jump
] each
@ -356,11 +356,11 @@ IN: cpu.ppc.intrinsics
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< BLT }
{ float<= BLE }
{ float> BGT }
{ float>= BGE }
{ float= BEQ }
{ float< BGE }
{ float<= BGT }
{ float> BLE }
{ float>= BLT }
{ float= BNE }
} [
first2 define-float-jump
] each

5
core/cpu/x86/32/32.factor
View File

@ -16,8 +16,9 @@ IN: cpu.x86.32
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 xt-reg ECX ;
M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;
@ -267,7 +268,7 @@ os windows? [
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
JNE
JE
] { } define-if-intrinsic
"-no-sse2" cli-args member? [

3
core/cpu/x86/64/64.factor
View File

@ -11,8 +11,9 @@ IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 xt-reg RCX ;
M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: temp-reg v>operand drop RBX ;

19
core/cpu/x86/allot/allot.factor
View File

@ -16,12 +16,12 @@ IN: cpu.x86.allot
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( -- )
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
"nursery" f allot-reg %alien-global ;
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
load-zone-ptr
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
@ -29,6 +29,19 @@ IN: cpu.x86.allot
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;

13
core/cpu/x86/architecture/architecture.factor
View File

@ -9,7 +9,6 @@ IN: cpu.x86.architecture
HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: stack-reg cpu
HOOK: xt-reg cpu
HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
@ -35,6 +34,10 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu
HOOK: temp-reg-2 cpu
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ cpu
@ -47,13 +50,13 @@ M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
M: x86 %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-this ;
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
M: x86 %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
temp-reg v>operand PUSH
stack-reg swap 2 cells - SUB ;
M: x86 %epilogue ( n -- )
@ -76,8 +79,8 @@ M: x86 %call ( label -- ) CALL ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86 %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
M: x86 %jump-f ( label -- )
"flag" operand f v>operand CMP JE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;

10
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -212,11 +212,11 @@ IN: cpu.x86.intrinsics
2array define-if-intrinsics ;
{
{ fixnum< JL }
{ fixnum<= JLE }
{ fixnum> JG }
{ fixnum>= JGE }
{ eq? JE }
{ fixnum< JGE }
{ fixnum<= JG }
{ fixnum> JLE }
{ fixnum>= JL }
{ eq? JNE }
} [
first2 define-fixnum-jump
] each

10
core/cpu/x86/sse2/sse2.factor
View File

@ -27,11 +27,11 @@ IN: cpu.x86.sse2
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
{ float< JB }
{ float<= JBE }
{ float> JA }
{ float>= JAE }
{ float= JE }
{ float< JAE }
{ float<= JA }
{ float> JBE }
{ float>= JB }
{ float= JNE }
} [
first2 define-float-jump
] each

20
core/generator/generator.factor
View File

@ -40,16 +40,16 @@ SYMBOL: current-label-start
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
f compiling-word get compiled get set-at ;
f compiling-label get compiled get set-at ;
: finish-compiling ( literals relocation labels code -- )
: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
finish-compiling
save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
@ -131,14 +131,14 @@ M: #loop generate-node
: generate-if ( node label -- next )
<label> [
>r >r node-children first2 generate-branch
>r >r node-children first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
[ <label> dup %jump-t ]
[ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
@ -189,13 +189,13 @@ M: #dispatch generate-node
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
"true" define-label
"false" define-label
"end" define-label
"true" get swap call
f "if-scratch" get load-literal
"end" get %jump-label
"true" resolve-label
"false" get swap call
t "if-scratch" get load-literal
"end" get %jump-label
"false" resolve-label
f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline

9
core/generator/registers/registers.factor
View File

@ -65,9 +65,7 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
TUPLE: temp-reg reg-class>> ;
: temp-reg T{ temp-reg f int-regs } ;
SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
@ -470,11 +468,6 @@ M: loc lazy-store
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
: %gc ( -- )
0 frame-required
%prepare-alien-invoke
"simple_gc" f %alien-invoke ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
double-float-regs free-vregs length <=

3
core/generic/generic.factor
View File

@ -29,6 +29,9 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: specific-method ( class word -- class )
order min-class ;
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )

108
core/generic/standard/engines/tuple/tuple.factor
View File

@ -1,8 +1,11 @@
IN: generic.standard.engines.tuple
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private quotations arrays ;
classes.algebra math math.private kernel.private
quotations arrays ;
IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
@ -27,14 +30,7 @@ TUPLE: tuple-dispatch-engine echelons ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
[
over zero? [
dup assoc-empty?
[ drop f ] [ values first ] if
] [
dupd <echelon-dispatch-engine>
] if
] assoc-map [ nip ] assoc-subset
[ dupd <echelon-dispatch-engine> ] assoc-map
\ tuple-dispatch-engine boa ;
: convert-tuple-methods ( assoc -- assoc' )
@ -48,52 +44,51 @@ M: trivial-tuple-dispatch-engine engine>quot
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: word-hashcode% [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
#! 1 slot == word hashcode
[
[ dup 1 slot ] %
\ dup ,
word-hashcode%
hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ;
: tuple-dispatch-engine-word-name ( engine -- string )
[
generic get word-name %
"/tuple-dispatch-engine/" %
n>> #
] "" make ;
: engine-word-name ( -- string )
generic get word-name "/tuple-dispatch-engine" append ;
PREDICATE: tuple-dispatch-engine-word < word
PREDICATE: engine-word < word
"tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect
M: engine-word stack-effect
"tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: tuple-dispatch-engine-word compiled-crossref?
M: engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
tri ;
: <engine-word> ( -- word )
engine-word-name f <word>
dup generic get "tuple-dispatch-generic" set-word-prop ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
: define-engine-word ( quot -- word )
>r <engine-word> dup r> define ;
: array-nth% 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare ; inline
: tuple-dispatch-engine-body ( engine -- quot )
#! 1 slot == tuple-layout
#! 2 slot == 0 array-nth
#! 4 slot == layout-superclasses
[
picker %
[ 1 slot 4 slot ] %
[ n>> 2 + , [ slot ] % ]
[ tuple-layout-superclasses ] %
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
@ -104,25 +99,54 @@ M: tuple-dispatch-engine-word compiled-crossref?
] [ ] make ;
M: echelon-dispatch-engine engine>quot
dup tuple-dispatch-engine-body
define-tuple-dispatch-engine-word
1quotation ;
dup n>> zero? [
methods>> dup assoc-empty?
[ drop default get ] [ values first engine>quot ] if
] [
[
picker %
[ tuple-layout-superclasses ] %
[ n>> array-nth% ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make
] if ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: tuple-layout-echelon ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
5 slot ; inline
: unclip-last [ 1 head* ] [ peek ] bi ;
M: tuple-dispatch-engine engine>quot
#! 1 slot == tuple-layout
#! 5 slot == layout-echelon
[
picker %
[ 1 slot 5 slot ] %
echelons>>
[ tuple-layout-echelon ] %
[
tuple assumed set
[ engine>quot dup default set ] assoc-map
echelons>> dup empty? [
unclip-last
[
[
engine>quot define-engine-word
[ remember-engine ] [ 1quotation ] bi
dup default set
] assoc-map
]
[ first2 engine>quot 2array ] bi*
suffix
] unless
] with-scope
>=-case-quot %
] [ ] make ;

8
core/generic/standard/standard-tests.factor
View File

@ -251,6 +251,14 @@ HOOK: my-tuple-hook my-var ( -- x )
M: sequence my-tuple-hook my-hook ;
TUPLE: m-t-h-a ;
M: m-t-h-a my-tuple-hook "foo" ;
TUPLE: m-t-h-b < m-t-h-a ;
M: m-t-h-b my-tuple-hook "bar" ;
[ f ] [
\ my-tuple-hook [ "engines" word-prop ] keep prefix
[ 1quotation infer ] map all-equal?

4
core/inference/backend/backend-docs.factor
View File

@ -48,10 +48,6 @@ HELP: no-effect
{ $description "Throws a " { $link no-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: collect-recursion
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
HELP: inline-word
{ $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words."

79
core/inference/backend/backend.factor
View File

@ -15,7 +15,7 @@ GENERIC: inline? ( word -- ? )
M: method-body inline?
"method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline?
M: engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
@ -130,25 +130,27 @@ TUPLE: too-many->r ;
TUPLE: too-many-r> ;
: check-r> ( -- )
meta-r get empty?
: check-r> ( n -- )
meta-r get length >
[ \ too-many-r> inference-error ] when ;
: infer->r ( -- )
1 ensure-values
: infer->r ( n -- )
dup ensure-values
#>r
1 0 pick node-inputs
pop-d push-r
0 1 pick node-outputs
node, ;
over 0 pick node-inputs
over [ drop pop-d ] map reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
: infer-r> ( -- )
check-r>
: infer-r> ( n -- )
dup check-r>
#r>
0 1 pick node-inputs
pop-r push-d
1 0 pick node-outputs
node, ;
0 pick pick node-inputs
over [ drop pop-r ] map reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
@ -199,18 +201,18 @@ M: object constructor drop f ;
dup infer-uncurry
constructor [
peek-d reify-curry
infer->r
1 infer->r
peek-d reify-curry
infer-r>
1 infer-r>
2 1 <effect> swap #call consume/produce
] when* ;
: reify-curries ( n -- )
meta-d get reverse [
dup special? [
over [ infer->r ] times
over infer->r
dup reify-curry
over [ infer-r> ] times
over infer-r>
] when 2drop
] 2each ;
@ -407,6 +409,25 @@ TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
M: node collect-label-info* 2drop ;
: (collect-label-info) ( label node vector -- )
>r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
inline
M: #call-label collect-label-info*
over calls>> (collect-label-info) ;
M: #return collect-label-info*
over returns>> (collect-label-info) ;
: collect-label-info ( #label -- )
V{ } clone >>calls
V{ } clone >>returns
dup [ collect-label-info* ] with each-node ;
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
@ -417,27 +438,17 @@ TUPLE: recursive-declare-error word ;
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- node-block data )
: inline-block ( word -- #label data )
[
copy-inference nest-node
dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion*
tuck node-param eq? [ , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
dup node-param
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get suffix
: join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
@ -458,7 +469,7 @@ M: #call-label collect-recursion*
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
collect-recursion [
calls>> [
[ flatten-curries ] modify-values
] each
] [

283
core/inference/class/class-tests.factor
View File

@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors ;
system layouts vectors optimizer.math.partial accessors
optimizer.inlining ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -13,9 +18,15 @@ system layouts vectors ;
! Ensure type inference works as it is supposed to by checking
! if various methods get inlined
: inlined? ( quot word -- ? )
: inlined? ( quot seq/word -- ? )
dup word? [ 1array ] when
swap dataflow optimize
[ node-param eq? ] with node-exists? not ;
[ node-param swap member? ] with node-exists? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
] unit-test
GENERIC: mynot ( x -- y )
@ -109,12 +120,17 @@ M: object xyz ;
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
] unit-test
[ f ] [
[ t ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ + inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
[ f ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ f ] [
[
@ -137,13 +153,13 @@ M: object xyz ;
DEFER: blah
[ t ] [
[ ] [
[
\ blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
\ blah compiled?
\ blah word-def dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
@ -158,14 +174,20 @@ M: fixnum detect-fx ;
] \ detect-fx inlined?
] unit-test
[ t ] [
[
1000000000000000000000000000000000 [ ] times
] \ + inlined?
] unit-test
[ f ] [
[
1000000000000000000000000000000000 [ ] times
] \ 1+ inlined?
] \ +-integer-fixnum inlined?
] unit-test
[ f ] [
[ { bignum } declare [ ] times ] \ 1+ inlined?
[ { bignum } declare [ ] times ]
\ +-integer-fixnum inlined?
] unit-test
@ -251,19 +273,24 @@ M: float detect-float ;
[ 3 + = ] \ equal? inlined?
] unit-test
[ t ] [
[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ shift inlined?
\ fixnum-shift-fast inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
{ fixnum-shift-fast } inlined?
] unit-test
cell-bits 32 = [
@ -278,6 +305,11 @@ cell-bits 32 = [
] unit-test
] when
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
@ -323,3 +355,228 @@ cell-bits 32 = [
] when
] \ + 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
[ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline
[ t ] [
[ { fixnum } declare rec 1 + ]
{ > - + } inlined?
] unit-test
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
[ t ] [
[ 27.0 fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27.0 fib ] { +-integer-integer } inlined?
] unit-test
[ t ] [
[ 27 fib ] { < - + } inlined?
] unit-test
[ t ] [
[ 27 >bignum fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27/2 fib ] { < - } inlined?
] unit-test
: hang-regression ( m n -- x )
over 0 number= [
nip
] [
dup [
drop 1 hang-regression
] [
dupd hang-regression hang-regression
] if
] if ; inline
[ t ] [
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
] { } inlined? ] unit-test
: detect-null ( a -- b ) dup drop ;
\ detect-null {
{ [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
} define-optimizers
[ t ] [
[ { null } declare detect-null ] \ detect-null inlined?
] unit-test
[ t ] [
[ { null null } declare + detect-null ] \ detect-null inlined?
] unit-test
[ f ] [
[ { null fixnum } declare + detect-null ] \ detect-null inlined?
] unit-test
GENERIC: detect-integer ( a -- b )
M: integer detect-integer ;
[ t ] [
[ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
] unit-test
[ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
\ fixnum-bitand 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 ] [
[ { fixnum } declare [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
{ < <-integer-fixnum } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
\ +-integer-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
[ f ] [
[
{ integer } declare [ ] map
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare { } set-nth-unsafe
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare 1 + { } set-nth-unsafe
] \ >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 ] [
[ { integer } declare bitnot detect-integer ]
\ detect-integer inlined?
] unit-test
! Later
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 0 >= ] map
! ] { >= fixnum>= } inlined?
! ] unit-test

201
core/inference/class/class.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
inference.backend combinators accessors ;
IN: inference.class
! Class inference
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
M: literal-constraint equal?
over literal-constraint? [
2dup
[ literal-constraint-literal ] bi@ eql? >r
[ literal-constraint-value ] bi@ = r> and
] [
2drop f
] if ;
[ [ literal>> ] bi@ eql? ]
[ [ value>> ] bi@ = ]
2bi and
] [ 2drop f ] if ;
TUPLE: class-constraint class value ;
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
: `input node get node-in-d nth ;
: `output node get node-out-d nth ;
: `input node get in-d>> nth ;
: `output node get out-d>> nth ;
: class, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
@ -84,14 +82,12 @@ SYMBOL: value-classes
set-value-interval* ;
M: interval-constraint apply-constraint
dup interval-constraint-interval
swap interval-constraint-value intersect-value-interval ;
[ interval>> ] [ value>> ] bi intersect-value-interval ;
: set-class-interval ( class value -- )
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
>r "interval" word-prop r> over
[ set-value-interval* ] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
[ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint
dup class-constraint-class
swap class-constraint-value intersect-value-class ;
[ class>> ] [ value>> ] bi intersect-value-class ;
: literal-interval ( value -- interval/f )
dup real? [ [a,a] ] [ drop f ] if ;
: set-value-literal* ( literal value -- )
over class over set-value-class*
over real? [ over [a,a] over set-value-interval* ] when
2dup <literal-constraint> assume
value-literals get set-at ;
{
[ >r class r> set-value-class* ]
[ >r literal-interval r> set-value-interval* ]
[ <literal-constraint> assume ]
[ value-literals get set-at ]
} 2cleave ;
M: literal-constraint apply-constraint
dup literal-constraint-literal
swap literal-constraint-value set-value-literal* ;
[ literal>> ] [ value>> ] bi set-value-literal* ;
! For conditionals, an assoc of child node # --> constraint
GENERIC: child-constraints ( node -- seq )
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
M: node infer-classes-before drop ;
M: node child-constraints
node-children length
children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
: value-literal* ( value -- obj ? )
value-literals get at* ;
M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
dup value>> value-literal*
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
dup class-constraint-value value-class*
swap class-constraint-class class< ;
[ value>> value-class* ] [ class>> ] bi class< ;
M: pair apply-constraint
first2 2dup constraints get set-at
@ -154,19 +152,18 @@ M: pair apply-constraint
M: pair constraint-satisfied?
first constraint-satisfied? ;
: extract-keys ( assoc seq -- newassoc )
dup length <hashtable> swap [
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
] each nip f assoc-like ;
: extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values
value-intervals get over extract-keys pick set-node-intervals
value-classes get over extract-keys pick set-node-classes
value-literals get over extract-keys pick set-node-literals
2drop ;
dup node-values {
[ value-intervals get extract-keys >>intervals ]
[ value-classes get extract-keys >>classes ]
[ value-literals get extract-keys >>literals ]
[ 2drop ]
} cleave ;
: intersect-classes ( classes values -- )
[ intersect-value-class ] 2each ;
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
dup param>> "constraints" word-prop [
call
] [
dup node-param "predicating" word-prop dup
dup param>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if
] if* ;
: compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop
dup param>> "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals )
dup compute-output-classes >r
[ ] [ node-param "default-output-classes" word-prop ] ?if
[ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before
dup compute-constraints
dup node-out-d swap output-classes
>r over intersect-classes
r> swap intersect-intervals ;
[ compute-constraints ] keep
[ output-classes ] [ out-d>> ] bi
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
M: #push infer-classes-before
node-out-d
[ [ value-literal ] keep set-value-literal* ] each ;
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-constraints
[
@ -224,19 +219,17 @@ M: #if child-constraints
M: #dispatch child-constraints
dup [
node-children length [
0 `input literal,
] each
children>> length [ 0 `input literal, ] each
] make-constraints ;
M: #declare infer-classes-before
dup node-param swap node-in-d
[ param>> ] [ in-d>> ] bi
[ intersect-value-class ] 2each ;
DEFER: (infer-classes)
: infer-children ( node -- )
dup node-children swap child-constraints [
[ children>> ] [ child-constraints ] bi [
[
value-classes [ clone ] change
value-literals [ clone ] change
@ -251,27 +244,27 @@ DEFER: (infer-classes)
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
: (merge-classes) ( nodes -- seq )
[ node-input-classes ] map
null pad-all flip [ null [ class-or ] reduce ] map ;
dup length 1 = [
first node-input-classes
] [
[ node-input-classes ] map null pad-all flip
[ null [ class-or ] reduce ] map
] if ;
: set-classes ( seq node -- )
node-out-d [ set-value-class* ] 2reverse-each ;
out-d>> [ set-value-class* ] 2reverse-each ;
: merge-classes ( nodes node -- )
>r (merge-classes) r> set-classes ;
: (merge-intervals) ( nodes quot -- seq )
>r
[ node-input-intervals ] map
f pad-all flip
r> map ; inline
: set-intervals ( seq node -- )
node-out-d [ set-value-interval* ] 2reverse-each ;
out-d>> [ set-value-interval* ] 2reverse-each ;
: merge-intervals ( nodes node -- )
>r [ dup first [ interval-union ] reduce ]
(merge-intervals) r> set-intervals ;
>r
[ node-input-intervals ] map f pad-all flip
[ dup first [ interval-union ] reduce ] map
r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
[ merge-classes ] [ merge-intervals ] 2bi ;
@ -280,28 +273,68 @@ DEFER: (infer-classes)
dup node-successor dup #merge? [
swap active-children dup empty?
[ 2drop ] [ swap annotate-merge ] if
] [
2drop
] if ;
] [ 2drop ] if ;
: classes= ( inferred current -- ? )
2dup min-length [ tail* ] curry bi@ sequence= ;
SYMBOL: fixed-point?
SYMBOL: nested-labels
: annotate-entry ( nodes #label -- )
node-child merge-classes ;
>r (merge-classes) r> node-child
2dup node-output-classes classes=
[ 2drop ] [ set-classes fixed-point? off ] if ;
: init-recursive-calls ( #label -- )
#! We set recursive calls to output the empty type, then
#! repeat inference until a fixed point is reached.
#! Hopefully, our type functions are monotonic so this
#! will always converge.
returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
[ 1array ] keep annotate-entry ;
[ init-recursive-calls ]
[ [ 1array ] keep annotate-entry ] bi ;
: infer-label-loop ( #label -- )
fixed-point? on
dup node-child (infer-classes)
dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
fixed-point? get [ drop ] [ infer-label-loop ] if ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
{
[ annotate-node ]
[ infer-classes-before ]
[ infer-children ]
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
[ node-child (infer-classes) ]
} cleave ;
[
{
[ nested-labels get push ]
[ annotate-node ]
[ infer-classes-before ]
[ infer-label-loop ]
[ drop nested-labels get pop* ]
} cleave
] with-scope ;
: find-label ( param -- #label )
param>> nested-labels get [ param>> eq? ] with find nip ;
M: #call-label infer-classes-before ( #call-label -- )
[ find-label returns>> (merge-classes) ] [ out-d>> ] bi
[ set-value-class* ] 2each ;
M: #return infer-classes-around
nested-labels get length 0 > [
dup param>> nested-labels get peek param>> eq? [
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
[ in-d>> value-classes get extract-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
] [ call-next-method ] if ;
M: object infer-classes-around
{
@ -314,11 +347,13 @@ M: object infer-classes-around
: (infer-classes) ( node -- )
[
[ infer-classes-around ]
[ node-successor (infer-classes) ] bi
[ node-successor ] bi
(infer-classes)
] when* ;
: infer-classes-with ( node classes literals intervals -- )
[
V{ } clone nested-labels set
H{ } assoc-like value-intervals set
H{ } assoc-like value-literals set
H{ } assoc-like value-classes set
@ -326,13 +361,11 @@ M: object infer-classes-around
(infer-classes)
] with-scope ;
: infer-classes ( node -- )
f f f infer-classes-with ;
: infer-classes ( node -- node )
dup f f f infer-classes-with ;
: infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
dup node-classes
over node-literals
rot node-intervals
[ classes>> ] [ literals>> ] [ intervals>> ] tri
infer-classes-with ;

5
core/inference/dataflow/dataflow.factor
View File

@ -90,7 +90,7 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label < node word loop? ;
TUPLE: #label < node word loop? returns calls ;
: #label ( word label -- node )
\ #label param-node swap >>word ;
@ -290,6 +290,9 @@ SYMBOL: node-stack
: node-input-classes ( node -- seq )
dup in-d>> [ node-class ] with map ;
: node-output-classes ( node -- seq )
dup out-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
dup in-d>> [ node-interval ] with map ;

8
core/inference/known-words/known-words.factor
View File

@ -54,9 +54,9 @@ IN: inference.known-words
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
\ >r [ infer->r ] "infer" set-word-prop
\ >r [ 1 infer->r ] "infer" set-word-prop
\ r> [ infer-r> ] "infer" set-word-prop
\ r> [ 1 infer-r> ] "infer" set-word-prop
\ declare [
1 ensure-values
@ -81,8 +81,8 @@ M: curried infer-call
M: composed infer-call
infer-uncurry
infer->r peek-d infer-call
terminated? get [ infer-r> peek-d infer-call ] unless ;
1 infer->r peek-d infer-call
terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ literal-expected inference-warning ;

7
core/math/integers/integers-tests.factor
View File

@ -184,3 +184,10 @@ unit-test
[ HEX: 988a259c3433f237 ] [
B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ f ] [ -128 power-of-2? ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test

2
core/math/intervals/intervals.factor
View File

@ -96,6 +96,8 @@ C: <interval> interval
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
: interval-sq ( i1 -- i2 ) dup interval* ;
: make-interval ( from to -- int )
over first over first {
{ [ 2dup > ] [ 2drop 2drop f ] }

12
core/math/math-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel sequences quotations
math.private math.functions ;
math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
@ -26,17 +26,13 @@ $nl
{ $subsection < }
{ $subsection <= }
{ $subsection > }
{ $subsection >= }
"Inexact comparison:"
{ $subsection ~ } ;
{ $subsection >= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
{ $subsection mod-inv }
{ $subsection ^mod }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
@ -363,6 +359,10 @@ HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }

24
core/math/math.factor
View File

@ -55,26 +55,26 @@ GENERIC: zero? ( x -- ? ) foldable
M: object zero? drop f ;
: 1+ ( x -- y ) 1 + ; foldable
: 1- ( x -- y ) 1 - ; foldable
: 2/ ( x -- y ) -1 shift ; foldable
: sq ( x -- y ) dup * ; foldable
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
: 1+ ( x -- y ) 1 + ; inline
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable
: min ( x y -- z ) [ < ] most ; foldable
: max ( x y -- z ) [ > ] most ; inline
: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
@ -121,7 +121,11 @@ M: float fp-nan?
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
: power-of-2? ( n -- ? )
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
: align ( m w -- n )
1- [ + ] keep bitnot bitand ; inline
<PRIVATE

66
core/optimizer/backend/backend.factor
View File

@ -3,7 +3,7 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes optimizer.def-use ;
combinators classes optimizer.def-use accessors ;
IN: optimizer.backend
SYMBOL: class-substitutions
@ -16,37 +16,32 @@ SYMBOL: optimizer-changed
GENERIC: optimize-node* ( node -- node/t changed? )
: ?union ( assoc/f assoc -- hash )
over [ assoc-union ] [ nip ] if ;
: ?union ( assoc assoc/f -- assoc' )
dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
: add-node-literals ( assoc node -- )
over assoc-empty? [
: add-node-literals ( node assoc -- )
[ ?union ] curry change-literals drop ;
: add-node-classes ( node assoc -- )
[ ?union ] curry change-classes drop ;
: substitute-values ( node assoc -- )
dup assoc-empty? [
2drop
] [
[ node-literals ?union ] keep set-node-literals
] if ;
: add-node-classes ( assoc node -- )
over assoc-empty? [
2drop
] [
[ node-classes ?union ] keep set-node-classes
] if ;
: substitute-values ( assoc node -- )
over assoc-empty? [
2drop
] [
2dup node-in-d swap substitute-here
2dup node-in-r swap substitute-here
2dup node-out-d swap substitute-here
node-out-r swap substitute-here
{
[ >r in-d>> r> substitute-here ]
[ >r in-r>> r> substitute-here ]
[ >r out-d>> r> substitute-here ]
[ >r out-r>> r> substitute-here ]
} 2cleave
] if ;
: perform-substitutions ( node -- )
class-substitutions get over add-node-classes
literal-substitutions get over add-node-literals
value-substitutions get swap substitute-values ;
[ class-substitutions get add-node-classes ]
[ literal-substitutions get add-node-literals ]
[ value-substitutions get substitute-values ]
tri ;
DEFER: optimize-nodes
@ -90,18 +85,21 @@ M: node optimize-node* drop t f ;
#! Not very efficient.
dupd union* update ;
: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
node-out-d swap node-in-d 2array unify-lengths flip
: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor dup [
class-substitutions get pick node-classes update
literal-substitutions get pick node-literals update
tuck compute-value-substitutions value-substitutions get swap update*
node-successor t
dup node-successor [
[ node-successor ] keep
{
[ nip classes>> class-substitutions get swap update ]
[ nip literals>> literal-substitutions get swap update ]
[ compute-value-substitutions value-substitutions get swap update* ]
[ drop node-successor ]
} 2cleave t
] [
2drop t f
drop t f
] if ;
! #return

10
core/optimizer/collect/collect.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inference.dataflow inference.backend kernel ;
IN: optimizer
: collect-label-infos ( node -- node )
dup [
dup #label? [ collect-label-info ] [ drop ] if
] each-node ;

32
core/optimizer/control/control-tests.factor
View File

@ -27,22 +27,22 @@ optimizer ;
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
[ t ] [
[ loop-test-1 ] dataflow dup detect-loops
[ loop-test-1 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ loop-test-1 1 2 3 ] dataflow dup detect-loops
[ loop-test-1 1 2 3 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
[ [ loop-test-1 ] each ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
[ [ loop-test-1 ] each ] dataflow dup detect-loops
[ [ loop-test-1 ] each ] dataflow detect-loops
\ (each-integer) label-is-loop?
] unit-test
@ -50,7 +50,7 @@ optimizer ;
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [
[ loop-test-2 ] dataflow dup detect-loops
[ loop-test-2 ] dataflow detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
@ -58,7 +58,7 @@ optimizer ;
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [
[ loop-test-3 ] dataflow dup detect-loops
[ loop-test-3 ] dataflow detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test
@ -73,7 +73,7 @@ optimizer ;
dup #label? [ node-successor find-label ] unless ;
: test-loop-exits
dataflow dup detect-loops find-label
dataflow detect-loops find-label
dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ;
@ -113,7 +113,7 @@ optimizer ;
] unit-test
[ f ] [
[ [ [ ] map ] map ] dataflow dup detect-loops
[ [ [ ] map ] map ] dataflow detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
@ -128,22 +128,22 @@ DEFER: a
blah [ b ] [ a ] if ; inline
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
[ b ] dataflow dup detect-loops
[ b ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
[ a ] dataflow dup detect-loops
[ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
@ -156,12 +156,12 @@ DEFER: a'
blah [ b' ] [ a' ] if ; inline
[ f ] [
[ a' ] dataflow dup detect-loops
[ a' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ b' ] dataflow dup detect-loops
[ b' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test
@ -171,11 +171,11 @@ DEFER: a'
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
[ b' ] dataflow dup detect-loops
[ b' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
[ a' ] dataflow dup detect-loops
[ a' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test

3
core/optimizer/control/control.factor
View File

@ -109,8 +109,9 @@ SYMBOL: potential-loops
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
: detect-loops ( nodes -- )
: detect-loops ( node -- node )
[
dup
collect-label-info
remove-non-tail-calls
remove-non-loop-calls

4
core/optimizer/def-use/def-use-tests.factor
View File

@ -3,12 +3,12 @@ USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use
[ 1 2 3 ] dataflow compute-def-use drop
def-use get values dup length swap [ length ] map
] unit-test
: kill-set ( quot -- seq )
dataflow compute-def-use compute-dead-literals keys
dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;

50
core/optimizer/def-use/def-use.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.def-use
USING: namespaces assocs sequences inference.dataflow
inference.backend kernel generic assocs classes vectors ;
inference.backend kernel generic assocs classes vectors
accessors combinators ;
IN: optimizer.def-use
SYMBOL: def-use
@ -21,17 +22,20 @@ SYMBOL: def-use
GENERIC: node-def-use ( node -- )
: compute-def-use ( node -- )
H{ } clone def-use set [ node-def-use ] each-node ;
: compute-def-use ( node -- node )
H{ } clone def-use set
dup [ node-def-use ] each-node ;
: nest-def-use ( node -- def-use )
[ compute-def-use def-use get ] with-scope ;
[ compute-def-use drop def-use get ] with-scope ;
: (node-def-use) ( node -- )
dup dup node-in-d uses-values
dup dup node-in-r uses-values
dup node-out-d defs-values
node-out-r defs-values ;
{
[ dup in-d>> uses-values ]
[ dup in-r>> uses-values ]
[ out-d>> defs-values ]
[ out-r>> defs-values ]
} cleave ;
M: object node-def-use (node-def-use) ;
@ -43,7 +47,7 @@ M: #passthru node-def-use drop ;
M: #return node-def-use
#! Values returned by local labels can be killed.
dup node-param [ drop ] [ (node-def-use) ] if ;
dup param>> [ drop ] [ (node-def-use) ] if ;
! nodes that don't use their values directly
UNION: #killable
@ -56,13 +60,13 @@ UNION: #killable
M: #label node-def-use
[
dup node-in-d ,
dup node-child node-out-d ,
dup collect-recursion [ node-in-d , ] each
dup in-d>> ,
dup node-child out-d>> ,
dup calls>> [ in-d>> , ] each
] { } make purge-invariants uses-values ;
: branch-def-use ( #branch -- )
active-children [ node-in-d ] map
active-children [ in-d>> ] map
purge-invariants t swap uses-values ;
M: #branch node-def-use
@ -85,16 +89,16 @@ M: node kill-node* drop t ;
inline
M: #shuffle kill-node*
[
dup node-in-d empty? swap node-out-d empty? and
] prune-if ;
[ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
M: #push kill-node*
[ node-out-d empty? ] prune-if ;
[ out-d>> empty? ] prune-if ;
M: #>r kill-node* [ node-in-d empty? ] prune-if ;
M: #>r kill-node*
[ in-d>> empty? ] prune-if ;
M: #r> kill-node* [ node-in-r empty? ] prune-if ;
M: #r> kill-node*
[ in-r>> empty? ] prune-if ;
: kill-node ( node -- node )
dup [
@ -116,7 +120,7 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
] if ;
: sole-consumer ( #call -- node/f )
node-out-d first used-by
out-d>> first used-by
dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- )
@ -128,5 +132,5 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
[ compute-def-use def-use get keys ] with-scope
nest-def-use keys
def-use get [ [ t swap ?push ] change-at ] curry each ;

10
core/optimizer/inlining/inlining-tests.factor Normal file
View File

@ -0,0 +1,10 @@
IN: optimizer.inlining.tests
USING: tools.test optimizer.inlining ;
\ word-flat-length must-infer
\ inlining-math-method must-infer
\ optimistic-inline? must-infer
\ find-identity must-infer

40
core/optimizer/inlining/inlining.factor
View File

@ -3,10 +3,11 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard
optimizer.specializers optimizer.def-use optimizer.pattern-match
generic.standard optimizer.control kernel.private ;
combinators classes classes.algebra generic.math
optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -53,8 +54,6 @@ DEFER: (flat-length)
[ word-def (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
@ -72,6 +71,7 @@ DEFER: (flat-length)
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
{
null
fixnum bignum integer
ratio rational
float real
@ -79,21 +79,31 @@ DEFER: (flat-length)
object
} [ class< ] with find nip ;
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: inline-math-method ( #call word -- node )
over node-input-classes
: inlining-math-method ( #call word -- quot/f )
swap node-input-classes
[ first normalize-math-class ]
[ second normalize-math-class ] bi
3dup math-both-known?
[ math-method f splice-quot ]
[ 2drop 2drop t ] if ;
3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
: inline-math-method ( #call word -- node/t )
[ drop ] [ inlining-math-method ] 2bi
dup [ f splice-quot ] [ 2drop t ] if ;
: inline-math-partial ( #call word -- node/t )
[ drop ]
[
"derived-from" word-prop first
inlining-math-method dup
]
[ nip 1quotation ] 2tri
[ = not ] [ drop ] 2bi and
[ f splice-quot ] [ 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
[ 2drop t ]
} cond ;
@ -183,7 +193,7 @@ DEFER: (flat-length)
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
dup find-identity f splice-quot ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [

12
core/optimizer/known-words/known-words.factor
View File

@ -83,21 +83,11 @@ sequences.private combinators ;
] "constraints" set-word-prop
! eq? on the same object is always t
{ eq? bignum= float= number= = } {
{ eq? = } {
{ { @ @ } [ 2drop t ] }
} define-identities
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop
] each
\ 2/ { fixnum } "specializer" set-word-prop
{ min max } [
{ number number } "specializer" set-word-prop
] each
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each

331
core/optimizer/math/math.factor
View File

@ -8,103 +8,104 @@ namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining
generic.standard system ;
optimizer.math.partial generic.standard system accessors ;
{ + bignum+ float+ fixnum+fast } {
: define-math-identities ( word identities -- )
>r all-derived-ops r> define-identities ;
\ number= {
{ { @ @ } [ 2drop t ] }
} define-math-identities
\ + {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
} define-identities
} define-math-identities
{ fixnum+ } {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
} define-identities
{ - fixnum- bignum- float- fixnum-fast } {
\ - {
{ { number 0 } [ drop ] }
{ { @ @ } [ 2drop 0 ] }
} define-identities
} define-math-identities
{ < fixnum< bignum< float< } {
\ < {
{ { @ @ } [ 2drop f ] }
} define-identities
} define-math-identities
{ <= fixnum<= bignum<= float<= } {
\ <= {
{ { @ @ } [ 2drop t ] }
} define-identities
} define-math-identities
{ > fixnum> bignum> float>= } {
\ > {
{ { @ @ } [ 2drop f ] }
} define-identities
} define-math-identities
{ >= fixnum>= bignum>= float>= } {
\ >= {
{ { @ @ } [ 2drop t ] }
} define-identities
} define-math-identities
{ * fixnum* bignum* float* } {
\ * {
{ { number 1 } [ drop ] }
{ { 1 number } [ nip ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
{ { -1 number } [ nip 0 swap - ] }
} define-identities
} define-math-identities
{ / fixnum/i bignum/i float/f } {
\ / {
{ { number 1 } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
} define-identities
} define-math-identities
{ fixnum-mod bignum-mod } {
{ { number 1 } [ 2drop 0 ] }
} define-identities
\ mod {
{ { integer 1 } [ 2drop 0 ] }
} define-math-identities
{ bitand fixnum-bitand bignum-bitand } {
\ rem {
{ { integer 1 } [ 2drop 0 ] }
} define-math-identities
\ bitand {
{ { number -1 } [ drop ] }
{ { -1 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
} define-identities
} define-math-identities
{ bitor fixnum-bitor bignum-bitor } {
\ bitor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number -1 } [ nip ] }
{ { -1 number } [ drop ] }
} define-identities
} define-math-identities
{ bitxor fixnum-bitxor bignum-bitxor } {
\ bitxor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { number -1 } [ drop bitnot ] }
{ { -1 number } [ nip bitnot ] }
{ { @ @ } [ 2drop 0 ] }
} define-identities
} define-math-identities
{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
\ shift {
{ { 0 number } [ drop ] }
{ { number 0 } [ drop ] }
} define-identities
} define-math-identities
: math-closure ( class -- newclass )
{ fixnum integer rational real }
{ null fixnum bignum integer rational float real number }
[ class< ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
[ interval-subset? ] [ 2drop t ] if ;
: math-output-class ( node min -- newclass )
#! if min is f, it means we just want to use the declared
#! output class from the "infer-effect".
dup [
swap node-in-d
[ value-class* math-closure math-class-max ] each
] [
2drop f
] if ;
: math-output-class ( node upgrades -- newclass )
>r
in-d>> null [ value-class* math-closure math-class-max ] reduce
dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
node-in-d [ value-class* fixnum class< ] all?
@ -123,28 +124,18 @@ generic.standard system ;
2drop f
] if ; inline
: math-output-class/interval-1 ( node min word -- classes intervals )
pick >r
>r over r>
math-output-interval-1
>r math-output-class r>
r> post-process ; inline
: math-output-class/interval-1 ( node word -- classes intervals )
[ drop { } math-output-class 1array ]
[ math-output-interval-1 1array ] 2bi ;
{
{ 1+ integer interval-1+ }
{ 1- integer interval-1- }
{ neg integer interval-neg }
{ shift integer interval-recip }
{ bitnot fixnum interval-bitnot }
{ fixnum-bitnot f interval-bitnot }
{ bignum-bitnot f interval-bitnot }
{ 2/ fixnum interval-2/ }
{ sq integer f }
{ bitnot interval-bitnot }
{ fixnum-bitnot interval-bitnot }
{ bignum-bitnot interval-bitnot }
} [
first3 [
math-output-class/interval-1
] 2curry "output-classes" set-word-prop
] each
[ math-output-class/interval-1 ] curry
"output-classes" set-word-prop
] assoc-each
: intervals ( node -- i1 i2 )
node-in-d first2 [ value-interval* ] bi@ ;
@ -156,7 +147,7 @@ generic.standard system ;
2drop f
] if ; inline
: math-output-class/interval-2 ( node min word -- classes intervals )
: math-output-class/interval-2 ( node upgrades word -- classes intervals )
pick >r
>r over r>
math-output-interval-2
@ -164,47 +155,18 @@ generic.standard system ;
r> post-process ; inline
{
{ + integer interval+ }
{ - integer interval- }
{ * integer interval* }
{ / rational interval/ }
{ /i integer interval/i }
{ fixnum+ f interval+ }
{ fixnum+fast f interval+ }
{ fixnum- f interval- }
{ fixnum-fast f interval- }
{ fixnum* f interval* }
{ fixnum*fast f interval* }
{ fixnum/i f interval/i }
{ bignum+ f interval+ }
{ bignum- f interval- }
{ bignum* f interval* }
{ bignum/i f interval/i }
{ bignum-shift f interval-shift-safe }
{ float+ f interval+ }
{ float- f interval- }
{ float* f interval* }
{ float/f f interval/ }
{ min fixnum interval-min }
{ max fixnum interval-max }
{ + { { fixnum integer } } interval+ }
{ - { { fixnum integer } } interval- }
{ * { { fixnum integer } } interval* }
{ / { { fixnum rational } { integer rational } } interval/ }
{ /i { { fixnum integer } } interval/i }
{ shift { { fixnum integer } } interval-shift-safe }
} [
first3 [
math-output-class/interval-2
] 2curry "output-classes" set-word-prop
] each
{ fixnum-shift fixnum-shift-fast shift } [
[
dup
node-in-d second value-interval*
-1./0. 0 [a,b] interval-subset? fixnum integer ?
\ interval-shift-safe
math-output-class/interval-2
] "output-classes" set-word-prop
[
math-output-class/interval-2
] 2curry "output-classes" set-word-prop
] 2curry each-derived-op
] each
: real-value? ( value -- n ? )
@ -235,22 +197,18 @@ generic.standard system ;
r> post-process ; inline
{
{ mod fixnum mod-range }
{ fixnum-mod f mod-range }
{ bignum-mod f mod-range }
{ float-mod f mod-range }
{ mod { } mod-range }
{ rem { { fixnum integer } } rem-range }
{ rem integer rem-range }
{ bitand fixnum bitand-range }
{ fixnum-bitand f bitand-range }
{ bitor fixnum f }
{ bitxor fixnum f }
{ bitand { } bitand-range }
{ bitor { } f }
{ bitxor { } f }
} [
first3 [
math-output-class/interval-special
] 2curry "output-classes" set-word-prop
[
math-output-class/interval-special
] 2curry "output-classes" set-word-prop
] 2curry each-derived-op
] each
: twiddle-interval ( i1 -- i2 )
@ -280,26 +238,12 @@ generic.standard system ;
{ <= assume<= assume> }
{ > assume> assume<= }
{ >= assume>= assume< }
{ fixnum< assume< assume>= }
{ fixnum<= assume<= assume> }
{ fixnum> assume> assume<= }
{ fixnum>= assume>= assume< }
{ bignum< assume< assume>= }
{ bignum<= assume<= assume> }
{ bignum> assume> assume<= }
{ bignum>= assume>= assume< }
{ float< assume< assume>= }
{ float<= assume<= assume> }
{ float> assume> assume<= }
{ float>= assume>= assume< }
} [
first3
[
[ comparison-constraints ] with-scope
] 2curry "constraints" set-word-prop
first3 [
[
[ comparison-constraints ] with-scope
] 2curry "constraints" set-word-prop
] 2curry each-derived-op
] each
{
@ -348,22 +292,20 @@ most-negative-fixnum most-positive-fixnum [a,b]
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
dup node-out-d first node-class fixnum class< ;
dup out-d>> first node-class
[ fixnum class< ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
{ +-integer-fixnum [ fixnum+fast ] }
{ - [ fixnum-fast ] }
{ * [ fixnum*fast ] }
{ *-integer-fixnum [ fixnum*fast ] }
{ shift [ fixnum-shift-fast ] }
{ fixnum+ [ fixnum+fast ] }
{ fixnum- [ fixnum-fast ] }
{ fixnum* [ fixnum*fast ] }
! these are here as an optimization. if they weren't given
! explicitly, the same would be inferred after an extra
! optimization step (see optimistic-inline?)
{ 1+ [ 1 fixnum+fast ] }
{ 1- [ 1 fixnum-fast ] }
{ 2/ [ -1 fixnum-shift ] }
{ neg [ 0 swap fixnum-fast ] }
{ fixnum-shift [ fixnum-shift-fast ] }
} [
[
[ dup remove-overflow-check? ] ,
@ -397,26 +339,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
{ <= interval<= }
{ > interval> }
{ >= interval>= }
{ fixnum< interval< }
{ fixnum<= interval<= }
{ fixnum> interval> }
{ fixnum>= interval>= }
{ bignum< interval< }
{ bignum<= interval<= }
{ bignum> interval> }
{ bignum>= interval>= }
{ float< interval< }
{ float<= interval<= }
{ float> interval> }
{ float>= interval>= }
} [
[
dup [ dupd foldable-comparison? ] curry ,
[ fold-comparison ] curry ,
] { } make 1array define-optimizers
[
dup [ dupd foldable-comparison? ] curry ,
[ fold-comparison ] curry ,
] { } make 1array define-optimizers
] curry each-derived-op
] assoc-each
! The following words are handled in a similar way except if
@ -426,44 +355,68 @@ most-negative-fixnum most-positive-fixnum [a,b]
swap sole-consumer
dup #call? [ node-param eq? ] [ 2drop f ] if ;
: coereced-to-fixnum? ( #call -- ? )
\ >fixnum consumed-by? ;
: coerced-to-fixnum? ( #call -- ? )
dup dup node-in-d [ node-class integer class< ] with all?
[ \ >fixnum consumed-by? ] [ drop f ] if ;
{
{ fixnum+ [ fixnum+fast ] }
{ fixnum- [ fixnum-fast ] }
{ fixnum* [ fixnum*fast ] }
{ + [ [ >fixnum ] bi@ fixnum+fast ] }
{ - [ [ >fixnum ] bi@ fixnum-fast ] }
{ * [ [ >fixnum ] bi@ fixnum*fast ] }
} [
[
>r derived-ops r> [
[
dup remove-overflow-check?
over coereced-to-fixnum? or
] ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
[
dup remove-overflow-check?
over coerced-to-fixnum? or
] ,
[ f splice-quot ] curry ,
] { } make 1array define-optimizers
] curry each
] assoc-each
: fixnum-shift-fast-pos? ( node -- ? )
#! Shifting 1 to the left won't overflow if the shift
#! count is small enough
dup dup node-in-d first node-literal 1 = [
dup node-in-d second node-interval
0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
] [ drop f ] if ;
: convert-rem-to-and? ( #call -- ? )
dup node-in-d {
{ [ 2dup first node-class integer class< not ] [ f ] }
{ [ 2dup second node-literal integer? not ] [ f ] }
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
[ t ]
} cond 2nip ;
: fixnum-shift-fast-neg? ( node -- ? )
#! Shifting any number to the right won't overflow if the
#! shift count is small enough
dup node-in-d second node-interval
cell-bits 1- neg 0 [a,b] interval-subset? ;
: convert-mod-to-and? ( #call -- ? )
dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
[ convert-rem-to-and? ] [ drop f ] if ;
: fixnum-shift-fast? ( node -- ? )
dup fixnum-shift-fast-pos?
[ drop t ] [ fixnum-shift-fast-neg? ] if ;
: convert-mod-to-and ( #call -- node )
dup
dup node-in-d second node-literal 1-
[ nip bitand ] curry f splice-quot ;
\ fixnum-shift {
\ mod [
{
[ dup fixnum-shift-fast? ]
[ [ fixnum-shift-fast ] f splice-quot ]
{
[ dup convert-mod-to-and? ]
[ convert-mod-to-and ]
}
} define-optimizers
] each-derived-op
\ rem {
{
[ dup convert-rem-to-and? ]
[ convert-mod-to-and ]
}
} define-optimizers
: fixnumify-bitand? ( #call -- ? )
dup node-in-d second node-interval fixnum fits? ;
: fixnumify-bitand ( #call -- node )
[ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
\ bitand {
{
[ dup fixnumify-bitand? ]
[ fixnumify-bitand ]
}
} define-optimizers

13
core/optimizer/math/partial/partial-tests.factor Normal file
View File

@ -0,0 +1,13 @@
IN: optimizer.math.partial.tests
USING: optimizer.math.partial tools.test math kernel
sequences ;
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
[ t ] [ \ + integer bignum math-both-known? ] unit-test
[ t ] [ \ + float fixnum math-both-known? ] unit-test
[ f ] [ \ + real fixnum math-both-known? ] unit-test
[ f ] [ \ + object number math-both-known? ] unit-test
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test

172
core/optimizer/math/partial/partial.factor Normal file
View File

@ -0,0 +1,172 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private math math.private words
sequences parser namespaces assocs quotations arrays
generic generic.math hashtables effects ;
IN: optimizer.math.partial
! Partial dispatch.
! This code will be overhauled and generalized when
! multi-methods go into the core.
PREDICATE: math-partial < word
"derived-from" word-prop >boolean ;
: fixnum-integer-op ( a b fix-word big-word -- c )
pick tag 0 eq? [
drop execute
] [
>r drop >r fixnum>bignum r> r> execute
] if ; inline
: integer-fixnum-op ( a b fix-word big-word -- c )
>r pick tag 0 eq? [
r> drop execute
] [
drop fixnum>bignum r> execute
] if ; inline
: integer-integer-op ( a b fix-word big-word -- c )
pick tag 0 eq? [
integer-fixnum-op
] [
>r drop over tag 0 eq? [
>r fixnum>bignum r> r> execute
] [
r> execute
] if
] if ; inline
<<
: integer-op-combinator ( triple -- word )
[
[ second word-name % "-" % ]
[ third word-name % "-op" % ]
bi
] "" make in get lookup ;
: integer-op-word ( triple fix-word big-word -- word )
[
drop
word-name "fast" tail? >r
[ "-" % ] [ word-name % ] interleave
r> [ "-fast" % ] when
] "" make in get create ;
: integer-op-quot ( word fix-word big-word -- quot )
rot integer-op-combinator 1quotation 2curry ;
: define-integer-op-word ( word fix-word big-word -- )
[
[ integer-op-word ] [ integer-op-quot ] 3bi
2 1 <effect> define-declared
]
[
[ integer-op-word ] [ 2drop ] 3bi
"derived-from" set-word-prop
] 3bi ;
: define-integer-op-words ( words fix-word big-word -- )
[ define-integer-op-word ] 2curry each ;
: integer-op-triples ( word -- triples )
{
{ fixnum integer }
{ integer fixnum }
{ integer integer }
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
>r >r integer-op-triples r> r>
[ define-integer-op-words ]
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
[ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
[ nip ] assoc-subset
[ word-def peek ] assoc-map % ;
SYMBOL: math-ops
[
\ + define-math-ops
\ - define-math-ops
\ * define-math-ops
\ shift define-math-ops
\ mod define-math-ops
\ /i define-math-ops
\ bitand define-math-ops
\ bitor define-math-ops
\ bitxor define-math-ops
\ < define-math-ops
\ <= define-math-ops
\ > define-math-ops
\ >= define-math-ops
\ number= define-math-ops
\ + \ fixnum+ \ bignum+ define-integer-ops
\ - \ fixnum- \ bignum- define-integer-ops
\ * \ fixnum* \ bignum* define-integer-ops
\ shift \ fixnum-shift \ bignum-shift define-integer-ops
\ mod \ fixnum-mod \ bignum-mod define-integer-ops
\ /i \ fixnum/i \ bignum/i define-integer-ops
\ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
\ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
\ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
\ < \ fixnum< \ bignum< define-integer-ops
\ <= \ fixnum<= \ bignum<= define-integer-ops
\ > \ fixnum> \ bignum> define-integer-ops
\ >= \ fixnum>= \ bignum>= define-integer-ops
\ number= \ eq? \ bignum= define-integer-ops
] { } make >hashtable math-ops set-global
SYMBOL: fast-math-ops
[
{ { + fixnum fixnum } fixnum+fast } ,
{ { - fixnum fixnum } fixnum-fast } ,
{ { * fixnum fixnum } fixnum*fast } ,
{ { shift fixnum fixnum } fixnum-shift-fast } ,
\ + \ fixnum+fast \ bignum+ define-integer-ops
\ - \ fixnum-fast \ bignum- define-integer-ops
\ * \ fixnum*fast \ bignum* define-integer-ops
\ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
] { } make >hashtable fast-math-ops set-global
>>
: math-op ( word left right -- word' ? )
3array math-ops get at* ;
: math-method* ( word left right -- quot )
3dup math-op
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
: math-both-known? ( word left right -- ? )
3dup math-op
[ 2drop 2drop t ]
[ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words )
swap [ rot first eq? nip ] curry assoc-subset values ;
: derived-ops ( word -- words )
[ 1array ]
[ math-ops get (derived-ops) ]
bi append ;
: fast-derived-ops ( word -- words )
fast-math-ops get (derived-ops) ;
: all-derived-ops ( word -- words )
[ derived-ops ] [ fast-derived-ops ] bi append ;
: each-derived-op ( word quot -- )
>r derived-ops r> each ; inline

45
core/optimizer/optimizer-tests.factor
View File

@ -14,40 +14,6 @@ IN: optimizer.tests
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
@ -325,7 +291,6 @@ TUPLE: silly-tuple a b ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
@ -342,6 +307,7 @@ M: integer generic-inline-test ;
generic-inline-test
generic-inline-test ;
! Inlining all of the above should only take two passes
[ { t f } ] [
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
@ -374,3 +340,12 @@ HINTS: recursive-inline-hang-3 array ;
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

11
core/optimizer/optimizer.factor
View File

@ -2,7 +2,7 @@
! 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.inlining inference.class ;
optimizer.collect optimizer.inlining inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
@ -10,10 +10,13 @@ IN: optimizer
H{ } clone class-substitutions set
H{ } clone literal-substitutions set
H{ } clone value-substitutions set
dup compute-def-use
collect-label-infos
compute-def-use
kill-values
dup detect-loops
dup infer-classes
detect-loops
infer-classes
optimizer-changed off
optimize-nodes
optimizer-changed get

17
core/prettyprint/backend/backend.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
generic hashtables io assocs kernel math namespaces sequences
strings sbufs io.styles vectors words prettyprint.config
prettyprint.sections quotations io io.files math.parser effects
classes.tuple classes.tuple.private classes float-arrays
float-vectors ;
USING: arrays byte-arrays bit-arrays generic hashtables io
assocs kernel math namespaces sequences strings sbufs io.styles
vectors words prettyprint.config prettyprint.sections quotations
io io.files math.parser effects classes.tuple
classes.tuple.private classes float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
@ -140,11 +139,8 @@ M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
M: float-vector pprint-delims drop \ FV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
@ -156,9 +152,6 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: bit-vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;

22
core/sequences/sequences-docs.factor
View File

@ -76,10 +76,7 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
{ $subsection flip }
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> } ;
{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
@ -785,23 +782,6 @@ HELP: <slice>
{ <slice> subseq } related-words
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
HELP: <column> ( seq n -- column )
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
"USING: arrays prettyprint sequences ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }"
}
}
{ $notes
"In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
} ;
HELP: repetition
{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;

7
core/sequences/sequences-tests.factor
View File

@ -224,13 +224,6 @@ unit-test
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all

14
core/sequences/sequences.factor
View File

@ -215,18 +215,6 @@ M: slice length dup slice-to swap slice-from - ;
INSTANCE: slice virtual-sequence
! A column of a matrix
TUPLE: column seq col ;
C: <column> column
M: column virtual-seq column-seq ;
M: column virtual@
dup column-col -rot column-seq nth bounds-check ;
M: column length column-seq length ;
INSTANCE: column virtual-sequence
! One element repeated many times
TUPLE: repetition len elt ;
@ -703,5 +691,5 @@ PRIVATE>
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
[ <column> dup like ] with map
swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;

33
core/syntax/syntax-docs.factor
View File

@ -150,18 +150,6 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax"
{ $subsection POSTPONE: B{ }
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
{ $subsection POSTPONE: ?V{ }
"Bit vectors are documented in " { $link "bit-vectors" } "." ;
ARTICLE: "syntax-float-vectors" "Float vector syntax"
{ $subsection POSTPONE: FV{ }
"Float vectors are documented in " { $link "float-vectors" } "." ;
ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
{ $subsection POSTPONE: BV{ }
"Byte vectors are documented in " { $link "byte-vectors" } "." ;
ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
"Pathnames are documented in " { $link "pathnames" } "." ;
@ -182,9 +170,6 @@ $nl
{ $subsection "syntax-float-arrays" }
{ $subsection "syntax-vectors" }
{ $subsection "syntax-sbufs" }
{ $subsection "syntax-bit-vectors" }
{ $subsection "syntax-byte-vectors" }
{ $subsection "syntax-float-vectors" }
{ $subsection "syntax-hashtables" }
{ $subsection "syntax-tuples" }
{ $subsection "syntax-pathnames" } ;
@ -291,30 +276,12 @@ HELP: B{
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "B{ 1 2 3 }" } } ;
HELP: BV{
{ $syntax "BV{ elements... }" }
{ $values { "elements" "a list of bytes" } }
{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "BV{ 1 2 3 12 }" } } ;
HELP: ?{
{ $syntax "?{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?{ t f t }" } } ;
HELP: ?V{
{ $syntax "?V{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?V{ t f t }" } } ;
HELP: FV{
{ $syntax "FV{ elements... }" }
{ $values { "elements" "a list of real numbers" } }
{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
HELP: F{
{ $syntax "F{ elements... }" }
{ $values { "elements" "a list of real numbers" } }

9
core/syntax/syntax.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays bit-vectors byte-arrays
byte-vectors definitions generic hashtables kernel math
USING: alien arrays bit-arrays byte-arrays
definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
generic.math classes io.files vocabs float-arrays
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
IN: bootstrap.syntax
@ -79,11 +79,8 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax

4
core/threads/threads-docs.factor
View File

@ -26,7 +26,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
{ $subsection resume }
{ $subsection resume-with } ;
ARTICLE: "thread-state" "Thread-local state"
ARTICLE: "thread-state" "Thread-local state and variables"
"Threads form a class of objects:"
{ $subsection thread }
"The current thread:"
@ -36,6 +36,8 @@ ARTICLE: "thread-state" "Thread-local state"
{ $subsection tget }
{ $subsection tset }
{ $subsection tchange }
"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
$nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;

13
core/threads/threads-tests.factor
View File

@ -1,4 +1,5 @@
USING: namespaces io tools.test threads kernel ;
USING: namespaces io tools.test threads kernel
concurrency.combinators math ;
IN: threads.tests
3 "x" set
@ -16,3 +17,13 @@ yield
] unit-test
[ f ] [ f get-global ] unit-test
{ { 0 3 6 9 12 15 18 21 24 27 } } [
10 [
0 "i" tset
[
"i" [ yield 3 + ] tchange
] times yield
"i" tget
] parallel-map
] unit-test

2
core/threads/threads.factor
View File

@ -27,7 +27,7 @@ mailbox variables sleep-entry ;
tnamespace set-at ;
: tchange ( key quot -- )
tnamespace change-at ; inline
tnamespace swap change-at ; inline
: threads 41 getenv ;

2
extra/benchmark/dispatch2/dispatch2.factor
View File

@ -1,4 +1,4 @@
USING: namespaces math sequences splitting kernel ;
USING: namespaces math sequences splitting kernel columns ;
IN: benchmark.dispatch2
: sequences

2
extra/benchmark/dispatch3/dispatch3.factor
View File

@ -1,5 +1,5 @@
USING: sequences math mirrors splitting kernel namespaces
assocs alien.syntax ;
assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )

43
extra/benchmark/recursive/recursive.factor
View File

@ -1,38 +1,37 @@
USING: math kernel hints prettyprint io combinators ;
IN: benchmark.recursive
USING: math kernel hints prettyprint io ;
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ;
inline
: ack ( m n -- x )
over zero? [
nip 1+
] [
dup zero? [
drop 1- 1 ack
] [
dupd 1- ack >r 1- r> ack
] if
] if ;
{
{ [ over zero? ] [ nip 1+ ] }
{ [ dup zero? ] [ drop 1- 1 ack ] }
[ [ drop 1- ] [ 1- ack ] 2bi ack ]
} cond ; inline
: tak ( x y z -- t )
2over swap < [
[ rot 1- -rot tak ] 3keep
[ -rot 1- -rot tak ] 3keep
1- -rot tak
tak
] [
2over <= [
2nip
] if ;
] [
[ rot 1- -rot tak ]
[ -rot 1- -rot tak ]
[ 1- -rot tak ]
3tri
tak
] if ; inline
: recursive ( n -- )
3 over ack . flush
dup 27.0 + fib . flush
1-
dup 3 * over 2 * rot tak . flush
[ 3 swap ack . flush ]
[ 27.0 + fib . flush ]
[ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
HINTS: recursive fixnum ;
: recursive-main 11 recursive ;
MAIN: recursive-main

4
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -19,7 +19,7 @@ IN: benchmark.spectral-norm
pick 0.0 [
swap >r >r 2dup r> (eval-A-times-u) r> +
] reduce nip
] F{ } map-as 2nip ; inline
] F{ } map-as { float-array } declare 2nip ; inline
: (eval-At-times-u) ( u i j -- x )
tuck swap eval-A >r swap nth-unsafe r> * ; inline
@ -29,7 +29,7 @@ IN: benchmark.spectral-norm
pick 0.0 [
swap >r >r 2dup r> (eval-At-times-u) r> +
] reduce nip
] F{ } map-as 2nip ; inline
] F{ } map-as { float-array } declare 2nip ; inline
: eval-AtA-times-u ( n u -- seq )
dupd eval-A-times-u eval-At-times-u ; inline

9
core/bit-vectors/bit-vectors-docs.factor → extra/bit-vectors/bit-vectors-docs.factor
View File

@ -11,6 +11,8 @@ $nl
"Creating bit vectors:"
{ $subsection >bit-vector }
{ $subsection <bit-vector> }
"Literal syntax:"
{ $subsection POSTPONE: ?V{ }
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
{ $code "?V{ } clone" } ;
@ -31,3 +33,10 @@ HELP: bit-array>vector
{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
HELP: ?V{
{ $syntax "?V{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?V{ t f t }" } } ;

0
core/bit-vectors/bit-vectors-tests.factor → extra/bit-vectors/bit-vectors-tests.factor
View File

22
core/bit-vectors/bit-vectors.factor → extra/bit-vectors/bit-vectors.factor
View File

@ -1,9 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays ;
sequences.private growable bit-arrays prettyprint.backend
parser ;
IN: bit-vectors
TUPLE: bit-vector underlying fill ;
M: bit-vector underlying underlying>> { bit-array } declare ;
M: bit-vector set-underlying (>>underlying) ;
M: bit-vector length fill>> { array-capacity } declare ;
M: bit-vector set-fill (>>fill) ;
<PRIVATE
: bit-array>vector ( bit-array length -- bit-vector )
@ -14,7 +25,8 @@ PRIVATE>
: <bit-vector> ( n -- bit-vector )
<bit-array> 0 bit-array>vector ; inline
: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
: >bit-vector ( seq -- bit-vector )
T{ bit-vector f ?{ } 0 } clone-like ;
M: bit-vector like
drop dup bit-vector? [
@ -31,3 +43,9 @@ M: bit-vector equal?
M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
: ?V \ } [ >bit-vector ] parse-literal ; parsing
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;

0
core/bit-vectors/summary.txt → extra/bit-vectors/summary.txt
View File

0
core/bit-vectors/tags.txt → extra/bit-vectors/tags.txt
View File

10
core/byte-vectors/byte-vectors-docs.factor → extra/byte-vectors/byte-vectors-docs.factor
View File

@ -3,7 +3,7 @@ byte-vectors.private combinators ;
IN: byte-vectors
ARTICLE: "byte-vectors" "Byte vectors"
"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
$nl
"Byte vectors form a class:"
{ $subsection byte-vector }
@ -11,6 +11,8 @@ $nl
"Creating byte vectors:"
{ $subsection >byte-vector }
{ $subsection <byte-vector> }
"Literal syntax:"
{ $subsection POSTPONE: BV{ }
"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
{ $code "BV{ } clone" } ;
@ -32,3 +34,9 @@ HELP: byte-array>vector
{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;
HELP: BV{
{ $syntax "BV{ elements... }" }
{ $values { "elements" "a list of bytes" } }
{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "BV{ 1 2 3 12 }" } } ;

0
core/byte-vectors/byte-vectors-tests.factor → extra/byte-vectors/byte-vectors-tests.factor
View File

22
core/byte-vectors/byte-vectors.factor → extra/byte-vectors/byte-vectors.factor
View File

@ -1,9 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays ;
sequences.private growable byte-arrays prettyprint.backend
parser accessors ;
IN: byte-vectors
TUPLE: byte-vector underlying fill ;
M: byte-vector underlying underlying>> { byte-array } declare ;
M: byte-vector set-underlying (>>underlying) ;
M: byte-vector length fill>> { array-capacity } declare ;
M: byte-vector set-fill (>>fill) ;
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
@ -14,7 +25,8 @@ PRIVATE>
: <byte-vector> ( n -- byte-vector )
<byte-array> 0 byte-array>vector ; inline
: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;
: >byte-vector ( seq -- byte-vector )
T{ byte-vector f B{ } 0 } clone-like ;
M: byte-vector like
drop dup byte-vector? [
@ -31,3 +43,9 @@ M: byte-vector equal?
M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector >pprint-sequence ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

0
core/byte-vectors/summary.txt → extra/byte-vectors/summary.txt
View File

0
core/byte-vectors/tags.txt → extra/byte-vectors/tags.txt
View File

2
extra/columns/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Daniel Ehrenberg

26
extra/columns/columns-docs.factor Normal file
View File

@ -0,0 +1,26 @@
USING: help.markup help.syntax sequences ;
IN: columns
ARTICLE: "columns" "Column sequences"
"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
{ $subsection column }
{ $subsection <column> } ;
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
HELP: <column> ( seq n -- column )
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
"USING: arrays prettyprint sequences ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }"
}
}
{ $notes
"In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
} ;
ABOUT: "columns"

9
extra/columns/columns-tests.factor Normal file
View File

@ -0,0 +1,9 @@
IN: columns.tests
USING: columns sequences kernel namespaces arrays tools.test math ;
! Columns
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test

15
extra/columns/columns.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors ;
IN: columns
! A column of a matrix
TUPLE: column seq col ;
C: <column> column
M: column virtual-seq seq>> ;
M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
M: column length seq>> length ;
INSTANCE: column virtual-sequence

1
extra/columns/summary.txt Normal file
View File

@ -0,0 +1 @@
Virtual sequence view of a matrix column

0
core/float-vectors/tags.txt → extra/columns/tags.txt
View File

7
extra/editors/vim/vim.factor
View File

@ -1,5 +1,5 @@
USING: definitions io io.launcher kernel math math.parser
namespaces parser prettyprint sequences editors ;
namespaces parser prettyprint sequences editors accessors ;
IN: editors.vim
SYMBOL: vim-path
@ -17,8 +17,9 @@ M: vim vim-command ( file line -- array )
: vim-location ( file line -- )
vim-command
vim-detach get-global
[ run-detached ] [ run-process ] if drop ;
<process> swap >>command
vim-detach get-global [ t >>detached ] when
try-process ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global

8
core/float-vectors/float-vectors-docs.factor → extra/float-vectors/float-vectors-docs.factor
View File

@ -11,6 +11,8 @@ $nl
"Creating float vectors:"
{ $subsection >float-vector }
{ $subsection <float-vector> }
"Literal syntax:"
{ $subsection POSTPONE: FV{ }
"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
{ $code "FV{ } clone" } ;
@ -32,3 +34,9 @@ HELP: float-array>vector
{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }
{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }
{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;
HELP: FV{
{ $syntax "FV{ elements... }" }
{ $values { "elements" "a list of real numbers" } }
{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;

0
core/float-vectors/float-vectors-tests.factor → extra/float-vectors/float-vectors-tests.factor
View File

22
core/float-vectors/float-vectors.factor → extra/float-vectors/float-vectors.factor
View File

@ -1,9 +1,20 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable float-arrays ;
sequences.private growable float-arrays prettyprint.backend
parser ;
IN: float-vectors
TUPLE: float-vector underlying fill ;
M: float-vector underlying underlying>> { float-array } declare ;
M: float-vector set-underlying (>>underlying) ;
M: float-vector length fill>> { array-capacity } declare ;
M: float-vector set-fill (>>fill) ;
<PRIVATE
: float-array>vector ( float-array length -- float-vector )
@ -14,7 +25,8 @@ PRIVATE>
: <float-vector> ( n -- float-vector )
0.0 <float-array> 0 float-array>vector ; inline
: >float-vector ( seq -- float-vector ) FV{ } clone-like ;
: >float-vector ( seq -- float-vector )
T{ float-vector f F{ } 0 } clone-like ;
M: float-vector like
drop dup float-vector? [
@ -31,3 +43,9 @@ M: float-vector equal?
M: float-array new-resizable drop <float-vector> ;
INSTANCE: float-vector growable
: FV{ \ } [ >float-vector ] parse-literal ; parsing
M: float-vector >pprint-sequence ;
M: float-vector pprint-delims drop \ FV{ \ } ;

0
core/float-vectors/summary.txt → extra/float-vectors/summary.txt
View File

1
extra/float-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

6
extra/help/handbook/handbook.factor
View File

@ -145,9 +145,9 @@ ARTICLE: "collections" "Collections"
{ $subsection "vectors" }
"Resizable specialized sequences:"
{ $subsection "sbufs" }
{ $subsection "bit-vectors" }
{ $subsection "byte-vectors" }
{ $subsection "float-vectors" }
{ $vocab-subsection "Bit vectors" "bit-vectors" }
{ $vocab-subsection "Byte vectors" "byte-vectors" }
{ $vocab-subsection "Float vectors" "float-vectors" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
{ $subsection "namespaces" }

2
extra/help/help.factor
View File

@ -38,7 +38,7 @@ M: predicate word-help* drop \ $predicate ;
\ $error-description swap word-help elements empty? not ;
: sort-articles ( seq -- newseq )
[ dup article-title ] { } map>assoc sort-values 0 <column> ;
[ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
all-words [ error? ] subset sort-articles ;

2
extra/html/elements/elements.factor
View File

@ -161,6 +161,6 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media"
"media" "title"
] [ define-attribute-word ] each
] with-compilation-unit

3
extra/io/launcher/launcher-docs.factor
View File

@ -113,6 +113,8 @@ HELP: try-process
{ $values { "desc" "a launch descriptor" } }
{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
{ run-process try-process run-detached } related-words
HELP: kill-process
{ $values { "process" process } }
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
@ -171,6 +173,7 @@ ARTICLE: "io.launcher.launch" "Launching processes"
"Launching processes:"
{ $subsection run-process }
{ $subsection try-process }
{ $subsection run-detached }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream } ;

5
extra/io/launcher/launcher.factor
View File

@ -127,10 +127,7 @@ HOOK: run-process* io-backend ( process -- handle )
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
TUPLE: process-failed code ;
: process-failed ( code -- * )
\ process-failed boa throw ;
ERROR: process-failed code ;
: try-process ( desc -- )
run-process wait-for-process dup zero?

38
extra/locals/backend/backend-tests.factor Normal file
View File

@ -0,0 +1,38 @@
IN: locals.backend.tests
USING: tools.test locals.backend kernel arrays ;
[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
: get-local-test-1 3 >r 1 get-local r> drop ;
{ 0 1 } [ get-local-test-1 ] must-infer-as
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
{ 0 1 } [ get-local-test-2 ] must-infer-as
[ 4 ] [ get-local-test-2 ] unit-test
: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
{ 0 2 } [ get-local-test-3 ] must-infer-as
[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
{ 0 2 } [ get-local-test-4 ] must-infer-as
[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
: load-locals-test-1 1 2 2 load-locals r> r> ;
{ 0 2 } [ load-locals-test-1 ] must-infer-as
[ 1 2 ] [ load-locals-test-1 ] unit-test

37
extra/locals/backend/backend.factor Normal file
View File

@ -0,0 +1,37 @@
USING: math kernel slots.private inference.known-words
inference.backend sequences effects words ;
IN: locals.backend
: load-locals ( n -- )
dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
: get-local ( n -- value )
dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
: local-value 2 slot ; inline
: set-local-value 2 set-slot ; inline
: drop-locals ( n -- )
dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
\ load-locals [
pop-literal nip
[ dup reverse <effect> infer-shuffle ]
[ infer->r ]
bi
] "infer" set-word-prop
\ get-local [
pop-literal nip
[ infer-r> ]
[ dup 0 prefix <effect> infer-shuffle ]
[ infer->r ]
tri
] "infer" set-word-prop
\ drop-locals [
pop-literal nip
[ infer-r> ]
[ { } <effect> infer-shuffle ] bi
] "infer" set-word-prop

2
extra/locals/locals-tests.factor
View File

@ -82,6 +82,8 @@ IN: locals.tests
0 write-test-1 "q" set
{ 1 1 } "q" get must-infer-as
[ 1 ] [ 1 "q" get call ] unit-test
[ 2 ] [ 1 "q" get call ] unit-test

96
extra/locals/locals.factor
View File

@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables prettyprint.sections sets
sequences.private effects generic compiler.units accessors ;
sequences.private effects generic compiler.units accessors
locals.backend ;
IN: locals
! Inspired by
@ -56,95 +57,80 @@ TUPLE: quote local ;
C: <quote> quote
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read-local
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ;
: read-local ( obj args -- quot )
local-index 1+
dup [ r> ] <repetition> concat [ dup ] append
swap [ swap >r ] <repetition> concat append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! localize
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: read-local-quot ( obj args -- quot )
local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
>r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
>r "local-reader" word-prop r>
read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
{ [ over local? ] [ read-local ] }
{ [ over quote? ] [ >r quote-local r> read-local ] }
{ [ over local-word? ] [ read-local [ call ] append ] }
{ [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
{ [ over local? ] [ read-local-quot ] }
{ [ over quote? ] [ >r quote-local r> read-local-quot ] }
{ [ over local-word? ] [ read-local-quot [ call ] append ] }
{ [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! point-free
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
UNION: special local quote local-word local-reader local-writer ;
: load-local ( arg -- quot )
local-reader? [ 1array >r ] [ >r ] ? ;
: load-locals-quot ( args -- quot )
dup [ local-reader? ] contains? [
<reversed> [
local-reader? [ 1array >r ] [ >r ] ?
] map concat
] [
length [ load-locals ] curry >quotation
] if ;
: load-locals ( quot args -- quot )
nip <reversed> [ load-local ] map concat ;
: drop-locals ( args -- args quot )
dup length [ r> drop ] <repetition> concat ;
: drop-locals-quot ( args -- quot )
length [ drop-locals ] curry ;
: point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
[ drop-locals >r >r peek r> localize r> append ]
[ drop-locals nip swap peek suffix ]
[ dup drop-locals-quot >r >r peek r> localize r> append ]
[ dup drop-locals-quot nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
[ load-locals ] [ point-free-body ] [ point-free-end ]
[ nip load-locals-quot ]
[ point-free-body ]
[ point-free-end ]
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! free-vars
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
UNION: lexical local local-reader local-writer local-word ;
GENERIC: free-vars ( form -- vars )
GENERIC: free-vars* ( form -- )
: add-if-free ( vars object -- vars )
: free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
{
{ [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
{ [ dup lexical? ] [ suffix ] }
{ [ dup quote? ] [ quote-local suffix ] }
{ [ t ] [ free-vars append ] }
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
M: object free-vars drop { } ;
M: object free-vars* drop ;
M: quotation free-vars { } [ add-if-free ] reduce ;
M: quotation free-vars* [ add-if-free ] each ;
M: lambda free-vars
dup vars>> swap body>> free-vars diff ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! lambda-rewrite
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M: lambda free-vars*
[ vars>> ] [ body>> ] bi free-vars diff % ;
GENERIC: lambda-rewrite* ( obj -- )
@ -172,8 +158,8 @@ M: lambda block-vars vars>> ;
M: lambda block-body body>> ;
M: lambda local-rewrite*
dup vars>> swap body>>
[ local-rewrite* \ call , ] [ ] make <lambda> , ;
[ vars>> ] [ body>> ] bi
[ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
@ -188,8 +174,6 @@ M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-local ( name -- word )
"!" ?tail [
<local-reader>

2
extra/math/fft/fft.factor
View File

@ -1,7 +1,7 @@
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
math.functions kernel splitting ;
math.functions kernel splitting columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;

11
extra/math/functions/functions-docs.factor
View File

@ -7,6 +7,9 @@ ARTICLE: "integer-functions" "Integer functions"
{ $subsection gcd }
{ $subsection log2 }
{ $subsection next-power-of-2 }
"Modular exponentiation:"
{ $subsection ^mod }
{ $subsection mod-inv }
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
@ -33,7 +36,9 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
{ $subsection ceiling }
{ $subsection floor }
{ $subsection truncate }
{ $subsection round } ;
{ $subsection round }
"Inexact comparison:"
{ $subsection ~ } ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
@ -107,10 +112,6 @@ HELP: >rect
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: align
{ $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } }
{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." }

3
extra/math/functions/functions-tests.factor
View File

@ -81,9 +81,6 @@ IN: math.functions.tests
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test

3
extra/math/functions/functions.factor
View File

@ -102,9 +102,6 @@ M: real absq sq ;
[ ~abs ]
} cond ;
: power-of-2? ( n -- ? )
dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline

2
extra/math/haar/haar.factor
View File

@ -1,5 +1,5 @@
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
USING: sequences math kernel splitting ;
USING: sequences math kernel splitting columns ;
IN: math.haar
: averages ( seq -- seq )

17
extra/newfx/newfx.factor
View File

@ -155,6 +155,23 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prefix-on ( elt seq -- seq ) swap prefix ;
: suffix-on ( elt seq -- seq ) swap suffix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 1st 0 at ;
: 2nd 1 at ;
: 3rd 2 at ;
: 4th 3 at ;
: 5th 4 at ;
: 6th 5 at ;
: 7th 6 at ;
: 8th 7 at ;
: 9th 8 at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.

53
extra/project-euler/076/076.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators kernel math sequences math.ranges locals ;
IN: project-euler.076
! http://projecteuler.net/index.php?section=problems&id=76
! DESCRIPTION
! -----------
! How many different ways can one hundred be written as a
! sum of at least two positive integers?
! SOLUTION
! --------
! This solution uses dynamic programming and the following
! recurence relation:
! ways(0,_) = 1
! ways(_,0) = 0
! ways(n,i) = ways(n-i,i) + ways(n,i-1)
<PRIVATE
: init ( n -- table )
[1,b] [ 0 2array 0 ] H{ } map>assoc
1 { 0 0 } pick set-at ;
: use ( n i -- n i )
[ - dup ] keep min ; inline
: ways ( n i table -- )
over zero? [
3drop
] [
[ [ 1- 2array ] dip at ]
[ [ use 2array ] dip at + ]
[ [ 2array ] dip set-at ] 3tri
] if ;
:: each-subproblem ( n quot -- )
n [1,b] [ dup [1,b] quot with each ] each ; inline
PRIVATE>
: (euler076) ( n -- m )
dup init
[ [ ways ] curry each-subproblem ]
[ [ dup 2array ] dip at 1- ] 2bi ;
: euler076 ( -- m )
100 (euler076) ;

55
extra/project-euler/116/116.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.ranges sequences sequences.lib ;
IN: project-euler.116
! http://projecteuler.net/index.php?section=problems&id=116
! DESCRIPTION
! -----------
! A row of five black square tiles is to have a number of its tiles replaced
! with coloured oblong tiles chosen from red (length two), green (length
! three), or blue (length four).
! If red tiles are chosen there are exactly seven ways this can be done.
! If green tiles are chosen there are three ways.
! And if blue tiles are chosen there are two ways.
! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
! replacing the black tiles in a row measuring five units in length.
! How many different ways can the black tiles in a row measuring fifty units in
! length be replaced if colours cannot be mixed and at least one coloured tile
! must be used?
! SOLUTION
! --------
! This solution uses a simple dynamic programming approach using the
! following recurence relation
! ways(n,_) = 0 | n < 0
! ways(0,_) = 1
! ways(n,i) = ways(n-i,i) + ways(n-1,i)
! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
<PRIVATE
: nth* ( n seq -- elt/0 )
[ length swap - 1- ] keep ?nth 0 or ;
: next ( colortile seq -- )
[ nth* ] [ peek + ] [ push ] tri ;
: ways ( length colortile -- permutations )
V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
PRIVATE>
: (euler116) ( length -- permutations )
3 [1,b] [ ways ] with sigma ;
: euler116 ( -- permutations )
50 (euler116) ;

Some files were not shown because too many files have changed in this diff Show More