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

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

db4
Joe Groff 2010-01-15 14:03:46 -08:00
parent 3bc72151a8 7455981a0a
commit 235d7c9a14
330 changed files with 1930 additions and 2148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile
View File

@ -47,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/data_heap_checker.o \
vm/debug.o \
vm/dispatch.o \
vm/entry_points.o \
vm/errors.o \
vm/factor.o \
vm/free_list.o \

6
basis/alien/remote-control/remote-control.factor
View File

@ -19,8 +19,8 @@ IN: alien.remote-control
dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
\ yield-callback ?callback 17 setenv
\ sleep-callback ?callback 18 setenv ;
\ eval-callback ?callback 16 set-special-object
\ yield-callback ?callback 17 set-special-object
\ sleep-callback ?callback 18 set-special-object ;
MAIN: init-remote-control

5
basis/base64/base64.factor
View File

@ -13,7 +13,8 @@ ERROR: malformed-base64 ;
read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
: read-ignoring ( ignoring n -- str )
[ drop read1-ignoring ] with map harvest
[ drop read1-ignoring ] with { } map-integers
[ { f 0 } member? not ] filter
[ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
@ -42,7 +43,7 @@ SYMBOL: column
[ write1-lines ] each ;
: encode3 ( seq -- )
be> 4 <reversed> [
be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline

4
basis/binary-search/binary-search-tests.factor
View File

@ -1,4 +1,4 @@
USING: binary-search math.order vectors kernel tools.test ;
USING: binary-search math.order sequences kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
@ -7,7 +7,7 @@ IN: binary-search.tests
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test

2
basis/bit-arrays/bit-arrays-tests.factor
View File

@ -40,7 +40,7 @@ IN: bit-arrays.tests
100 [
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] all-integers?
] unit-test
[ ?{ f } ] [

6
basis/bit-arrays/bit-arrays.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
@ -25,7 +25,7 @@ TUPLE: bit-array
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
] if ;
: bit-array>integer ( bit-array -- n )
0 swap underlying>> dup length <reversed> [
0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -4,7 +4,7 @@ IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each ;
1234 swap [ [ even? ] dip push ] curry each-integer ;
[ t ] [
3 <bit-vector> dup do-it

109
basis/bootstrap/image/image.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.binary io.files io.encodings.binary
@ -93,7 +93,7 @@ CONSTANT: image-version 4
CONSTANT: data-base 1024
CONSTANT: userenv-size 70
CONSTANT: special-objects-size 70
CONSTANT: header-size 10
@ -155,7 +155,7 @@ SYMBOL: jit-literals
: define-sub-primitive ( quot word -- )
[ make-jit 3array ] dip sub-primitives get set-at ;
: define-sub-primitive* ( quot non-tail-quot tail-quot word -- )
: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
[
[ make-jit ]
[ make-jit 2nip ]
@ -176,54 +176,58 @@ SYMBOL: architecture
RESET
! Boot quotation, set in stage1.factor
USERENV: bootstrap-startup-quot 20
SPECIAL-OBJECT: bootstrap-startup-quot 20
! Bootstrap global namesapce
USERENV: bootstrap-global 21
SPECIAL-OBJECT: bootstrap-global 21
! JIT parameters
USERENV: jit-prolog 23
USERENV: jit-primitive-word 24
USERENV: jit-primitive 25
USERENV: jit-word-jump 26
USERENV: jit-word-call 27
USERENV: jit-if-word 28
USERENV: jit-if 29
USERENV: jit-epilog 30
USERENV: jit-return 31
USERENV: jit-profiling 32
USERENV: jit-push 33
USERENV: jit-dip-word 34
USERENV: jit-dip 35
USERENV: jit-2dip-word 36
USERENV: jit-2dip 37
USERENV: jit-3dip-word 38
USERENV: jit-3dip 39
USERENV: jit-execute 40
USERENV: jit-declare-word 41
SPECIAL-OBJECT: jit-prolog 23
SPECIAL-OBJECT: jit-primitive-word 24
SPECIAL-OBJECT: jit-primitive 25
SPECIAL-OBJECT: jit-word-jump 26
SPECIAL-OBJECT: jit-word-call 27
SPECIAL-OBJECT: jit-if-word 28
SPECIAL-OBJECT: jit-if 29
SPECIAL-OBJECT: jit-epilog 30
SPECIAL-OBJECT: jit-return 31
SPECIAL-OBJECT: jit-profiling 32
SPECIAL-OBJECT: jit-push 33
SPECIAL-OBJECT: jit-dip-word 34
SPECIAL-OBJECT: jit-dip 35
SPECIAL-OBJECT: jit-2dip-word 36
SPECIAL-OBJECT: jit-2dip 37
SPECIAL-OBJECT: jit-3dip-word 38
SPECIAL-OBJECT: jit-3dip 39
SPECIAL-OBJECT: jit-execute 40
SPECIAL-OBJECT: jit-declare-word 41
USERENV: callback-stub 48
SPECIAL-OBJECT: c-to-factor-word 42
SPECIAL-OBJECT: lazy-jit-compile-word 43
SPECIAL-OBJECT: unwind-native-frames-word 44
SPECIAL-OBJECT: callback-stub 48
! PIC stubs
USERENV: pic-load 49
USERENV: pic-tag 50
USERENV: pic-tuple 51
USERENV: pic-check-tag 52
USERENV: pic-check-tuple 53
USERENV: pic-hit 54
USERENV: pic-miss-word 55
USERENV: pic-miss-tail-word 56
SPECIAL-OBJECT: pic-load 49
SPECIAL-OBJECT: pic-tag 50
SPECIAL-OBJECT: pic-tuple 51
SPECIAL-OBJECT: pic-check-tag 52
SPECIAL-OBJECT: pic-check-tuple 53
SPECIAL-OBJECT: pic-hit 54
SPECIAL-OBJECT: pic-miss-word 55
SPECIAL-OBJECT: pic-miss-tail-word 56
! Megamorphic dispatch
USERENV: mega-lookup 57
USERENV: mega-lookup-word 58
USERENV: mega-miss-word 59
SPECIAL-OBJECT: mega-lookup 57
SPECIAL-OBJECT: mega-lookup-word 58
SPECIAL-OBJECT: mega-miss-word 59
! Default definition for undefined words
USERENV: undefined-quot 60
SPECIAL-OBJECT: undefined-quot 60
: userenv-offset ( symbol -- n )
userenvs get at header-size + ;
: special-object-offset ( symbol -- n )
special-objects get at header-size + ;
: emit ( cell -- ) image get push ;
@ -239,7 +243,7 @@ USERENV: undefined-quot 60
: fixup ( value offset -- ) image get set-nth ;
: heap-size ( -- size )
image get length header-size - userenv-size -
image get length header-size - special-objects-size -
bootstrap-cells ;
: here ( -- size ) heap-size data-base + ;
@ -278,10 +282,10 @@ GENERIC: ' ( obj -- ptr )
0 emit ! pointer to bignum 0
0 emit ! pointer to bignum 1
0 emit ! pointer to bignum -1
userenv-size [ f ' emit ] times ;
special-objects-size [ f ' emit ] times ;
: emit-userenv ( symbol -- )
[ get ' ] [ userenv-offset ] bi fixup ;
: emit-special-object ( symbol -- )
[ get ' ] [ special-object-offset ] bi fixup ;
! Bignums
@ -534,15 +538,18 @@ M: quotation '
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
\ inline-cache-miss \ pic-miss-word set
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
\ inline-cache-miss pic-miss-word set
\ inline-cache-miss-tail pic-miss-tail-word set
\ mega-cache-lookup mega-lookup-word set
\ mega-cache-miss mega-miss-word set
\ declare jit-declare-word set
\ c-to-factor c-to-factor-word set
\ lazy-jit-compile lazy-jit-compile-word set
\ unwind-native-frames unwind-native-frames-word set
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
userenvs get keys [ emit-userenv ] each ;
: emit-special-objects ( -- )
special-objects get keys [ emit-special-object ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
@ -559,8 +566,8 @@ M: quotation '
emit-jit-data
"Serializing global namespace..." print flush
emit-global
"Serializing user environment..." print flush
emit-userenvs
"Serializing special object table..." print flush
emit-special-objects
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush

10
basis/bootstrap/image/syntax/syntax.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces assocs words.symbol ;
IN: bootstrap.image.syntax
SYMBOL: userenvs
SYMBOL: special-objects
SYNTAX: RESET H{ } clone userenvs set-global ;
SYNTAX: RESET H{ } clone special-objects set-global ;
SYNTAX: USERENV:
SYNTAX: SPECIAL-OBJECT:
CREATE-WORD scan-word
[ swap userenvs get set-at ]
[ swap special-objects get set-at ]
[ drop define-symbol ]
2bi ;

3
basis/calendar/calendar.factor
View File

@ -554,7 +554,8 @@ M: integer end-of-year 12 31 <date> ;
: unix-time>timestamp ( seconds -- timestamp )
seconds unix-1970 time+ ;
M: duration sleep duration>nanoseconds nano-count + sleep-until ;
M: duration sleep
duration>nanoseconds >integer nano-count + sleep-until ;
{
{ [ os unix? ] [ "calendar.unix" ] }

6
basis/calendar/format/format.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
@ -70,7 +70,7 @@ M: array month. ( pair -- )
[
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each nl ;
] with each-integer nl ;
M: timestamp month. ( timestamp -- )
[ year>> ] [ month>> ] bi 2array month. ;
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1 + 2array month. nl ] with each ;
12 [ 1 + 2array month. nl ] with each-integer ;
M: timestamp year. ( timestamp -- )
year>> year. ;

4
basis/checksums/sha/sha.factor
View File

@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
M cloned-H sha2 T1-256
cloned-H T2-256
cloned-H update-H
] each
] each-integer
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
M: sha2-short checksum-block
@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
] each
] each-integer
state [ H [ w+ ] 2map ] change-H drop ; inline
M:: sha1-state checksum-block ( bytes state -- )

3
basis/classes/struct/bit-accessors/bit-accessors-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
USING: classes.struct.bit-accessors tools.test effects kernel
sequences random stack-checker ;
IN: classes.struct.bit-accessors.test
[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test

2
basis/cocoa/application/application.factor
View File

@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
[ [ objc-error ] 19 setenv ] "cocoa.application" add-startup-hook
[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
: running.app? ( -- ? )
#! Test if we're running a .app.

4
basis/cocoa/messages/messages.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
@ -202,7 +202,7 @@ ERROR: no-objc-type name ;
(free) ;
: method-arg-types ( method -- args )
dup method_getNumberOfArguments
dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )

2
basis/columns/columns-tests.factor
View File

@ -7,3 +7,5 @@ IN: columns.tests
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test

4
basis/columns/columns.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors ;
IN: columns
@ -15,4 +15,4 @@ M: column length seq>> length ;
INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
dup empty? [ dup first length [ <column> ] with map ] unless ;
dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;

20
basis/combinators/smart/smart.factor
View File

@ -5,49 +5,49 @@ stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
dup infer out>> '[ @ _ ndrop ] ;
dup outputs '[ @ _ ndrop ] ;
MACRO: keep-inputs ( quot -- quot' )
dup infer in>> '[ _ _ nkeep ] ;
dup inputs '[ _ _ nkeep ] ;
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
[ dup outputs ] dip
'[ @ _ _ nsequence ] ;
MACRO: output>array ( quot -- newquot )
'[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
[ inputs ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
[ infer in>> ] keep
[ inputs ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
[ dup outputs 1 [-] ] dip n*quot compose ;
MACRO: sum-outputs ( quot -- n )
'[ _ [ + ] reduce-outputs ] ;
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
[ dup infer out>> ] 2dip
[ dup outputs ] 2dip
[ swap '[ _ _ napply ] ]
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
'[ @ @ @ ] ;
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
[ dup outputs ] dip '[ @ _ _ nappend-as ] ;
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
MACRO: preserving ( quot -- )
[ infer in>> length ] keep '[ _ ndup @ ] ;
[ inputs ] keep '[ _ ndup @ ] ;
MACRO: nullary ( quot -- quot' )
dup infer out>> length '[ @ _ ndrop ] ;
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline

3
basis/command-line/command-line.factor
View File

@ -8,7 +8,8 @@ IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
: (command-line) ( -- args )
10 special-object sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless

3
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture layouts
@ -17,6 +17,7 @@ GENERIC: compute-stack-frame* ( insn -- )
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
##alien-assembly
##alien-callback ;
M: stack-frame-insn compute-stack-frame*

3
basis/compiler/cfg/builder/builder.factor
View File

@ -236,6 +236,9 @@ M: #alien-invoke emit-node
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-assembly emit-node
[ ##alien-assembly ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[

3
basis/compiler/cfg/instructions/instructions.factor
View File

@ -671,6 +671,9 @@ literal: params stack-frame ;
INSN: ##alien-indirect
literal: params stack-frame ;
INSN: ##alien-assembly
literal: params stack-frame ;
INSN: ##alien-callback
literal: params stack-frame ;

6
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser accessors effects namespaces
@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ;
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
boa-effect in>> but-last { } <effect> ;
: define-insn-tuple ( class superclass specs -- )
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
[ name>> ] map f <effect> define-declared ;
[ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {

4
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -30,7 +30,7 @@ IN: compiler.cfg.intrinsics
{
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:getenv [ emit-getenv ] }
{ kernel.private:special-object [ emit-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }

4
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -9,8 +9,8 @@ IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
"userenv" ^^vm-field-ptr
: emit-special-object ( node -- )
"special-objects" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;

4
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -110,7 +110,7 @@ MACRO: vvvv-vector-op ( trials -- )
blub ;
MACRO: can-has-case ( cases -- )
dup first second infer in>> length 1 +
dup first second inputs 1 +
'[ _ ndrop f ] suffix '[ _ case ] ;
GENERIC# >can-has-trial 1 ( obj #pick -- quot )
@ -118,7 +118,7 @@ GENERIC# >can-has-trial 1 ( obj #pick -- quot )
M: callable >can-has-trial
drop '[ _ can-has? ] ;
M: pair >can-has-trial
swap first2 dup infer in>> length
swap first2 dup inputs
'[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ;
MACRO: can-has-vector-op ( trials #pick #dup -- )

3
basis/compiler/cfg/save-contexts/save-contexts.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit
compiler.cfg.instructions compiler.cfg.registers
@ -14,6 +14,7 @@ IN: compiler.cfg.save-contexts
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
[ ##alien-assembly? ]
} 1||
] any? ;

4
basis/compiler/cfg/stacks/stacks.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel namespaces accessors biassocs compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
@ -33,7 +33,7 @@ IN: compiler.cfg.stacks
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
[ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[

4
basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences byte-arrays namespaces accessors classes math
math.order fry arrays combinators compiler.cfg.registers
@ -55,7 +55,7 @@ M: insn visit-insn drop ;
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
[ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
[ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
PRIVATE>

16
basis/compiler/codegen/codegen.factor
View File

@ -380,7 +380,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
: prepare-unbox-parameters ( parameters -- offsets types indices )
[ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
[ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
: unbox-parameters ( offset node -- )
parameters>> swap
@ -436,6 +436,16 @@ M: ##alien-invoke generate-insn
dup %cleanup
box-return* ;
M: ##alien-assembly generate-insn
params>>
! Unbox parameters
dup objects>registers
%prepare-var-args
! Generate assembly
dup quot>> call( -- )
! Box return value
box-return* ;
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
@ -464,7 +474,7 @@ M: ##alien-indirect generate-insn
TUPLE: callback-context ;
: current-callback ( -- id ) 2 getenv ;
: current-callback ( -- id ) 2 special-object ;
: wait-to-return ( token -- )
dup current-callback eq? [
@ -475,7 +485,7 @@ TUPLE: callback-context ;
: do-callback ( quot token -- )
init-catchstack
[ 2 setenv call ] keep
[ 2 set-special-object call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )

9
basis/compiler/codegen/fixup/fixup.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order generalizations
accessors growable fry compiler.constants ;
accessors growable fry compiler.constants memoize ;
IN: compiler.codegen.fixup
! Owner
@ -52,8 +52,11 @@ SYMBOL: relocation-table
: rel-fixup ( class type -- )
swap compiled-offset add-relocation-entry ;
! Caching common symbol names reduces image size a bit
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: add-dlsym-parameters ( symbol dll -- )
[ string>symbol add-parameter ] [ add-parameter ] bi* ;
[ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
: rel-dlsym ( name dll class -- )
[ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;

7
basis/compiler/constants/constants.factor
View File

@ -25,6 +25,13 @@ CONSTANT: deck-bits 18
: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0

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

@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
float
@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
@ -316,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
@ -377,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
void { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
@ -591,3 +589,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
[ ] [ assembly-test-1 ] unit-test

4
basis/compiler/tests/codegen.factor
View File

@ -116,7 +116,7 @@ unit-test
1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
[ t ] [
10000000 [ drop try-breaking-dispatch-2 ] all?
10000000 [ drop try-breaking-dispatch-2 ] all-integers?
] unit-test
! Regression
@ -314,7 +314,7 @@ cell 4 = [
! Bug with ##return node construction
: return-recursive-bug ( nodes -- ? )
{ fixnum } declare [
{ fixnum } declare iota [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
return-recursive-bug

27
basis/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;
math.private tools.test math.floats.private math.order fry ;
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
@ -84,11 +84,6 @@ IN: compiler.tests.float
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
@ -100,3 +95,23 @@ IN: compiler.tests.float
[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
! Ensure that float-min and min, and float-max and max, have
! consistent behavior with respect to NaNs
: two-floats ( a b -- a b ) { float float } declare ; inline
[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test
[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
: check-compiled-binary-op ( a b word -- )
[ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
[ '[ _ execute ] ]
bi 2bi fp-bitwise= ; inline
[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test

6
basis/compiler/tests/intrinsics.factor
View File

@ -54,8 +54,8 @@ IN: compiler.tests.intrinsics
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ ] [ [ 0 special-object ] compile-call drop ] unit-test
[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ [ 1 drop ] compile-call ] unit-test
@ -337,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ;
[ ] [
10000 [
5 random [ drop 32 random-bits ] map product >bignum
5 random iota [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if
] times

24
basis/compiler/tests/optimizer.factor
View File

@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler definitions generic.single shuffle ;
compiler definitions generic.single shuffle math.order ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
@ -90,7 +90,7 @@ TUPLE: pred-test ;
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test
[ 0 ] [ 10 iota double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
@ -208,7 +208,7 @@ USE: binary-search.private
] if ; inline recursive
[ 10 ] [
10 20 >vector <flat-slice>
10 20 iota <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
@ -349,7 +349,7 @@ TUPLE: some-tuple x ;
[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
@ -445,5 +445,17 @@ M: object bad-dispatch-position-test* ;
[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
: grid-mesh-test-case ( -- vertices )
1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa
1 f <array>
[
[ drop length>> >fixnum 2 min ] 2keep
[
[ step>> 1 * ] dip
0 swap set-nth-unsafe
] 2curry times
] keep ;
[ { 0.5 } ] [ grid-mesh-test-case ] unit-test

4
basis/compiler/tree/checker/checker.factor
View File

@ -185,9 +185,7 @@ M: #recursive check-stack-flow*
M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-callback check-stack-flow* drop ;

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

@ -339,28 +339,23 @@ cell-bits 32 = [
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
[ { fixnum } declare iota [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
[ { fixnum } declare iota 0 [ + ] reduce ]
{ < <-integer-fixnum nth-unsafe } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
[ { fixnum } declare iota 0 [ + ] reduce ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare [ ] map
{ integer } declare iota [ ] map
] \ >fixnum inlined?
] unit-test
@ -403,7 +398,7 @@ cell-bits 32 = [
[ t ] [
[
{ integer } declare [ 0 >= ] map
{ integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test

4
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
@ -36,7 +36,7 @@ M: #branch remove-dead-code*
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ length make-values ] keep
[ drop ] [ zip ] 2bi
#data-shuffle ;

6
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
@ -24,7 +24,7 @@ M: #call-recursive compute-live-values*
:: drop-dead-inputs ( inputs outputs -- #shuffle )
inputs filter-live
outputs inputs filter-corresponding make-values
outputs inputs filter-corresponding length make-values
outputs
inputs
drop-values ;
@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code*
2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
inputs outputs filter-corresponding make-values :> new-live-outputs
inputs outputs filter-corresponding length make-values :> new-live-outputs
outputs filter-live :> live-outputs
new-live-outputs
live-outputs

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

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
fry locals definitions classes classes.algebra generic
@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ;
M: #call mark-live-values*
dup flushable-call? [ drop ] [ look-at-inputs ] if ;
M: #alien-invoke mark-live-values* look-at-inputs ;
M: #alien-indirect mark-live-values* look-at-inputs ;
M: #alien-node mark-live-values* look-at-inputs ;
M: #return mark-live-values* look-at-inputs ;
@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ;
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
M: #alien-invoke compute-live-values* nip look-at-inputs ;
M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #alien-node compute-live-values* nip look-at-inputs ;
: filter-mapping ( assoc -- assoc' )
live-values get '[ drop _ key? ] assoc-filter ;
@ -71,7 +67,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
outputs make-values :> new-outputs
outputs length make-values :> new-outputs
outputs filter-live :> live-outputs
new-outputs
live-outputs
@ -127,8 +123,5 @@ M: #terminate remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-in-r ;
M: #alien-invoke remove-dead-code*
maybe-drop-dead-outputs ;
M: #alien-indirect remove-dead-code*
M: #alien-node remove-dead-code*
maybe-drop-dead-outputs ;

6
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
@ -64,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map <effect> ;
mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
@ -126,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
M: #alien-callback node>quot params>> , \ #alien-callback , ;
M: node node>quot drop ;

4
basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel tools.test namespaces sequences
USING: kernel tools.test namespaces sequences math
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.recursive.tests
@ -6,7 +6,7 @@ IN: compiler.tree.escape-analysis.recursive.tests
H{ } clone allocations set
<escaping-values> escaping-values set
[ ] [ 8 [ introduce-value ] each ] unit-test
[ ] [ 8 [ introduce-value ] each-integer ] unit-test
[ ] [ { 1 2 } 3 record-allocation ] unit-test

7
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -86,12 +86,7 @@ M: #call escape-analysis*
M: #return escape-analysis*
in-d>> add-escaping-values ;
M: #alien-invoke escape-analysis*
[ in-d>> add-escaping-values ]
[ out-d>> unknown-allocations ]
bi ;
M: #alien-indirect escape-analysis*
M: #alien-node escape-analysis*
[ in-d>> add-escaping-values ]
[ out-d>> unknown-allocations ]
bi ;

4
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

@ -73,7 +73,7 @@ TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[
{ fixnum } declare 0 swap
{ fixnum } declare iota 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
@ -94,7 +94,7 @@ TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[
{ integer } declare [ 256 mod ] map
{ integer } declare iota [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test

9
basis/compiler/tree/normalization/normalization.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math math.order accessors kernel arrays
combinators assocs
@ -75,10 +75,9 @@ M: #phi normalize*
] with-variable ;
M: #recursive normalize*
dup label>> introductions>>
[ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
[ make-values '[ _ (normalize) ] change-child ]
2bi ;
[ [ child>> first ] [ in-d>> ] bi >>in-d drop ]
[ dup label>> introductions>> make-values '[ _ (normalize) ] change-child ]
bi ;
M: #enter-recursive normalize*
[ introduction-stack get prepend ] change-out-d

10
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
words math stack-checker combinators.short-circuit
USING: accessors arrays combinators combinators.private effects
fry kernel kernel.private make sequences continuations
quotations words math stack-checker combinators.short-circuit
stack-checker.transforms compiler.tree.propagation.info
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
@ -43,7 +43,7 @@ M: +unknown+ curry-effect ;
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
effect boa ;
[ [ "x" <array> ] bi@ ] dip effect boa ;
M: curry cached-effect
quot>> cached-effect curry-effect ;

7
basis/compiler/tree/propagation/info/info-tests.factor
View File

@ -4,13 +4,6 @@ IN: compiler.tree.propagation.info.tests
[ f ] [ 0.0 -0.0 eql? ] unit-test
[ t ] [
number <class-info>
sequence <class-info>
value-info-intersect
class>> integer class=
] unit-test
[ t t ] [
0 10 [a,b] <interval-info>
5 20 [a,b] <interval-info>

7
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private
math.integers.private math.floats.private math.partial-dispatch
@ -23,11 +23,10 @@ IN: compiler.tree.propagation.known-words
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
{ /f < > <= >= u< u> u<= u>= }
{ /f /i mod < > <= >= u< u> u<= u>= }
[ { real real } "input-classes" set-word-prop ] each
{ /i mod /mod }
[ { rational rational } "input-classes" set-word-prop ] each
\ /mod { rational rational } "input-classes" set-word-prop
{ bitand bitor bitxor bitnot shift }
[ { integer integer } "input-classes" set-word-prop ] each

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

@ -1,14 +1,13 @@
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.recursive
compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays system sorting math.libm
compiler.tree.normalization tools.test math math.order accessors
sequences arrays kernel.private vectors alien.accessors
alien.c-types sequences.private byte-arrays classes.algebra
classes.tuple.private math.functions math.private strings
layouts compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker slots.private words
hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private
math.intervals quotations effects alien alien.data ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
@ -91,6 +90,8 @@ IN: compiler.tree.propagation.tests
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
[ V{ integer float } ] [ [ { float float } declare [ /i ] keep ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
[ V{ fixnum } ] [
@ -405,14 +406,6 @@ IN: compiler.tree.propagation.tests
] final-literals
] unit-test
[ V{ 27 } ] [
[
dup number? over sequence? and [
dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
] [ "B" throw ] if
] final-literals
] unit-test
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
@ -680,7 +673,7 @@ M: array iterate first t ; inline
] unit-test
[ V{ fixnum } ] [
[ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
[ { fixnum fixnum } declare iota [ nth-unsafe ] curry call ] final-classes
] unit-test
[ V{ f } ] [
@ -942,3 +935,14 @@ M: tuple-with-read-only-slot clone
! Could be bignum not integer but who cares
[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
[ t ] [ [ { fixnum fixnum } declare min ] { min } inlined? ] unit-test
[ f ] [ [ { fixnum fixnum } declare min ] { fixnum-min } inlined? ] unit-test
[ t ] [ [ { float float } declare min ] { min } inlined? ] unit-test
[ f ] [ [ { float float } declare min ] { float-min } inlined? ] unit-test
[ t ] [ [ { fixnum fixnum } declare max ] { max } inlined? ] unit-test
[ f ] [ [ { fixnum fixnum } declare max ] { fixnum-max } inlined? ] unit-test
[ t ] [ [ { float float } declare max ] { max } inlined? ] unit-test
[ f ] [ [ { float float } declare max ] { float-max } inlined? ] unit-test

6
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -80,7 +80,7 @@ M: #declare propagate-before
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
'[ _ _ with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
[ drop length [ object-info ] replicate ]
recover ;
: fold-call ( #call word -- )
@ -153,8 +153,6 @@ M: #call propagate-after
[ out-d>> ] [ params>> return>> ] bi
[ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
M: #alien-invoke propagate-before propagate-alien-invoke ;
M: #alien-indirect propagate-before propagate-alien-invoke ;
M: #alien-node propagate-before propagate-alien-invoke ;
M: #return annotate-node dup in-d>> (annotate-node) ;

26
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel sequences words fry generic accessors
classes.tuple classes classes.algebra definitions
@ -132,26 +132,6 @@ IN: compiler.tree.propagation.transforms
] "custom-inlining" set-word-prop
] each
! Integrate this with generic arithmetic optimization instead?
: both-inputs? ( #call class -- ? )
[ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
\ min [
{
{ [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
{ [ dup float both-inputs? ] [ [ float-min ] ] }
[ f ]
} cond nip
] "custom-inlining" set-word-prop
\ max [
{
{ [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
{ [ dup float both-inputs? ] [ [ float-max ] ] }
[ f ]
} cond nip
] "custom-inlining" set-word-prop
! Generate more efficient code for common idiom
\ clone [
in-d>> first value-info literal>> {
@ -209,7 +189,7 @@ ERROR: bad-partial-eval quot word ;
\ index [
dup sequence? [
dup length 4 >= [
dup length zip >hashtable '[ _ at ]
dup length iota zip >hashtable '[ _ at ]
] [ drop f ] if
] [ drop f ] if
] 1 define-partial-eval
@ -248,7 +228,7 @@ CONSTANT: lookup-table-at-max 256
} 1&& ;
: lookup-table-seq ( assoc -- table )
[ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
[ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ;
: lookup-table-quot ( seq -- newquot )
lookup-table-seq

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

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals classes
@ -149,7 +149,12 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ;
: #alien-indirect ( params -- node )
\ #alien-indirect new-alien-node ;
TUPLE: #alien-callback < #alien-node ;
TUPLE: #alien-assembly < #alien-node in-d out-d ;
: #alien-assembly ( params -- node )
\ #alien-assembly new-alien-node ;
TUPLE: #alien-callback < node params ;
: #alien-callback ( params -- node )
\ #alien-callback new
@ -187,4 +192,5 @@ M: vector #recursive, #recursive node, ;
M: vector #copy, #copy node, ;
M: vector #alien-invoke, #alien-invoke node, ;
M: vector #alien-indirect, #alien-indirect node, ;
M: vector #alien-assembly, #alien-assembly node, ;
M: vector #alien-callback, #alien-callback node, ;

4
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -164,9 +164,7 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ;
M: #alien-callback unbox-tuples* ;

14
basis/compression/inflate/inflate.factor
View File

@ -36,7 +36,7 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
5 bitstream bs:read 1 +
4 bitstream bs:read 4 + clen-shuffle swap head
dup length iota [ 3 bitstream bs:read ] replicate
dup length [ 3 bitstream bs:read ] replicate
get-table
bitstream swap <huffman-decoder>
[ 2dup + ] dip swap :> k!
@ -64,13 +64,13 @@ CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
MEMO: static-huffman-tables ( -- obj )
[
0 143 [a,b] [ 8 ] replicate
144 255 [a,b] [ 9 ] replicate append
256 279 [a,b] [ 7 ] replicate append
280 287 [a,b] [ 8 ] replicate append
0 143 [a,b] length [ 8 ] replicate
144 255 [a,b] length [ 9 ] replicate append
256 279 [a,b] length [ 7 ] replicate append
280 287 [a,b] length [ 8 ] replicate append
] append-outputs
0 31 [a,b] [ 5 ] replicate 2array
[ [ length>> [0,b) ] [ ] bi get-table ] map ;
0 31 [a,b] length [ 5 ] replicate 2array
[ [ length>> iota ] [ ] bi get-table ] map ;
CONSTANT: length-table
{

5
basis/compression/zlib/zlib-tests.factor
View File

@ -1,9 +1,12 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test compression.zlib classes ;
USING: accessors kernel tools.test compression.zlib classes ;
QUALIFIED-WITH: compression.zlib.ffi ffi
IN: compression.zlib.tests
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
[ t ] [ compress-me compress compressed instance? ] unit-test
[ ffi:Z_DATA_ERROR zlib-error-message ] [ string>> "data error" = ] must-fail-with

4
basis/compression/zlib/zlib.factor
View File

@ -19,7 +19,9 @@ ERROR: zlib-failed n string ;
dup compression.zlib.ffi:Z_ERRNO = [
drop errno "native libc error"
] [
dup {
dup
neg ! zlib error codes are negative
{
"no error" "libc_error"
"stream error" "data error"
"memory error" "buffer error" "zlib version error"

6
basis/concurrency/combinators/combinators-tests.factor
View File

@ -17,12 +17,12 @@ IN: concurrency.combinators.tests
[ error>> "Even" = ] must-fail-with
[ V{ 0 3 6 9 } ]
[ 10 [ 3 mod zero? ] parallel-filter ] unit-test
[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test
[ 10 ]
[
V{ } clone
10 over [ push ] curry parallel-each
10 iota over [ push ] curry parallel-each
length
] unit-test
@ -41,7 +41,7 @@ IN: concurrency.combinators.tests
[ 20 ]
[
V{ } clone
10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each
length
] unit-test

2
basis/cpu/architecture/architecture.factor
View File

@ -550,7 +550,7 @@ HOOK: %save-param-reg cpu ( stack reg rep -- )
HOOK: %load-param-reg cpu ( stack reg rep -- )
HOOK: %load-context cpu ( temp1 temp2 -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
HOOK: %save-context cpu ( temp1 temp2 -- )

193
basis/cpu/ppc/bootstrap.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
compiler.constants math math.private layouts words vocabs
slots.private locals locals.backend generic.single.private fry ;
compiler.constants math math.private math.ranges layouts words vocabs
slots.private locals locals.backend generic.single.private fry
sequences ;
FROM: cpu.ppc.assembler => B ;
IN: bootstrap.ppc
@ -13,28 +14,88 @@ big-endian on
CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
CONSTANT: vm-reg 15
CONSTANT: ctx-reg 16
: factor-area-size ( -- n ) 4 bootstrap-cells ;
: factor-area-size ( -- n ) 16 ;
: stack-frame ( -- n )
factor-area-size c-area-size + 4 bootstrap-cells align ;
reserved-size
factor-area-size +
16 align ;
: next-save ( -- n ) stack-frame bootstrap-cell - ;
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
: next-save ( -- n ) stack-frame 4 - ;
: xt-save ( -- n ) stack-frame 8 - ;
: param-size ( -- n ) 32 ;
: save-at ( m -- n ) reserved-size + param-size + ;
: save-int ( register offset -- ) [ 1 ] dip save-at STW ;
: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;
: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;
: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;
: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;
: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;
: nv-int-regs ( -- seq ) 13 31 [a,b] ;
: nv-fp-regs ( -- seq ) 14 31 [a,b] ;
: nv-vec-regs ( -- seq ) 20 31 [a,b] ;
: saved-int-regs-size ( -- n ) 96 ;
: saved-fp-regs-size ( -- n ) 144 ;
: saved-vec-regs-size ( -- n ) 208 ;
: callback-frame-size ( -- n )
reserved-size
param-size +
saved-int-regs-size +
saved-fp-regs-size +
saved-vec-regs-size +
16 align ;
[
0 MFLR
1 1 callback-frame-size neg STWU
0 1 callback-frame-size lr-save + STW
nv-int-regs [ 4 * save-int ] each-index
nv-fp-regs [ 8 * 80 + save-fp ] each-index
nv-vec-regs [ 16 * 224 + save-vec ] each-index
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel
2 MTLR
BLRL
nv-vec-regs [ 16 * 224 + restore-vec ] each-index
nv-fp-regs [ 8 * 80 + restore-fp ] each-index
nv-int-regs [ 4 * restore-int ] each-index
0 1 callback-frame-size lr-save + LWZ
1 1 0 LWZ
0 MTLR
BLR
] callback-stub jit-define
: jit-conditional* ( test-quot false-quot -- )
[ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline
[ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline
: jit-load-context ( -- )
ctx-reg vm-reg vm-context-offset LWZ ;
: jit-save-context ( -- )
4 vm-reg 0 LWZ
1 4 0 STW
ds-reg 4 8 STW
rs-reg 4 12 STW ;
jit-load-context
1 ctx-reg context-callstack-top-offset STW
ds-reg ctx-reg context-datastack-offset STW
rs-reg ctx-reg context-retainstack-offset STW ;
: jit-restore-context ( -- )
4 vm-reg 0 LWZ
ds-reg 4 8 LWZ
rs-reg 4 12 LWZ ;
jit-load-context
ds-reg ctx-reg context-datastack-offset LWZ
rs-reg ctx-reg context-retainstack-offset LWZ ;
[
0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
@ -48,12 +109,12 @@ CONSTANT: vm-reg 15
] jit-profiling jit-define
[
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
3 1 xt-save STW
stack-frame 3 LI
3 1 next-save STW
2 1 xt-save STW
stack-frame 2 LI
2 1 next-save STW
0 1 lr-save stack-frame + STW
] jit-prolog jit-define
@ -181,7 +242,7 @@ CONSTANT: vm-reg 15
load-tag
0 4 tuple type-number tag-fixnum CMPI
[ BNE ]
[ 4 3 tuple type-number neg bootstrap-cell + LWZ ]
[ 4 3 tuple type-number neg 4 + LWZ ]
jit-conditional*
] pic-tuple jit-define
@ -215,12 +276,12 @@ CONSTANT: vm-reg 15
[ jit-load-return-address jit-inline-cache-miss ]
[ 3 MTLR BLRL ]
[ 3 MTCTR BCTR ]
\ inline-cache-miss define-sub-primitive*
\ inline-cache-miss define-combinator-primitive
[ jit-inline-cache-miss ]
[ 3 MTLR BLRL ]
[ 3 MTCTR BCTR ]
\ inline-cache-miss-tail define-sub-primitive*
\ inline-cache-miss-tail define-combinator-primitive
! ! ! Megamorphic caches
@ -230,7 +291,7 @@ CONSTANT: vm-reg 15
! key = hashcode(class)
5 4 1 SRAWI
! key &= cache.length - 1
5 5 mega-cache-size get 1 - bootstrap-cell * ANDI
5 5 mega-cache-size get 1 - 4 * ANDI
! cache += array-start-offset
3 3 array-start-offset ADDI
! cache += key
@ -245,7 +306,7 @@ CONSTANT: vm-reg 15
5 4 0 LWZ
5 5 1 ADDI
5 4 0 STW
! ... goto get(cache + bootstrap-cell)
! ... goto get(cache + 4)
3 3 4 LWZ
3 3 word-xt-offset LWZ
3 MTCTR
@ -255,23 +316,16 @@ CONSTANT: vm-reg 15
! fall-through on miss
] mega-lookup jit-define
[
0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel
2 MTCTR
BCTR
] callback-stub jit-define
! ! ! Sub-primitives
! Quotations and words
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 vm-reg MR
5 3 quot-xt-offset LWZ
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ] \ (call) define-sub-primitive*
[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive
[
3 ds-reg 0 LWZ
@ -279,7 +333,7 @@ CONSTANT: vm-reg 15
4 3 word-xt-offset LWZ
]
[ 4 MTLR BLRL ]
[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive*
[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive
[
3 ds-reg 0 LWZ
@ -288,6 +342,79 @@ CONSTANT: vm-reg 15
4 MTCTR BCTR
] jit-execute jit-define
! Special primitives
[
jit-restore-context
! Save ctx->callstack_bottom
1 ctx-reg context-callstack-bottom-offset STW
! Call quotation
5 3 quot-xt-offset LWZ
5 MTLR
BLRL
jit-save-context
] \ c-to-factor define-sub-primitive
[
! Unwind stack frames
1 4 MR
! Load VM pointer into vm-reg, since we're entering from
! C code
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
! Load ds and rs registers
jit-restore-context
! We have changed the stack; load return address again
0 1 lr-save LWZ
0 MTLR
! Call quotation
4 3 quot-xt-offset LWZ
4 MTCTR
BCTR
] \ unwind-native-frames define-sub-primitive
[
! Load callstack object
6 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
! Get ctx->callstack_bottom
jit-load-context
3 ctx-reg context-callstack-bottom-offset LWZ
! Get top of callstack object -- 'src' for memcpy
4 6 callstack-top-offset ADDI
! Get callstack length, in bytes --- 'len' for memcpy
5 6 callstack-length-offset LWZ
5 5 tag-bits get SRAWI
! Compute new stack pointer -- 'dst' for memcpy
3 5 3 SUBF
! Install new stack pointer
1 3 MR
! Call memcpy; arguments are now in the correct registers
1 1 -64 STWU
0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
1 1 0 LWZ
! Return with new callstack
0 1 lr-save LWZ
0 MTLR
BLR
] \ set-callstack define-sub-primitive
[
jit-save-context
4 vm-reg MR
0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym
2 MTLR
BLRL
5 3 quot-xt-offset LWZ
]
[ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ]
\ lazy-jit-compile define-combinator-primitive
! Objects
[
3 ds-reg 0 LWZ

8
basis/cpu/ppc/linux/bootstrap.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser layouts system kernel sequences ;
USING: parser system kernel sequences ;
IN: bootstrap.ppc
: c-area-size ( -- n ) 10 bootstrap-cells ;
: lr-save ( -- n ) bootstrap-cell ;
: reserved-size ( -- n ) 24 ;
: lr-save ( -- n ) 4 ;
<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
call

8
basis/cpu/ppc/macosx/bootstrap.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser layouts system kernel sequences ;
USING: parser system kernel sequences ;
IN: bootstrap.ppc
: c-area-size ( -- n ) 14 bootstrap-cells ;
: lr-save ( -- n ) 2 bootstrap-cells ;
: reserved-size ( -- n ) 24 ;
: lr-save ( -- n ) 8 ;
<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
call

43
basis/cpu/ppc/ppc.factor
View File

@ -83,8 +83,8 @@ HOOK: reserved-area-size os ( -- n )
! The start of the stack frame contains the size of this frame
! as well as the currently executing XT
: factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ;
: xt-save ( n -- i ) 2 cells - ;
: next-save ( n -- i ) cell - ; foldable
: xt-save ( n -- i ) 2 cells - ; foldable
! Next, we have the spill area as well as the FFI parameter area.
! It is safe for them to overlap, since basic blocks with FFI calls
@ -126,7 +126,7 @@ M: ppc stack-frame-size ( stack-frame -- i )
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
M: ppc %jump ( word -- )
0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
0 B rc-relative-ppc-3 rel-word-pic-tail ;
M: ppc %jump-label ( label -- ) B ;
@ -134,7 +134,7 @@ M: ppc %return ( -- ) BLR ;
M:: ppc %dispatch ( src temp -- )
0 temp LOAD32
4 cells rc-absolute-ppc-2/2 rel-here
3 cells rc-absolute-ppc-2/2 rel-here
temp temp src LWZX
temp MTCTR
BCTR ;
@ -564,14 +564,16 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
: next-param@ ( n -- reg x )
2 1 stack-frame get total-size>> LWZ
[ 2 ] dip param@ ;
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
{ float-rep [ [ 1 ] dip STFS ] }
{ double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
{ stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
M: ppc %spill ( src rep dst -- )
@ -679,10 +681,15 @@ M: ppc %box-large-struct ( n c-type -- )
! Call the function
"from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 "ctx" %load-vm-field-addr
temp1 temp1 0 LWZ
temp2 1 stack-frame get total-size>> ADDI
temp2 temp1 "callstack-bottom" context-field-offset STW
ds-reg temp1 8 LWZ
rs-reg temp1 12 LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
temp1 "ctx" %load-vm-field-addr
temp1 temp1 0 LWZ
1 temp1 0 STW
@ -693,13 +700,18 @@ M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 4 %restore-context
3 swap %load-reference
4 %load-vm-addr
"c_to_factor" f %alien-invoke ;
4 3 quot-xt-offset LWZ
4 MTLR
BLRL
3 4 %save-context ;
M: ppc %prepare-alien-indirect ( -- )
3 %load-vm-addr
"from_alien" f %alien-invoke
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
4 %load-vm-addr
"pinned_alien_offset" f %alien-invoke
16 3 MR ;
M: ppc %alien-indirect ( -- )
@ -753,9 +765,7 @@ M: ppc %box-small-struct ( c-type -- )
3 3 0 LWZ ;
M: ppc %nest-stacks ( -- )
! Save current frame. See comment in vm/contexts.hpp
3 1 stack-frame get total-size>> 2 cells - ADDI
4 %load-vm-addr
3 %load-vm-addr
"nest_stacks" f %alien-invoke ;
M: ppc %unnest-stacks ( -- )
@ -763,7 +773,6 @@ M: ppc %unnest-stacks ( -- )
"unnest_stacks" f %alien-invoke ;
M: ppc %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }

7
basis/cpu/x86/32/32-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: cpu.x86.32.tests
USING: alien alien.c-types tools.test cpu.x86.assembler
cpu.x86.assembler.operands ;
: assembly-test-1 ( -- x ) int { } "cdecl" [ EAX 3 MOV ] alien-assembly ;
[ 3 ] [ assembly-test-1 ] unit-test

12
basis/cpu/x86/32/32.factor
View File

@ -8,7 +8,8 @@ compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture ;
cpu.architecture vm ;
FROM: layouts => cell ;
IN: cpu.x86.32
M: x86.32 machine-registers
@ -23,6 +24,12 @@ M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@ -235,9 +242,8 @@ M: x86.32 %alien-indirect ( -- )
EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
EAX EDX %load-context
EAX EDX %restore-context
EAX swap %load-reference
EDX %mov-vm-ptr
EAX quot-xt-offset [+] CALL
EAX EDX %save-context ;

158
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler cpu.x86.assembler.operands layouts
@ -19,6 +19,8 @@ IN: bootstrap.x86
: safe-reg ( -- reg ) EAX ;
: stack-reg ( -- reg ) ESP ;
: frame-reg ( -- reg ) EBP ;
: vm-reg ( -- reg ) ECX ;
: ctx-reg ( -- reg ) EBP ;
: nv-regs ( -- seq ) { ESI EDI EBX } ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
@ -35,49 +37,122 @@ IN: bootstrap.x86
] jit-prolog jit-define
: jit-load-vm ( -- )
EBP 0 MOV 0 rc-absolute-cell jit-vm ;
vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
: jit-load-context ( -- )
! VM pointer must be in vm-reg already
ctx-reg vm-reg vm-context-offset [+] MOV ;
: jit-save-context ( -- )
! VM pointer must be in EBP already
ECX EBP [] MOV
! save ctx->callstack_top
EAX ESP -4 [+] LEA
ECX [] EAX MOV
! save ctx->datastack
ECX 8 [+] ds-reg MOV
! save ctx->retainstack
ECX 12 [+] rs-reg MOV ;
EDX RSP -4 [+] LEA
ctx-reg context-callstack-top-offset [+] EDX MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
! VM pointer must be in EBP already
ECX EBP [] MOV
! restore ctx->datastack
ds-reg ECX 8 [+] MOV
! restore ctx->retainstack
rs-reg ECX 12 [+] MOV ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
jit-load-vm
! save ds, rs registers
jit-load-context
jit-save-context
! call the primitive
ESP [] EBP MOV
ESP [] vm-reg MOV
0 CALL rc-relative rt-primitive jit-rel
! restore ds, rs registers
jit-restore-context
] jit-primitive jit-define
[
! load from stack
! Load quotation
EAX EBP 8 [+] MOV
! save ctx->callstack_bottom, load ds, rs registers
jit-load-vm
jit-load-context
jit-restore-context
EDX stack-reg stack-frame-size 4 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] EDX MOV
! call the quotation
EAX quot-xt-offset [+] CALL
! save ds, rs registers
jit-save-context
] \ c-to-factor define-sub-primitive
[
EAX ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! load VM pointer
EDX 0 MOV 0 rc-absolute-cell jit-vm
]
[ EAX quot-xt-offset [+] CALL ]
[ EAX quot-xt-offset [+] JMP ]
\ (call) define-sub-primitive*
\ (call) define-combinator-primitive
[
! Clear x87 stack, but preserve rounding mode and exception flags
ESP 2 SUB
ESP [] FNSTCW
FNINIT
ESP [] FLDCW
ESP 2 ADD
! Load arguments
EAX ESP stack-frame-size [+] MOV
EDX ESP stack-frame-size 4 + [+] MOV
! Unwind stack frames
ESP EDX MOV
! Load ds and rs registers
jit-load-vm
jit-load-context
jit-restore-context
! Call quotation
EAX quot-xt-offset [+] JMP
] \ unwind-native-frames define-sub-primitive
[
! Load callstack object
EBX ds-reg [] MOV
ds-reg bootstrap-cell SUB
! Get ctx->callstack_bottom
jit-load-vm
jit-load-context
EAX ctx-reg context-callstack-bottom-offset [+] MOV
! Get top of callstack object -- 'src' for memcpy
EBP EBX callstack-top-offset [+] LEA
! Get callstack length, in bytes --- 'len' for memcpy
EDX EBX callstack-length-offset [+] MOV
EDX tag-bits get SHR
! Compute new stack pointer -- 'dst' for memcpy
EAX EDX SUB
! Install new stack pointer
ESP EAX MOV
! Call memcpy
EDX PUSH
EBP PUSH
EAX PUSH
0 CALL "factor_memcpy" f rc-relative jit-dlsym
ESP 12 ADD
! Return with new callstack
0 RET
] \ set-callstack define-sub-primitive
[
jit-load-vm
jit-load-context
jit-save-context
! Store arguments
ESP [] EAX MOV
ESP 4 [+] vm-reg MOV
! Call VM
0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
]
[ EAX quot-xt-offset [+] CALL ]
[ EAX quot-xt-offset [+] JMP ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
: jit-load-return-address ( -- )
@ -87,8 +162,9 @@ IN: bootstrap.x86
! frame, and the stack. The frame setup takes this into account.
: jit-inline-cache-miss ( -- )
jit-load-vm
jit-load-context
jit-save-context
ESP 4 [+] EBP MOV
ESP 4 [+] vm-reg MOV
ESP [] EBX MOV
0 CALL "inline_cache_miss" f rc-relative jit-dlsym
jit-restore-context ;
@ -96,28 +172,29 @@ IN: bootstrap.x86
[ jit-load-return-address jit-inline-cache-miss ]
[ EAX CALL ]
[ EAX JMP ]
\ inline-cache-miss define-sub-primitive*
\ inline-cache-miss define-combinator-primitive
[ jit-inline-cache-miss ]
[ EAX CALL ]
[ EAX JMP ]
\ inline-cache-miss-tail define-sub-primitive*
\ inline-cache-miss-tail define-combinator-primitive
! Overflowing fixnum arithmetic
: jit-overflow ( insn func -- )
ds-reg 4 SUB
jit-load-vm
jit-load-context
jit-save-context
EAX ds-reg [] MOV
EDX ds-reg 4 [+] MOV
ECX EAX MOV
[ [ ECX EDX ] dip call( dst src -- ) ] dip
ds-reg [] ECX MOV
EBX EAX MOV
[ [ EBX EDX ] dip call( dst src -- ) ] dip
ds-reg [] EBX MOV
[ JNO ]
[
ESP [] EAX MOV
ESP 4 [+] EDX MOV
ESP 8 [+] EBP MOV
ESP 8 [+] vm-reg MOV
[ 0 CALL ] dip f rc-relative jit-dlsym
]
jit-conditional ;
@ -129,19 +206,20 @@ IN: bootstrap.x86
[
ds-reg 4 SUB
jit-load-vm
jit-load-context
jit-save-context
ECX ds-reg [] MOV
EAX ECX MOV
EBX ds-reg 4 [+] MOV
EBX tag-bits get SAR
EBX IMUL
EBX ds-reg [] MOV
EAX EBX MOV
EBP ds-reg 4 [+] MOV
EBP tag-bits get SAR
EBP IMUL
ds-reg [] EAX MOV
[ JNO ]
[
ECX tag-bits get SAR
ESP [] ECX MOV
ESP 4 [+] EBX MOV
ESP 8 [+] EBP MOV
EBX tag-bits get SAR
ESP [] EBX MOV
ESP 4 [+] EBP MOV
ESP 8 [+] vm-reg MOV
0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
]
jit-conditional

15
basis/cpu/x86/64/64-tests.factor Normal file
View File

@ -0,0 +1,15 @@
USING: alien alien.c-types cpu.architecture cpu.x86.64
cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
IN: cpu.x86.64.tests
: assembly-test-1 ( -- x ) int { } "cdecl" [ RAX 3 MOV ] alien-assembly ;
[ 3 ] [ assembly-test-1 ] unit-test
: assembly-test-2 ( a b -- x )
int { int int } "cdecl" [
param-reg-0 param-reg-1 ADD
int-regs return-reg param-reg-0 MOV
] alien-assembly ;
[ 23 ] [ 17 6 assembly-test-2 ] unit-test

16
basis/cpu/x86/64/64.factor
View File

@ -7,7 +7,8 @@ compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.intrinsics compiler.cfg.stack-frame
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
cpu.architecture ;
cpu.architecture vm ;
FROM: layouts => cell cells ;
IN: cpu.x86.64
: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
@ -29,13 +30,21 @@ M: x86.64 extra-stack-space drop 0 ;
M: x86.64 machine-registers
{
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 } }
{ float-regs {
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
} }
} ;
: vm-reg ( -- reg ) R13 ; inline
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
M: x86.64 %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
M: x86.64 %prologue ( n -- )
@ -223,9 +232,8 @@ M: x86.64 %alien-indirect ( -- )
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
param-reg-0 param-reg-1 %load-context
param-reg-0 param-reg-1 %restore-context
param-reg-0 swap %load-reference
param-reg-1 %mov-vm-ptr
param-reg-0 quot-xt-offset [+] CALL
param-reg-0 param-reg-1 %save-context ;

128
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system layouts vocabs parser compiler.constants math
@ -15,9 +15,12 @@ IN: bootstrap.x86
: temp1 ( -- reg ) RSI ;
: temp2 ( -- reg ) RDX ;
: temp3 ( -- reg ) RBX ;
: return-reg ( -- reg ) RAX ;
: safe-reg ( -- reg ) RAX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
: ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) temp0 1 SAR ;
@ -25,60 +28,114 @@ IN: bootstrap.x86
[
! load XT
RDI 0 MOV rc-absolute-cell rt-this jit-rel
safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push XT
RDI PUSH
safe-reg PUSH
! alignment
RSP stack-frame-size 3 bootstrap-cells - SUB
] jit-prolog jit-define
: jit-load-vm ( -- )
RBP 0 MOV 0 rc-absolute-cell jit-vm ;
: jit-load-context ( -- )
ctx-reg vm-reg vm-context-offset [+] MOV ;
: jit-save-context ( -- )
! VM pointer must be in RBP already
RCX RBP [] MOV
! save ctx->callstack_top
RAX RSP -8 [+] LEA
RCX [] RAX MOV
! save ctx->datastack
RCX 16 [+] ds-reg MOV
! save ctx->retainstack
RCX 24 [+] rs-reg MOV ;
jit-load-context
safe-reg RSP -8 [+] LEA
ctx-reg context-callstack-top-offset [+] safe-reg MOV
ctx-reg context-datastack-offset [+] ds-reg MOV
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
! VM pointer must be in EBP already
RCX RBP [] MOV
! restore ctx->datastack
ds-reg RCX 16 [+] MOV
! restore ctx->retainstack
rs-reg RCX 24 [+] MOV ;
jit-load-context
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
jit-load-vm
! save ds, rs registers
jit-save-context
! call the primitive
arg1 RBP MOV
arg1 vm-reg MOV
RAX 0 MOV rc-absolute-cell rt-primitive jit-rel
RAX CALL
! restore ds, rs registers
jit-restore-context
] jit-primitive jit-define
[
! load from stack
jit-restore-context
! save ctx->callstack_bottom
safe-reg stack-reg stack-frame-size 8 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
! call the quotation
arg1 quot-xt-offset [+] CALL
jit-save-context
] \ c-to-factor define-sub-primitive
[
arg1 ds-reg [] MOV
! pop stack
ds-reg bootstrap-cell SUB
! load VM pointer
arg2 0 MOV 0 rc-absolute-cell jit-vm
]
[ arg1 quot-xt-offset [+] CALL ]
[ arg1 quot-xt-offset [+] JMP ]
\ (call) define-sub-primitive*
\ (call) define-combinator-primitive
[
! Clear x87 stack, but preserve rounding mode and exception flags
RSP 2 SUB
RSP [] FNSTCW
FNINIT
RSP [] FLDCW
! Unwind stack frames
RSP arg2 MOV
! Load VM pointer into vm-reg, since we're entering from
! C code
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
! Load ds and rs registers
jit-restore-context
! Call quotation
arg1 quot-xt-offset [+] JMP
] \ unwind-native-frames define-sub-primitive
[
! Load callstack object
arg4 ds-reg [] MOV
ds-reg bootstrap-cell SUB
! Get ctx->callstack_bottom
jit-load-context
arg1 ctx-reg context-callstack-bottom-offset [+] MOV
! Get top of callstack object -- 'src' for memcpy
arg2 arg4 callstack-top-offset [+] LEA
! Get callstack length, in bytes --- 'len' for memcpy
arg3 arg4 callstack-length-offset [+] MOV
arg3 tag-bits get SHR
! Compute new stack pointer -- 'dst' for memcpy
arg1 arg3 SUB
! Install new stack pointer
RSP arg1 MOV
! Call memcpy; arguments are now in the correct registers
! Create register shadow area for Win64
RSP 32 SUB
safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
safe-reg CALL
! Tear down register shadow area
RSP 32 ADD
! Return with new callstack
0 RET
] \ set-callstack define-sub-primitive
[
jit-save-context
arg2 vm-reg MOV
safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
safe-reg CALL
]
[ return-reg quot-xt-offset [+] CALL ]
[ return-reg quot-xt-offset [+] JMP ]
\ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points
: jit-load-return-address ( -- )
@ -87,10 +144,9 @@ IN: bootstrap.x86
! These are always in tail position with an existing stack
! frame, and the stack. The frame setup takes this into account.
: jit-inline-cache-miss ( -- )
jit-load-vm
jit-save-context
arg1 RBX MOV
arg2 RBP MOV
arg2 vm-reg MOV
RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
RAX CALL
jit-restore-context ;
@ -98,17 +154,16 @@ IN: bootstrap.x86
[ jit-load-return-address jit-inline-cache-miss ]
[ RAX CALL ]
[ RAX JMP ]
\ inline-cache-miss define-sub-primitive*
\ inline-cache-miss define-combinator-primitive
[ jit-inline-cache-miss ]
[ RAX CALL ]
[ RAX JMP ]
\ inline-cache-miss-tail define-sub-primitive*
\ inline-cache-miss-tail define-combinator-primitive
! Overflowing fixnum arithmetic
: jit-overflow ( insn func -- )
ds-reg 8 SUB
jit-load-vm
jit-save-context
arg1 ds-reg [] MOV
arg2 ds-reg 8 [+] MOV
@ -117,7 +172,7 @@ IN: bootstrap.x86
ds-reg [] arg3 MOV
[ JNO ]
[
arg3 RBP MOV
arg3 vm-reg MOV
RAX 0 MOV f rc-absolute-cell jit-dlsym
RAX CALL
]
@ -129,7 +184,6 @@ IN: bootstrap.x86
[
ds-reg 8 SUB
jit-load-vm
jit-save-context
RCX ds-reg [] MOV
RBX ds-reg 8 [+] MOV
@ -142,7 +196,7 @@ IN: bootstrap.x86
arg1 RCX MOV
arg1 tag-bits get SAR
arg2 RBX MOV
arg3 RBP MOV
arg3 vm-reg MOV
RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
RAX CALL
]

8
basis/cpu/x86/assembler/assembler.factor
View File

@ -375,6 +375,7 @@ PRIVATE>
: NOP ( -- ) HEX: 90 , ;
: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
: RDTSC ( -- ) HEX: 0f , HEX: 31 , ;
: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
@ -385,6 +386,13 @@ PRIVATE>
: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
: FNSTCW ( operand -- ) { BIN: 111 f HEX: d9 } 1-operand ;
: FNSTSW ( operand -- ) { BIN: 111 f HEX: dd } 1-operand ;
: FLDCW ( operand -- ) { BIN: 101 f HEX: d9 } 1-operand ;
: FNCLEX ( -- ) HEX: db , HEX: e2 , ;
: FNINIT ( -- ) HEX: db , HEX: e3 , ;
! SSE multimedia instructions
<PRIVATE

7
basis/cpu/x86/bootstrap.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private compiler.constants
compiler.units cpu.x86.assembler cpu.x86.assembler.operands
@ -30,6 +30,9 @@ big-endian off
! hurt on other platforms
stack-reg 32 SUB
! Load VM into vm-reg
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
! Call into Factor code
safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel
safe-reg CALL
@ -169,7 +172,7 @@ big-endian off
]
[ temp0 word-xt-offset [+] CALL ]
[ temp0 word-xt-offset [+] JMP ]
\ (execute) define-sub-primitive*
\ (execute) define-combinator-primitive
[
temp0 ds-reg [] MOV

88
basis/cpu/x86/features/features.factor
View File

@ -1,21 +1,78 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel memoize math math.order math.parser
namespaces alien.c-types alien.syntax combinators locals init io
compiler compiler.units accessors ;
USING: accessors alien alien.c-types combinators compiler
compiler.codegen.fixup compiler.units cpu.architecture
cpu.x86.assembler cpu.x86.assembler.operands init io kernel
locals math math.order math.parser memoize namespaces system ;
IN: cpu.x86.features
<PRIVATE
FUNCTION: int sse_version ( ) ;
: (sse-version) ( -- n )
int { } "cdecl" [
"sse-42" define-label
"sse-41" define-label
"ssse-3" define-label
"sse-3" define-label
"sse-2" define-label
"sse-1" define-label
"end" define-label
FUNCTION: longlong read_timestamp_counter ( ) ;
int-regs return-reg 1 MOV
CPUID
ECX HEX: 100000 TEST
"sse-42" get JNE
ECX HEX: 80000 TEST
"sse-41" get JNE
ECX HEX: 200 TEST
"ssse-3" get JNE
ECX HEX: 1 TEST
"sse-3" get JNE
EDX HEX: 4000000 TEST
"sse-2" get JNE
EDX HEX: 2000000 TEST
"sse-1" get JNE
int-regs return-reg 0 MOV
"end" get JMP
"sse-42" resolve-label
int-regs return-reg 42 MOV
"end" get JMP
"sse-41" resolve-label
int-regs return-reg 41 MOV
"end" get JMP
"ssse-3" resolve-label
int-regs return-reg 33 MOV
"end" get JMP
"sse-3" resolve-label
int-regs return-reg 30 MOV
"end" get JMP
"sse-2" resolve-label
int-regs return-reg 20 MOV
"end" get JMP
"sse-1" resolve-label
int-regs return-reg 10 MOV
"end" resolve-label
] alien-assembly ;
PRIVATE>
MEMO: sse-version ( -- n )
sse_version
"sse-version" get string>number [ min ] when* ;
(sse-version) "sse-version" get string>number [ min ] when* ;
[ \ sse-version reset-memoized ] "cpu.x86.features" add-startup-hook
@ -39,7 +96,18 @@ MEMO: sse-version ( -- n )
HOOK: instruction-count cpu ( -- n )
M: x86 instruction-count read_timestamp_counter ;
M: x86.32 instruction-count
longlong { } "cdecl" [
RDTSC
] alien-assembly ;
M: x86.64 instruction-count
longlong { } "cdecl" [
RAX 0 MOV
RDTSC
RDX 32 SHL
RAX RDX OR
] alien-assembly ;
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
instruction-count [ call instruction-count ] dip - ; inline

30
basis/cpu/x86/x86.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
@ -419,11 +419,7 @@ M: x86 %shl int-rep two-operand [ SHL ] emit-shift ;
M: x86 %shr int-rep two-operand [ SHR ] emit-shift ;
M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
: %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
HOOK: %mov-vm-ptr cpu ( reg -- )
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
@ -1410,18 +1406,15 @@ M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M:: x86 %load-context ( temp1 temp2 -- )
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
#! Also save callstack bottom!
temp1 "ctx" %vm-field-ptr
temp1 temp1 [] MOV
! callstack_bottom
temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
temp1 1 cells [+] temp2 MOV
! datastack
ds-reg temp1 2 cells [+] MOV
! retainstack
rs-reg temp1 3 cells [+] MOV ;
temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
@ -1429,13 +1422,10 @@ M:: x86 %save-context ( temp1 temp2 -- )
#! all roots.
temp1 "ctx" %vm-field-ptr
temp1 temp1 [] MOV
! callstack_top
temp2 stack-reg cell neg [+] LEA
temp1 [] temp2 MOV
! datastack
temp1 2 cells [+] ds-reg MOV
! retainstack
temp1 3 cells [+] rs-reg MOV ;
temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV
temp1 "retainstack" context-field-offset [+] rs-reg MOV ;
M: x86 value-struct? drop t ;
@ -1475,6 +1465,6 @@ enable-fixnum-log2
] when ;
: check-sse ( -- )
[ { sse_version } compile ] with-optimizer
[ { (sse-version) } compile ] with-optimizer
"Checking for multimedia extensions: " write sse-version
[ sse-string write " detected" print ] [ enable-sse2 ] bi ;

4
basis/db/db.factor
View File

@ -100,10 +100,10 @@ M: object execute-statement* ( statement type -- )
t >>bound? drop ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
dup #columns [ row-column ] with { } map-integers ;
: sql-row-typed ( result-set -- seq )
dup #columns [ row-column-typed ] with map ;
dup #columns [ row-column-typed ] with { } map-integers ;
: query-each ( statement quot: ( statement -- ) -- )
over more-rows? [

2
basis/db/queries/queries.factor
View File

@ -34,7 +34,7 @@ SINGLETON: retryable
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [ retries>> ] [
drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]

4
basis/db/tester/tester.factor
View File

@ -67,7 +67,7 @@ test-2 "TEST2" {
test-2 ensure-table
] with-db
] [
10 [
10 iota [
drop
10 [
dup [
@ -85,7 +85,7 @@ test-2 "TEST2" {
] with-db
] [
<db-pool> [
10 [
10 iota [
10 [
test-1-tuple insert-tuple yield
] times

2
basis/farkup/farkup-tests.factor
View File

@ -205,7 +205,7 @@ link-no-follow? off
100 [
drop random-markup
[ convert-farkup drop t ] [ drop print f ] recover
] all?
] all-integers?
] unit-test
[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test

2
basis/fry/fry-tests.factor
View File

@ -64,7 +64,7 @@ SYMBOLS: a b c d e f g h ;
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
3 1 '[ _ [ _ + ] map ] call
3 1 '[ _ iota [ _ + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [

2
basis/generalizations/generalizations-tests.factor
View File

@ -64,7 +64,7 @@ IN: generalizations.tests
{ 3 5 } [ 2 nweave ] must-infer-as
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test

4
basis/grouping/grouping-docs.factor
View File

@ -52,7 +52,7 @@ HELP: <groups>
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
"9 iota >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
@ -67,7 +67,7 @@ HELP: <sliced-groups>
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <sliced-groups>"
"9 iota >array 3 <sliced-groups>"
"dup [ reverse! drop ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}

10
basis/heaps/heaps-tests.factor
View File

@ -31,7 +31,7 @@ IN: heaps.tests
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
[
iota [
drop 32 random-bits dup number>string
] H{ } map>assoc ;
@ -40,16 +40,16 @@ IN: heaps.tests
14 [
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
] each
] each-integer
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
data>> dup length swap [ index>> ] map sequence= ;
data>> dup length iota swap [ index>> ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
] each
] each-integer
: sort-entries ( entries -- entries' )
[ key>> ] sort-with ;
@ -66,4 +66,4 @@ IN: heaps.tests
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
] each
] each-integer

4
basis/hints/hints.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
@ -24,7 +24,7 @@ M: object specializer-declaration class ;
"specializer" word-prop ;
: make-specializer ( specs -- quot )
dup length <reversed>
dup length iota <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [

4
basis/images/jpeg/jpeg.factor
View File

@ -137,7 +137,7 @@ TUPLE: jpeg-color-info
data>>
binary
[
read1 [0,b)
read1 iota
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
@ -198,7 +198,7 @@ MEMO: yuv>bgr-matrix ( -- m )
{ 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
MEMO: dct-matrix ( -- m ) 64 iota [ 8 /mod dct-vect flatten ] map ;
: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;

2
basis/images/png/png.factor
View File

@ -120,7 +120,7 @@ ERROR: unimplemented-color-type image ;
prev width tail-slice :> b
curr :> a
curr width tail-slice :> x
x length [0,b)
x length iota
filter {
{ filter-none [ drop ] }
{ filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }

6
basis/images/processing/processing.factor
View File

@ -6,7 +6,7 @@ math.ranges math.vectors sequences sequences.deep fry ;
IN: images.processing
: coord-matrix ( dim -- m )
[ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;
[ iota ] map first2 [ [ 2array ] with map ] curry map ;
: map^2 ( m quot -- m' ) '[ _ map ] map ; inline
: each^2 ( m quot -- m' ) '[ _ each ] each ; inline
@ -16,7 +16,7 @@ IN: images.processing
: matrix>image ( m -- image )
<image> over matrix-dim >>dim
swap flip flatten
[ 128 * 128 + 0 max 255 min >fixnum ] map
[ 128 * 128 + 0 255 clamp >fixnum ] map
>byte-array >>bitmap L >>component-order ubyte-components >>component-type ;
:: matrix-zoom ( m f -- m' )
@ -30,7 +30,7 @@ IN: images.processing
:: draw-grey ( value x,y image -- )
x,y image image-offset 3 * { 0 1 2 }
[
+ value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth
+ value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth
] with each ;
:: draw-color ( value x,y color-id image -- )

6
basis/inspector/inspector.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables io kernel assocs math
namespaces prettyprint prettyprint.custom prettyprint.sections
@ -23,9 +23,7 @@ GENERIC: add-numbers ( alist -- table' )
M: enum add-numbers ;
M: assoc add-numbers
+number-rows+ get [
dup length [ prefix ] 2map
] when ;
+number-rows+ get [ [ prefix ] map-index ] when ;
TUPLE: slot-name name ;

6
basis/inverse/inverse.factor
View File

@ -68,7 +68,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
[ [ length ] [ 1quotation infer in>> ] bi* >= ]
[ [ length ] [ 1quotation inputs ] bi* >= ]
[ 3drop f ] recover
] if ;
@ -273,10 +273,10 @@ DEFER: __
] recover ; inline
: true-out ( quot effect -- quot' )
out>> '[ @ _ ndrop t ] ;
out>> length '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ;
in>> length [ ndrop f ] curry [ recover-fail ] curry ;
: [matches?] ( quot -- undoes?-quot )
[undo] dup infer [ true-out ] [ false-recover ] bi curry ;

2
basis/io/encodings/iso2022/iso2022.factor
View File

@ -18,7 +18,7 @@ VALUE: jis212
"vocab:io/encodings/iso2022/212.txt" flat-file>biassoc to: jis212
VALUE: ascii
128 unique >biassoc to: ascii
128 iota unique >biassoc to: ascii
TUPLE: iso2022-state type ;

2
basis/io/files/links/unix/unix-tests.factor
View File

@ -4,7 +4,7 @@ io.pathnames namespaces ;
IN: io.files.links.unix.tests
: make-test-links ( n path -- )
[ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ '[ [ 1 + ] keep [ number>string _ prepend ] bi@ make-link ] each-integer ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [

2
basis/io/files/unique/unique.factor
View File

@ -36,7 +36,7 @@ SYMBOL: unique-retries
unique-length get [ random-ch ] "" replicate-as ;
: retry ( quot: ( -- ? ) n -- )
swap [ drop ] prepose attempt-all ; inline
iota swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[

2
basis/lcs/diff2html/diff2html-tests.factor
View File

@ -3,4 +3,4 @@
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
IN: lcs.diff2html.tests
[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
[ ] [ "hello" "heyo" [ [ 1string ] { } map-as ] bi@ diff htmlize-diff xml>string drop ] unit-test

2
basis/lcs/diff2html/diff2html.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: lcs xml.syntax xml.writer kernel strings ;
FROM: accessors => item>> ;

8
basis/lcs/lcs.factor
View File

@ -19,15 +19,15 @@ IN: lcs
i 1 + j 1 + matrix nth set-nth ; inline
: lcs-initialize ( |str1| |str2| -- matrix )
[ drop 0 <array> ] with map ;
iota [ drop 0 <array> ] with map ;
: levenshtein-initialize ( |str1| |str2| -- matrix )
[ [ + ] curry map ] with map ;
[ iota ] bi@ [ [ + ] curry map ] with map ;
:: run-lcs ( old new init step -- matrix )
old length 1 + new length 1 + init call :> matrix
old length [| i |
new length
old length iota [| i |
new length iota
[| j | i j matrix old new step loop-step ] each
] each matrix ; inline
PRIVATE>

2
basis/macros/expander/expander.factor
View File

@ -49,7 +49,7 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
length [ <reversed> ] keep
length iota [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;

4
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -31,7 +31,7 @@ HELP: permutation
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
"1 { 0 1 2 } permutation ." "{ 0 2 1 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
} ;
@ -41,7 +41,7 @@ HELP: all-permutations
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
"{ 0 1 2 } all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
} ;
HELP: each-permutation

2
basis/math/combinatorics/combinatorics-tests.factor
View File

@ -56,7 +56,7 @@ IN: math.combinatorics.tests
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
[ { 5 3 2 1 } ] [ 7 iota 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test

12
basis/math/combinatorics/combinatorics.factor
View File

@ -1,4 +1,4 @@
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs binary-search fry kernel locals math math.order
math.ranges namespaces sequences sorting ;
@ -15,7 +15,7 @@ IN: math.combinatorics
PRIVATE>
: factorial ( n -- n! )
1 [ 1 + * ] reduce ;
iota 1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
@ -46,11 +46,11 @@ PRIVATE>
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
[ length factorial ] keep
[ length factorial iota ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
[ [ length factorial iota ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq identity quot -- result )
@ -77,7 +77,7 @@ C: <combo> combo
dup 0 = [
drop 1 - nip
] [
[ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
[ iota ] 2dip '[ _ nCk _ >=< ] search nip
] if ;
:: next-values ( a b x -- a' b' x' v )
@ -104,7 +104,7 @@ C: <combo> combo
[ combination-indices ] keep seq>> nths ;
: combinations-quot ( seq k quot -- seq quot )
[ <combo> [ choose [0,b) ] keep ] dip
[ <combo> [ choose iota ] keep ] dip
'[ _ apply-combination @ ] ; inline
PRIVATE>

3
basis/math/complex/complex-tests.factor
View File

@ -70,4 +70,7 @@ IN: math.complex.tests
[ ] [ C{ 1 4 } coth drop ] unit-test
[ ] [ C{ 1 4 } cot drop ] unit-test
[ t ] [ 0.0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test
[ t ] [ 0 pi rect> exp C{ -1 0 } 1.0e-7 ~ ] unit-test
[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test

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