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 \
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
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 )
[ write1-lines ] each ;
: encode3 ( seq -- )
- be> 4 <reversed> [
+ be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline
-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
[ 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
100 [
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
- ] all?
+ ] all-integers?
] unit-test
[ ?{ f } ] [
-! 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
: (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.
] 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 ;
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
\r
: do-it ( seq -- )\r
- 1234 swap [ [ even? ] dip push ] curry each ;\r
+ 1234 swap [ [ even? ] dip push ] curry each-integer ;\r
\r
[ t ] [\r
3 <bit-vector> dup do-it\r
-! 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
CONSTANT: data-base 1024
-CONSTANT: userenv-size 70
+CONSTANT: special-objects-size 70
CONSTANT: header-size 10
: 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 ]
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
-
-USERENV: callback-stub 48
+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
+
+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 ;
: 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 + ;
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
\ 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 ;
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
-! 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 ;
\ No newline at end of file
: 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" ] }
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: math math.order math.parser math.functions kernel\r
sequences io accessors arrays io.streams.string splitting\r
[\r
[ 1 + day. ] keep\r
1 + + 7 mod zero? [ nl ] [ bl ] if\r
- ] with each nl ;\r
+ ] with each-integer nl ;\r
\r
M: timestamp month. ( timestamp -- )\r
[ year>> ] [ month>> ] bi 2array month. ;\r
GENERIC: year. ( obj -- )\r
\r
M: integer year. ( n -- )\r
- 12 [ 1 + 2array month. nl ] with each ;\r
+ 12 [ 1 + 2array month. nl ] with each-integer ;\r
\r
M: timestamp year. ( timestamp -- )\r
year>> year. ;\r
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
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 -- )
! 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
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.
-! 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
(free) ;
: method-arg-types ( method -- args )
- dup method_getNumberOfArguments
+ dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )
[ { 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
-! 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
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 ;
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
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
-! 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
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
+ ##alien-assembly
##alien-callback ;
M: stack-frame-insn compute-stack-frame*
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
[
INSN: ##alien-indirect
literal: params stack-frame ;
+INSN: ##alien-assembly
+literal: params stack-frame ;
+
INSN: ##alien-callback
literal: params stack-frame ;
-! 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
"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 {
-! 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
[ [ ^^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 ;
{
{ 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+ ] }
: 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 ;
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 )
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 -- )
-! 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
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
+ [ ##alien-assembly? ]
} 1||
] any? ;
-! 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
: 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 -- )
[
-! 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
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>
[ [ 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
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>>
TUPLE: callback-context ;
-: current-callback ( -- id ) 2 getenv ;
+: current-callback ( -- id ) 2 special-object ;
: wait-to-return ( token -- )
dup current-callback eq? [
: 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 )
-! 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
: 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 ;
: 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
{ 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
{ 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 ;
: 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
[ 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
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
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
! 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
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
[ 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
[ 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
[ 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
[ ] [
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
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 )
: 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 -- * )
] if ; inline recursive
[ 10 ] [
- 10 20 >vector <flat-slice>
+ 10 20 iota <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
[ 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
[ 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
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 ;
] 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
[ t ] [
[
- { integer } declare [ 0 >= ] map
+ { integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test
-! 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
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ swap nths ] 2bi
- [ make-values ] keep
+ [ length make-values ] keep
[ drop ] [ zip ] 2bi
#data-shuffle ;
-! 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
:: 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 ;
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
-! 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
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 ;
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 ;
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
[ 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 ;
-! 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
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) ;
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 ;
-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
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
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 ;
[ t ] [
[
- { fixnum } declare 0 swap
+ { fixnum } declare iota 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
[ t ] [
[
- { integer } declare [ 256 mod ] map
+ { integer } declare iota [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
-! 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
] 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
-! 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
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 ;
[ 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>
-! 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
{ + - * / }
[ { 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
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
[ 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 } ] [
] 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
] 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 } ] [
! 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
: (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 -- )
[ 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) ;
-! 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
] "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>> {
\ 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
} 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
-! 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
: #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
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, ;
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* ;
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!
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
{
! 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
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"
[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
-[ 10 [ 3 mod zero? ] parallel-filter ] unit-test\r
+[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test\r
\r
[ 10 ]\r
[\r
V{ } clone\r
- 10 over [ push ] curry parallel-each\r
+ 10 iota over [ push ] curry parallel-each\r
length\r
] unit-test\r
\r
[ 20 ]\r
[\r
V{ } clone\r
- 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
+ 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
length\r
] unit-test\r
\r
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 -- )
-! Copyright (C) 2007, 2009 Slava Pestov.\r
+! Copyright (C) 2007, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
-compiler.constants math math.private layouts words vocabs\r
-slots.private locals locals.backend generic.single.private fry ;\r
+compiler.constants math math.private math.ranges layouts words vocabs\r
+slots.private locals locals.backend generic.single.private fry\r
+sequences ;\r
FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
CONSTANT: ds-reg 13\r
CONSTANT: rs-reg 14\r
CONSTANT: vm-reg 15\r
+CONSTANT: ctx-reg 16\r
\r
-: factor-area-size ( -- n ) 4 bootstrap-cells ;\r
+: factor-area-size ( -- n ) 16 ;\r
\r
: stack-frame ( -- n )\r
- factor-area-size c-area-size + 4 bootstrap-cells align ;\r
+ reserved-size\r
+ factor-area-size +\r
+ 16 align ;\r
\r
-: next-save ( -- n ) stack-frame bootstrap-cell - ;\r
-: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
+: next-save ( -- n ) stack-frame 4 - ;\r
+: xt-save ( -- n ) stack-frame 8 - ;\r
+\r
+: param-size ( -- n ) 32 ;\r
+\r
+: save-at ( m -- n ) reserved-size + param-size + ;\r
+\r
+: save-int ( register offset -- ) [ 1 ] dip save-at STW ;\r
+: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;\r
+\r
+: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;\r
+: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;\r
+\r
+: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;\r
+: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;\r
+\r
+: nv-int-regs ( -- seq ) 13 31 [a,b] ;\r
+: nv-fp-regs ( -- seq ) 14 31 [a,b] ;\r
+: nv-vec-regs ( -- seq ) 20 31 [a,b] ;\r
+\r
+: saved-int-regs-size ( -- n ) 96 ;\r
+: saved-fp-regs-size ( -- n ) 144 ;\r
+: saved-vec-regs-size ( -- n ) 208 ;\r
+\r
+: callback-frame-size ( -- n )\r
+ reserved-size\r
+ param-size +\r
+ saved-int-regs-size +\r
+ saved-fp-regs-size +\r
+ saved-vec-regs-size +\r
+ 16 align ;\r
+\r
+[\r
+ 0 MFLR\r
+ 1 1 callback-frame-size neg STWU\r
+ 0 1 callback-frame-size lr-save + STW\r
+\r
+ nv-int-regs [ 4 * save-int ] each-index\r
+ nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
+ nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
+\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel\r
+ 2 MTLR\r
+ BLRL\r
+\r
+ nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
+ nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
+ nv-int-regs [ 4 * restore-int ] each-index\r
+\r
+ 0 1 callback-frame-size lr-save + LWZ\r
+ 1 1 0 LWZ\r
+ 0 MTLR\r
+ BLR\r
+] callback-stub jit-define\r
\r
: jit-conditional* ( test-quot false-quot -- )\r
- [ '[ bootstrap-cell /i 1 + @ ] ] dip jit-conditional ; inline\r
+ [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline\r
+\r
+: jit-load-context ( -- )\r
+ ctx-reg vm-reg vm-context-offset LWZ ;\r
\r
: jit-save-context ( -- )\r
- 4 vm-reg 0 LWZ\r
- 1 4 0 STW\r
- ds-reg 4 8 STW\r
- rs-reg 4 12 STW ;\r
+ jit-load-context\r
+ 1 ctx-reg context-callstack-top-offset STW\r
+ ds-reg ctx-reg context-datastack-offset STW\r
+ rs-reg ctx-reg context-retainstack-offset STW ;\r
\r
: jit-restore-context ( -- )\r
- 4 vm-reg 0 LWZ\r
- ds-reg 4 8 LWZ\r
- rs-reg 4 12 LWZ ;\r
+ jit-load-context\r
+ ds-reg ctx-reg context-datastack-offset LWZ\r
+ rs-reg ctx-reg context-retainstack-offset LWZ ;\r
\r
[\r
0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
] jit-profiling jit-define\r
\r
[\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
- 3 1 xt-save STW\r
- stack-frame 3 LI\r
- 3 1 next-save STW\r
+ 2 1 xt-save STW\r
+ stack-frame 2 LI\r
+ 2 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
] jit-prolog jit-define\r
\r
load-tag\r
0 4 tuple type-number tag-fixnum CMPI\r
[ BNE ]\r
- [ 4 3 tuple type-number neg bootstrap-cell + LWZ ]\r
+ [ 4 3 tuple type-number neg 4 + LWZ ]\r
jit-conditional*\r
] pic-tuple jit-define\r
\r
[ jit-load-return-address jit-inline-cache-miss ]\r
[ 3 MTLR BLRL ]\r
[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss define-sub-primitive*\r
+\ inline-cache-miss define-combinator-primitive\r
\r
[ jit-inline-cache-miss ]\r
[ 3 MTLR BLRL ]\r
[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss-tail define-sub-primitive*\r
+\ inline-cache-miss-tail define-combinator-primitive\r
\r
! ! ! Megamorphic caches\r
\r
! key = hashcode(class)\r
5 4 1 SRAWI\r
! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
+ 5 5 mega-cache-size get 1 - 4 * ANDI\r
! cache += array-start-offset\r
3 3 array-start-offset ADDI\r
! cache += key\r
5 4 0 LWZ\r
5 5 1 ADDI\r
5 4 0 STW\r
- ! ... goto get(cache + bootstrap-cell)\r
+ ! ... goto get(cache + 4)\r
3 3 4 LWZ\r
3 3 word-xt-offset LWZ\r
3 MTCTR\r
! fall-through on miss\r
] mega-lookup jit-define\r
\r
-[\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel\r
- 2 MTCTR\r
- BCTR\r
-] callback-stub jit-define\r
-\r
! ! ! Sub-primitives\r
\r
! Quotations and words\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 4 vm-reg MR\r
5 3 quot-xt-offset LWZ\r
]\r
[ 5 MTLR BLRL ]\r
-[ 5 MTCTR BCTR ] \ (call) define-sub-primitive*\r
+[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 3 word-xt-offset LWZ\r
]\r
[ 4 MTLR BLRL ]\r
-[ 4 MTCTR BCTR ] \ (execute) define-sub-primitive*\r
+[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 MTCTR BCTR\r
] jit-execute jit-define\r
\r
+! Special primitives\r
+[\r
+ jit-restore-context\r
+ ! Save ctx->callstack_bottom\r
+ 1 ctx-reg context-callstack-bottom-offset STW\r
+ ! Call quotation\r
+ 5 3 quot-xt-offset LWZ\r
+ 5 MTLR\r
+ BLRL\r
+ jit-save-context\r
+] \ c-to-factor define-sub-primitive\r
+\r
+[\r
+ ! Unwind stack frames\r
+ 1 4 MR\r
+\r
+ ! Load VM pointer into vm-reg, since we're entering from\r
+ ! C code\r
+ 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
+\r
+ ! Load ds and rs registers\r
+ jit-restore-context\r
+\r
+ ! We have changed the stack; load return address again\r
+ 0 1 lr-save LWZ\r
+ 0 MTLR\r
+\r
+ ! Call quotation\r
+ 4 3 quot-xt-offset LWZ\r
+ 4 MTCTR\r
+ BCTR\r
+] \ unwind-native-frames define-sub-primitive\r
+\r
+[\r
+ ! Load callstack object\r
+ 6 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ ! Get ctx->callstack_bottom\r
+ jit-load-context\r
+ 3 ctx-reg context-callstack-bottom-offset LWZ\r
+ ! Get top of callstack object -- 'src' for memcpy\r
+ 4 6 callstack-top-offset ADDI\r
+ ! Get callstack length, in bytes --- 'len' for memcpy\r
+ 5 6 callstack-length-offset LWZ\r
+ 5 5 tag-bits get SRAWI\r
+ ! Compute new stack pointer -- 'dst' for memcpy\r
+ 3 5 3 SUBF\r
+ ! Install new stack pointer\r
+ 1 3 MR\r
+ ! Call memcpy; arguments are now in the correct registers\r
+ 1 1 -64 STWU\r
+ 0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym\r
+ 2 MTLR\r
+ BLRL\r
+ 1 1 0 LWZ\r
+ ! Return with new callstack\r
+ 0 1 lr-save LWZ\r
+ 0 MTLR\r
+ BLR\r
+] \ set-callstack define-sub-primitive\r
+\r
+[\r
+ jit-save-context\r
+ 4 vm-reg MR\r
+ 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym\r
+ 2 MTLR\r
+ BLRL\r
+ 5 3 quot-xt-offset LWZ\r
+]\r
+[ 5 MTLR BLRL ]\r
+[ 5 MTCTR BCTR ]\r
+\ lazy-jit-compile define-combinator-primitive\r
+\r
! Objects\r
[\r
3 ds-reg 0 LWZ\r
-! 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
-! 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
! 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
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 ;
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 ;
{ 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 -- )
! 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
[ 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 ( -- )
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 ( -- )
"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 ] }
--- /dev/null
+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
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
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@ ;
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 ;
-! 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
: 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 ;
] 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 ( -- )
! 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 ;
[ 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 ;
[
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
--- /dev/null
+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
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
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 -- )
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 ;
-! 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
: 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 ;
[
! 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 ( -- )
! 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 ;
[ 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
ds-reg [] arg3 MOV
[ JNO ]
[
- arg3 RBP MOV
+ arg3 vm-reg MOV
RAX 0 MOV f rc-absolute-cell jit-dlsym
RAX CALL
]
[
ds-reg 8 SUB
- jit-load-vm
jit-save-context
RCX ds-reg [] MOV
RBX ds-reg 8 [+] MOV
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
]
: NOP ( -- ) HEX: 90 , ;
: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
+: RDTSC ( -- ) HEX: 0f , HEX: 31 , ;
: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
: 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
-! 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
! 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
]
[ temp0 word-xt-offset [+] CALL ]
[ temp0 word-xt-offset [+] JMP ]
-\ (execute) define-sub-primitive*
+\ (execute) define-combinator-primitive
[
temp0 ds-reg [] MOV
-! 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
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
-! 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
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 ;
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
#! 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 ;
] 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 ;
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? [
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
- drop [ retries>> ] [
+ drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]
test-2 ensure-table
] with-db
] [
- 10 [
+ 10 iota [
drop
10 [
dup [
] with-db
] [
<db-pool> [
- 10 [
+ 10 iota [
10 [
test-1-tuple insert-tuple yield
] times
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
[ "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 } } } ] [
{ 3 5 } [ 2 nweave ] must-infer-as\r
\r
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
+[ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
\r
[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test\r
\r
{ $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 ;"
{ $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 }"
}
<min-heap> [ heap-push-all ] keep heap-pop-all ;
: random-alist ( n -- alist )
- [
+ iota [
drop 32 random-bits dup number>string
] H{ } map>assoc ;
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 ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
-] each
+] each-integer
-! 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
"specializer" word-prop ;
: make-specializer ( specs -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
data>>
binary
[
- read1 [0,b)
+ read1 iota
[ drop
read1 jpeg> color-info>> nth clone
read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
{ 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 ;
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 ] }
IN: images.processing\r
\r
: coord-matrix ( dim -- m )\r
- [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;\r
+ [ iota ] map first2 [ [ 2array ] with map ] curry map ;\r
\r
: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
: matrix>image ( m -- image )\r
<image> over matrix-dim >>dim\r
swap flip flatten\r
- [ 128 * 128 + 0 max 255 min >fixnum ] map\r
+ [ 128 * 128 + 0 255 clamp >fixnum ] map\r
>byte-array >>bitmap L >>component-order ubyte-components >>component-type ;\r
\r
:: matrix-zoom ( m f -- m' )\r
:: draw-grey ( value x,y image -- )\r
x,y image image-offset 3 * { 0 1 2 }\r
[\r
- + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth\r
+ + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth\r
] with each ;\r
\r
:: draw-color ( value x,y color-id image -- )\r
-! 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
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 ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
- [ [ length ] [ 1quotation infer in>> ] bi* >= ]
+ [ [ length ] [ 1quotation inputs ] bi* >= ]
[ 3drop f ] recover
] if ;
] 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 ;
"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 ;
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 ] [
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
-: retry ( quot: ( -- ? ) n -- )
- swap [ drop ] prepose attempt-all ; inline
+: retry ( quot: ( -- ? ) n -- )
+ iota swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
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
-! 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>> ;
i 1 + j 1 + matrix nth set-nth ; inline\r
\r
: lcs-initialize ( |str1| |str2| -- matrix )\r
- [ drop 0 <array> ] with map ;\r
+
iota [ drop 0 <array> ] with map ;
\r \r
: levenshtein-initialize ( |str1| |str2| -- matrix )\r
- [ [ + ] curry map ] with map ;\r
+ [ iota ] bi@ [ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
old length 1 + new length 1 + init call :> matrix\r
- old length [| i |\r
- new length\r
+ old length iota [| i |\r
+ new length iota\r
[| j | i j matrix old new step loop-step ] each\r
] each matrix ; inline\r
PRIVATE>\r
stack get pop end
[ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
[
- length [ <reversed> ] keep
+ length iota [ <reversed> ] keep
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
{ $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\" }" }
} ;
{ $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
[ 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
-! 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 ;
PRIVATE>
: factorial ( n -- n! )
- 1 [ 1 + * ] reduce ;
+ iota 1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
[ 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 )
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 )
[ 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>
[ ] [ 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
--- /dev/null
+USING: alien alien.c-types cpu.x86.assembler
+cpu.x86.assembler.operands math.floats.env.x86 system ;
+IN: math.floats.env.x86.32
+
+M: x86.32 get-sse-env
+ void { void* } "cdecl" [
+ EAX ESP [] MOV
+ EAX [] STMXCSR
+ ] alien-assembly ;
+
+M: x86.32 set-sse-env
+ void { void* } "cdecl" [
+ EAX ESP [] MOV
+ EAX [] LDMXCSR
+ ] alien-assembly ;
+
+M: x86.32 get-x87-env
+ void { void* } "cdecl" [
+ EAX ESP [] MOV
+ EAX [] FNSTSW
+ EAX 2 [+] FNSTCW
+ ] alien-assembly ;
+
+M: x86.32 set-x87-env
+ void { void* } "cdecl" [
+ EAX ESP [] MOV
+ FNCLEX
+ EAX 2 [+] FLDCW
+ ] alien-assembly ;
--- /dev/null
+unportable
--- /dev/null
+USING: alien alien.c-types cpu.architecture cpu.x86.assembler
+cpu.x86.assembler.operands math.floats.env.x86 sequences system ;
+IN: math.floats.env.x86.64
+
+M: x86.64 get-sse-env
+ void { void* } "cdecl" [
+ int-regs param-regs first [] STMXCSR
+ ] alien-assembly ;
+
+M: x86.64 set-sse-env
+ void { void* } "cdecl" [
+ int-regs param-regs first [] LDMXCSR
+ ] alien-assembly ;
+
+M: x86.64 get-x87-env
+ void { void* } "cdecl" [
+ int-regs param-regs first [] FNSTSW
+ int-regs param-regs first 2 [+] FNSTCW
+ ] alien-assembly ;
+
+M: x86.64 set-x87-env
+ void { void* } "cdecl" [
+ FNCLEX
+ int-regs param-regs first 2 [+] FLDCW
+ ] alien-assembly ;
--- /dev/null
+unportable
-USING: accessors alien.c-types alien.syntax arrays assocs
-biassocs classes.struct combinators cpu.x86.features kernel
-literals math math.bitwise math.floats.env
-math.floats.env.private system ;
+USING: accessors alien.c-types arrays assocs biassocs
+classes.struct combinators cpu.x86.features kernel literals
+math math.bitwise math.floats.env math.floats.env.private
+system vocabs.loader ;
IN: math.floats.env.x86
STRUCT: sse-env
{ status ushort }
{ control ushort } ;
-! defined in the vm, cpu-x86*.S
-FUNCTION: void get_sse_env ( sse-env* env ) ;
-FUNCTION: void set_sse_env ( sse-env* env ) ;
+HOOK: get-sse-env cpu ( sse-env -- )
+HOOK: set-sse-env cpu ( sse-env -- )
-FUNCTION: void get_x87_env ( x87-env* env ) ;
-FUNCTION: void set_x87_env ( x87-env* env ) ;
+HOOK: get-x87-env cpu ( x87-env -- )
+HOOK: set-x87-env cpu ( x87-env -- )
: <sse-env> ( -- sse-env )
- sse-env (struct) [ get_sse_env ] keep ;
+ sse-env (struct) [ get-sse-env ] keep ;
M: sse-env (set-fp-env-register)
- set_sse_env ;
+ set-sse-env ;
: <x87-env> ( -- x87-env )
- x87-env (struct) [ get_x87_env ] keep ;
+ x87-env (struct) [ get-x87-env ] keep ;
M: x87-env (set-fp-env-register)
- set_x87_env ;
+ set-x87-env ;
M: x86 (fp-env-registers)
sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
M: x87-env (set-denormal-mode) ( register mode -- register' )
drop ;
+cpu {
+ { x86.32 [ "math.floats.env.x86.32" ] }
+ { x86.64 [ "math.floats.env.x86.64" ] }
+} case require
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.private math.bits
math.libm combinators math.order sequences ;
M: real exp >float exp ; inline
-M: complex exp >rect swap fexp swap polar> ; inline
+M: complex exp >rect swap exp swap polar> ; inline
<PRIVATE
] if ;
unary-ops [
- [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+ [ [ t ] ] dip '[ 8000 [ drop _ unary-test ] all-integers? ] unit-test
] each
: binary-ops ( -- alist )
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel locals math math.vectors math.matrices
namespaces sequences fry sorting ;
[ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
- rows dup <slice> ;
+ rows dup iota <slice> ;
: clear-col ( col# row# rows -- )
[ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: reduced ( matrix' -- matrix'' )
[
- rows <reversed> [
+ rows iota <reversed> [
dup nth-row leading drop
- dup [ swap dup clear-col ] [ 2drop ] if
+ dup [ swap dup iota clear-col ] [ 2drop ] if
] each
] with-matrix ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays columns kernel locals math math.bits
math.functions math.order math.vectors sequences
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
- dup [ [ = 1 0 ? ] with map ] curry map ;
+ iota dup [ [ = 1 0 ? ] with map ] curry map ;
:: rotation-matrix3 ( axis theta -- matrix )
theta cos :> c
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
- 2unempty pextend-conv <reversed> dup length
+ 2unempty pextend-conv <reversed> dup length iota
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
: p-sq ( p -- p^2 )
[ t ] [ 37 miller-rabin ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
+[ f ] [ 1000 iota [ drop 15 miller-rabin ] any? ] unit-test
n 1 - :> n-1
n-1 factor-2s :> ( r s )
0 :> a!
- trials [
+ trials iota [
drop
2 n 2 - [a,b] random a!
a s n ^mod 1 = [
A{ DEFINES ${A}{
N [ A-rep rep-length ]
-BOA-EFFECT [ N 2 * "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
WHERE
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-with) ( n rep -- v )
- [ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as
+ [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
"== Checking vector operations" print
: random-int-vector ( class -- vec )
- new [ drop 1,000 random ] map ;
+ new [ drop 1000 random ] map ;
+
: random-float-vector ( class -- vec )
new [
drop
! Test element access -- it should box bignums for int-4 on x86
: test-accesses ( seq -- failures )
- [ length >array ] keep
+ [ length iota >array ] keep
'[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test
"== Checking broadcast" print
: test-broadcast ( seq -- failures )
- [ length >array ] keep
+ [ length iota >array ] keep
'[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-BOA-EFFECT [ N "n" <repetition> >array { "v" } <effect> ]
+BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
GENERIC: v/ ( u v -- w )
M: object v/ [ / ] 2map ;
-<PRIVATE
-
-: if-both-floats ( x y p q -- )
- [ 2dup [ float? ] both? ] 2dip if ; inline
-
-PRIVATE>
-
GENERIC: vavg ( u v -- w )
M: object vavg [ + 2 / ] 2map ;
GENERIC: vmax ( u v -- w )
-M: object vmax [ [ float-max ] [ max ] if-both-floats ] 2map ;
+M: object vmax [ max ] 2map ;
GENERIC: vmin ( u v -- w )
-M: object vmin [ [ float-min ] [ min ] if-both-floats ] 2map ;
+M: object vmin [ min ] 2map ;
GENERIC: v+- ( u v -- w )
M: object v+-
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models.arrow models.product stack-checker accessors fry
-generalizations macros kernel ;
+generalizations combinators.smart macros kernel ;
IN: models.arrow.smart
MACRO: <smart-arrow> ( quot -- quot' )
- [ infer in>> dup ] keep
+ [ inputs dup ] keep
'[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
USING: nibble-arrays tools.test sequences kernel math ;
IN: nibble-arrays.tests
-[ t ] [ 16 dup >nibble-array sequence= ] unit-test
+[ t ] [ 16 iota dup >nibble-array sequence= ] unit-test
[ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
[ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test
] [ \r
[\r
"FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
- dup length [\r
+ [\r
over ebnf-var? [\r
" " % # " over nth :> " %\r
name>> % \r
] [\r
2drop\r
] if\r
- ] 2each\r
+ ] each-index\r
" " %\r
% \r
" nip ]" % \r
] unit-test
: random-string ( -- str )
- 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
+ 1000000 random ;
+ ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
: random-assocs ( n -- hash phash )
[ random-string ] replicate
] unit-test
{ 100 1060 2000 10000 100000 1000000 } [
- [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+ [ t ] swap [ iota dup >persistent-vector sequence= ] curry unit-test
] each
[ ] [ 10000 [ 16 random-bits ] PV{ } replicate-as "1" set ] unit-test
[ ] [ "1" get >vector "2" set ] unit-test
[ t ] [
- 3000 [
+ 3000 iota [
drop
16 random-bits 10000 random
[ "1" [ new-nth ] change ]
] unit-test
[ t ] [
- 10000 >persistent-vector 752 [ ppop ] times dup length sequence=
+ 10000 iota >persistent-vector 752 [ ppop ] times dup length iota sequence=
] unit-test
[ t ] [
- 100 [
+ 100 iota [
drop
100 random [
16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
] if ;
: consonant-seq ( str -- n )
- 0 0 rot skip-consonants (consonant-seq) ;
+ [ 0 0 ] dip skip-consonants (consonant-seq) ;
: stem-vowel? ( str -- ? )
- [ length ] keep [ consonant? ] curry all? not ;
+ [ length iota ] keep [ consonant? ] curry all? not ;
: double-consonant? ( i str -- ? )
over 1 < [
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1 + cut [ (remove-breakpoints) ] bi@
- [ -> ] glue
+ 1 + short cut [ (remove-breakpoints) ] bi@
+ [ -> ] glue
] [
drop
] if ;
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
: group-flow ( seq -- newseq )
[
- dup length [
+ dup length iota [
2dup 1 - swap ?nth prev set
2dup 1 + swap ?nth next set
swap nth dup split-before dup , split-after
: check-random ( max -- ? )
[ random 0 ] keep between? ;
-[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
+[ t ] [ 100 [ drop 674 check-random ] all-integers? ] unit-test
: randoms ( -- seq )
100 [ 100 random ] replicate ;
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
[ 1333075495 ] [
- 0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+ 0 [ 1000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng
] unit-test
[ 1575309035 ] [
- 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+ 0 [ 10000 [ drop random-generator get random-32* drop ] each-integer random-generator get random-32* ] test-rng
] unit-test
: mt-generate ( mt -- )
[
seq>>
- [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each ]
- [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each ]
+ [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each-integer ]
+ [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each-integer ]
bi
] [ 0 >>i drop ] bi ; inline
: init-mt-rest ( seq -- )
n 1 - swap '[
_ [ init-mt-formula ] [ [ 1 + ] dip set-nth ] 2bi
- ] each ; inline
+ ] each-integer ; inline
: init-mt-seq ( seed -- seq )
32 bits n <uint-array>
{ $description "Generates a byte-array of random bytes." } ;
HELP: random
-{ $values { "seq" sequence } { "elt" "a random element" } }
-{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." }
-{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." }
+{ $values { "obj" object } { "elt" "a random element" } }
+{ $description "Outputs a random element of the input object, or outputs " { $link f } " if the object contains no elements." }
{ $examples
{ $unchecked-example "USING: random prettyprint ;"
"10 random ."
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail
-[ t ] [ 10000 [ 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
-[ t ] [ 10000 [ 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
+[ t ] [ 10000 [ iota 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
+[ t ] [ 10000 [ iota 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
-[ 99 ] [ 100 99 sample prune length ] unit-test
+[ 99 ] [ 100 iota 99 sample prune length ] unit-test
[ ]
[ [ 100 random-bytes ] with-system-random drop ] unit-test
: random-bits* ( numbits -- n )
1 - [ random-bits ] keep set-bit ;
-: random ( seq -- elt )
+GENERIC: random ( obj -- elt )
+
+M: integer random [ f ] [ random-integer ] if-zero ;
+
+M: sequence random
[ f ] [
[ length random-integer ] keep nth
] if-empty ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
- [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
+ [ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
ERROR: too-many-samples seq n ;
zip [ first ] partition [ values ] bi@ parts boa ;
: powerset-partition ( sequence -- partitions )
- [ length [ 2^ ] keep ] keep '[
- _ <bits> _ make-partition
- ] map rest ;
+ [ length [ 2^ iota ] keep ] keep '[ _ <bits> _ make-partition ] map rest ;
: partition>class ( parts -- class )
[ out>> [ <not-class> ] map ]
IN: roman
HELP: >roman
-{ $values { "n" "an integer" } { "str" "a string" } }
+{ $values { "n" integer } { "str" string } }
{ $description "Converts a number to its lower-case Roman Numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
{ $examples
} ;
HELP: >ROMAN
-{ $values { "n" "an integer" } { "str" "a string" } }
+{ $values { "n" integer } { "str" string } }
{ $description "Converts a number to its upper-case Roman numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
{ $examples
} ;
HELP: roman>
-{ $values { "str" "a string" } { "n" "an integer" } }
+{ $values { "str" string } { "n" integer } }
{ $description "Converts a Roman numeral to an integer." }
{ $notes "The range for this word is i-mmmcmxcix, inclusive." }
{ $examples
{ >roman >ROMAN roman> } related-words
HELP: roman+
-{ $values { "string" string } { "string" string } { "string" string } }
+{ $values { "x" string } { "x" string } { "x" string } }
{ $description "Adds two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman-
-{ $values { "string" string } { "string" string } { "string" string } }
+{ $values { "x" string } { "x" string } { "x" string } }
{ $description "Subtracts two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
{ roman+ roman- } related-words
HELP: roman*
-{ $values { "string" string } { "string" string } { "string" string } }
+{ $values { "x" string } { "x" string } { "x" string } }
{ $description "Multiplies two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/i
-{ $values { "string" string } { "string" string } { "string" string } }
+{ $values { "x" string } { "x" string } { "x" string } }
{ $description "Computes the integer division of two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/mod
-{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
+{ $values { "x" string } { "x" string } { "x" string } { "x" string } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $examples
{ $example "USING: kernel io roman ;"
<PRIVATE
MACRO: binary-roman-op ( quot -- quot' )
- [ infer in>> ] [ ] [ infer out>> ] tri
+ [ inputs ] [ ] [ outputs ] tri
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
PRIVATE>
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
- dup infer [ in>> ] [ out>> ] bi
- [ "string" <repetition> ] bi@ <effect> define-declared ;
+ dup infer define-declared ;
>>
[ t ] [
100 [
drop
- 40 [ test-serialize-cell ] all?
- 4 [ 40 * test-serialize-cell ] all?
- 4 [ 400 * test-serialize-cell ] all?
- 4 [ 4000 * test-serialize-cell ] all?
+ 40 [ test-serialize-cell ] all-integers?
+ 4 [ 40 * test-serialize-cell ] all-integers?
+ 4 [ 400 * test-serialize-cell ] all-integers?
+ 4 [ 4000 * test-serialize-cell ] all-integers?
and and and
- ] all?
+ ] all-integers?
] unit-test
TUPLE: serialize-test a b ;
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
- [ dup length ] dip [ set-array-nth ] curry 2each ;
+ [ set-array-nth ] curry each-index ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
<PRIVATE
: >index-assoc ( sequence -- assoc )
- dup length zip >hashtable ;
+ dup length iota zip >hashtable ;
PRIVATE>
: insertion-sort ( seq quot -- )
! quot is a transformation on elements
- over length [ insert ] with with each ; inline
+ over length [ insert ] with with each-integer ; inline
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline
-sorting.functor ;
+arrays sequences kernel assocs multiline sorting.functor ;
IN: sorting.literals.tests
TUPLE: sort-test a b c tuple2 ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
- } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by
+ } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by
] unit-test
[ { } ]
{ length-test<=> <=> } sort-by
] unit-test
-[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
+[ { { { 0 } 1 } { { 1 } 2 } { { 1 } 1 } { { 3 1 } 2 } } ]
[
- { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { { { 3 1 } 2 } { { 1 } 2 } { { 0 } 1 } { { 1 } 1 } }
{ length-test<=> <=> } sort-keys-by
] unit-test
-[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
+[ { { 0 { 1 } } { 1 { 1 } } { 3 { 2 4 } } { 1 { 2 0 0 0 } } } ]
[
- { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { { 3 { 2 4 } } { 1 { 2 0 0 0 } } { 0 { 1 } } { 1 { 1 } } }
{ length-test<=> <=> } sort-values-by
] unit-test
: (monotonic-slice) ( seq quot class -- slices )
[
dupd '[
- [ length ] [ ] [ <circular> 1 over change-circular-start ] tri
+ [ length iota ] [ ] [ <circular> 1 over change-circular-start ] tri
[ @ not [ , ] [ drop ] if ] 3each
] { } make
dup empty? [ over length 1 - prefix ] when -1 prefix 2 clump
TUPLE: alien-indirect-params < alien-node-params ;
+TUPLE: alien-assembly-params < alien-node-params quot ;
+
TUPLE: alien-callback-params < alien-node-params quot xt ;
: param-prep-quot ( node -- quot )
! Quotation which coerces return value to required type
return-prep-quot infer-quot-here ;
+: infer-alien-assembly ( -- )
+ alien-assembly-params new
+ ! Compile-time parameters
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-literal nip >>parameters
+ pop-literal nip >>return
+ ! Quotation which coerces parameters to required types
+ dup param-prep-quot infer-quot-here
+ ! Magic #: consume exactly the number of inputs
+ dup 0 alien-stack
+ ! Add node to IR
+ dup #alien-assembly,
+ ! Quotation which coerces return value to required type
+ return-prep-quot infer-quot-here ;
+
: callback-xt ( word return-rewind -- alien )
[ callbacks get ] dip '[ _ <callback> ] cache ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel prettyprint io debugger
+USING: accessors arrays kernel prettyprint io debugger
sequences assocs stack-checker.errors summary effects ;
IN: stack-checker.errors.prettyprint
M: unbalanced-branches-error error.
dup summary print
- [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
+ [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: too-many->r summary
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors
definitions math math.order effects classes arrays combinators
: make-copies ( values effect-in -- values' )
[ length cut* ] keep
[ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
- [ make-values ] dip append ;
+ [ length make-values ] dip append ;
SYMBOL: enter-in
SYMBOL: enter-out
-! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays
classes continuations.private effects generic hashtables
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
- peek-d literal value>> second 1 + { tuple } <effect>
+ peek-d literal value>> second 1 + "obj" <array> { tuple } <effect>
apply-word/effect ;
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
+\ alien-assembly [ infer-alien-assembly ] "special" set-word-prop
\ alien-callback [ infer-alien-callback ] "special" set-word-prop
: infer-special ( word -- )
\ word-xt { word } { integer integer } define-primitive
\ word-xt make-flushable
-\ getenv { fixnum } { object } define-primitive
-\ getenv make-flushable
+\ special-object { fixnum } { object } define-primitive
+\ special-object make-flushable
-\ setenv { object fixnum } { } define-primitive
+\ set-special-object { object fixnum } { } define-primitive
\ (exists?) { string } { object } define-primitive
ARTICLE: "inference-simple" "Straight-line stack effects"
"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words."
$nl
-"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "."
+"Pushing a literal has stack effect " { $snippet "( -- x )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "."
$nl
"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet."
$nl
"An example:"
-{ $example "[ 1 2 3 ] infer." "( -- object object object )" }
+{ $example "[ 1 2 3 ] infer." "( -- x x x )" }
"Another example:"
-{ $example "[ 2 + ] infer." "( object -- object )" } ;
+{ $example "[ 2 + ] infer." "( x -- x )" } ;
ARTICLE: "inference-combinators" "Combinator stack effects"
"If a word calls a combinator, one of the following two conditions must hold for the stack checker to succeed:"
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
-{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( object object -- object )" }
+{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( x x -- x )" }
"The equivalent code using " { $vocab-link "fry" } " and " { $vocab-link "locals" } " likewise passes the stack checker:"
-{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( object object -- object )" }
-{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( object object -- object )" }
+{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( x x -- x )" }
+{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( x x -- x )" }
{ $subheading "Defining an inline combinator" }
"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":"
-{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" }
+{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( x -- x )" }
{ $subheading "Defining a combinator for unknown quotations" }
"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:"
{ $code
}
"To make this work, use " { $link dip } " to pass the quotation instead:"
{ $example
- "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )"
+ "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( x -- x )"
} ;
ARTICLE: "inference-branches" "Branch stack effects"
"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "."
$nl
"If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example,"
-{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" }
+{ $example "[ [ + ] [ drop ] if ] infer." "( x x x -- x )" }
"The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ;
ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects"
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
{ $unchecked-example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" }
"However a small change can be made:"
-{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
+{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( x -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
{ $code
": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline"
ERROR: custom-error ;
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error ] infer
] unit-test
: funny-throw ( a -- * ) throw ; inline
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ 3 funny-throw ] infer
] unit-test
-[ T{ effect f 0 0 t } ] [
+[ T{ effect f { } { } t } ] [
[ custom-error inference-error ] infer
] unit-test
-[ T{ effect f 1 2 t } ] [
+[ T{ effect f { "x" } { "x" "x" } t } ] [
[ dup [ 3 throw ] dip ] infer
] unit-test
[ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with
[ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with
-[ \ set-callstack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with
-[ ] [ [ \ set-callstack def>> infer ] try ] unit-test
+[ \ set-datastack def>> infer ] [ T{ unknown-primitive-error } = ] must-fail-with
+[ ] [ [ \ set-datastack def>> infer ] try ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io effects namespaces sequences quotations vocabs
-vocabs.loader generic words stack-checker.backend stack-checker.state
+USING: accessors kernel io effects namespaces sequences
+quotations vocabs vocabs.loader generic words
+stack-checker.backend stack-checker.state
stack-checker.known-words stack-checker.transforms
stack-checker.errors stack-checker.inlining
stack-checker.visitor.dummy ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ;
+
+: inputs ( quot -- n ) infer in>> length ;
+
+: outputs ( quot -- n ) infer out>> length ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs arrays namespaces sequences kernel definitions
math effects accessors words fry classes.algebra
: current-stack-height ( -- n ) meta-d length input-count get - ;
: current-effect ( -- effect )
- input-count get meta-d length terminated? get effect boa ;
+ input-count get "x" <array>
+ meta-d length "x" <array>
+ terminated? get effect boa ;
: init-inference ( -- )
terminated? off
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: stack-checker.visitor kernel ;
IN: stack-checker.visitor.dummy
M: f #drop, drop ;
M: f #alien-invoke, drop ;
M: f #alien-indirect, drop ;
+M: f #alien-assembly, drop ;
M: f #alien-callback, drop ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays namespaces ;
IN: stack-checker.visitor
HOOK: #copy, stack-visitor ( inputs outputs -- )
HOOK: #alien-invoke, stack-visitor ( params -- )
HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-assembly, stack-visitor ( params -- )
HOOK: #alien-callback, stack-visitor ( params -- )
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences fry math.order splitting ;
IN: strings.tables
<PRIVATE
: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+ [ dup length iota <reversed> ] dip '[ 0 = @ ] 2map ; inline
: max-length ( seq -- n )
[ length ] [ max ] map-reduce ;
<PRIVATE
: suffixes ( string -- suffixes-seq )
- dup length [ tail-slice ] with map ;
+ dup length iota [ tail-slice ] with map ;
: prefix<=> ( begin seq -- <=> )
[ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
USING: namespaces io tools.test threads kernel
concurrency.combinators concurrency.promises locals math
-words ;
+words calendar sequences ;
IN: threads.tests
3 "x" set
[ f ] [ f get-global ] unit-test
{ { 0 3 6 9 12 15 18 21 24 27 } } [
- 10 [
+ 10 iota [
0 "i" tset
[
"i" [ yield 3 + ] tchange
[ t ] [ spawn-namespace-test ] unit-test
[ "a" [ 1 1 + ] spawn 100 sleep ] must-fail
+
+[ ] [ 0.1 seconds sleep ] unit-test
variables
sleep-entry ;
-: self ( -- thread ) 63 getenv ; inline
+: self ( -- thread ) 63 special-object ; inline
! Thread-local storage
: tnamespace ( -- assoc )
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads ( -- assoc ) 64 getenv ;
+: threads ( -- assoc ) 64 special-object ;
: thread ( id -- thread ) threads at ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
-: set-self ( thread -- ) 63 setenv ; inline
+: set-self ( thread -- ) 63 set-special-object ; inline
PRIVATE>
: <thread> ( quot name -- thread )
\ thread new-thread ;
-: run-queue ( -- dlist ) 65 getenv ;
+: run-queue ( -- dlist ) 65 special-object ;
-: sleep-queue ( -- heap ) 66 getenv ;
+: sleep-queue ( -- heap ) 66 special-object ;
: resume ( thread -- )
f >>state
<PRIVATE
: init-threads ( -- )
- H{ } clone 64 setenv
- <dlist> 65 setenv
- <min-heap> 66 setenv
+ H{ } clone 64 set-special-object
+ <dlist> 65 set-special-object
+ <min-heap> 66 set-special-object
initial-thread global
[ drop [ ] "Initial" <thread> ] cache
<box> >>continuation
'[ drop _ member? not ] assoc-filter
[ drop string? not ] assoc-filter ! strip CLI args
sift-assoc
- 21 setenv
+ 21 set-special-object
] [ drop ] if ;
: strip-c-io ( -- )
strip-c-io
strip-default-methods
strip-compiler-classes
- f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
+ f 5 set-special-object ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-startup-quot
find-megamorphic-caches
stripped-word-props
: objc-error ( error -- ) die ;
-[ [ die ] 19 setenv ] "cocoa.application" add-startup-hook
+[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
H{ } clone \ pool [
global [
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays strings sequences sequences.private ascii
fry kernel words parser lexer assocs math math.order summary ;
[ [ ascii? ] all? ] both? [ bad-tr ] unless ;
: compute-tr ( quot from to -- mapping )
- [ 128 ] 3dip zip
+ [ 128 iota ] 3dip zip
'[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
-MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
+MACRO: infer-in ( class -- quot ) inputs '[ _ ] ;
: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
MACRO: write-tuple ( class -- quot )
[ '[ [ _ boa ] undo ] ]
- [ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
+ [ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
PRIVATE>
<mock-gadget> over <model> >>model
"g" get over add-gadget drop
swap 1 + number>string set
- ] each ;
+ ] each-integer ;
: status-flags ( -- seq )
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
USING: ui.gadgets.packs ui.gadgets.packs.private
ui.gadgets.labels ui.gadgets ui.gadgets.debug ui.render
ui.baseline-alignment kernel namespaces tools.test math.parser
-sequences math.rectangles accessors ;
+sequences math.rectangles accessors math ;
IN: ui.gadgets.packs.tests
[ t ] [
{ 0 0 } { 100 100 } <rect> clip set
<pile>
- 100 [ number>string <label> add-gadget ] each
+ 100 [ number>string <label> add-gadget ] each-integer
dup layout
visible-children [ label? ] all?
[ ] [ #children "num-children" set ] unit-test
[ ] [
- "pane" get <pane-stream> [ 100 [ . ] each ] with-output-stream*
+ "pane" get <pane-stream> [ 100 [ . ] each-integer ] with-output-stream*
] unit-test
[ t ] [ #children "num-children" get = ] unit-test
"s" set
[ t ] [
- 10 [
+ 10 iota [
drop
"g2" get scroll>gadget
"s" get layout
IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
-[ t ] [ [ ] [ ] { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+[ t ] [ [ ] [ ] { { 1 1 } { 2 2 } { 3 3 } } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.pens.gradient ;
+USING: tools.test ui.pens.gradient ui.pens.gradient.private
+colors.constants specialized-arrays alien.c-types ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.gradient.tests
+
+[
+ float-array{
+ 0.0
+ 0.0
+ 0.0
+ 100.0
+ 50.0
+ 0.0
+ 50.0
+ 100.0
+ 100.0
+ 0.0
+ 100.0
+ 100.0
+ }
+] [
+ { 1 0 } { 100 100 } { COLOR: red COLOR: green COLOR: blue }
+ gradient-vertices
+] unit-test
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
- colors length dup 1 - v/n [ v*n ] with map
+ colors length [ iota ] [ 1 - ] bi v/n [ v*n ] with map
swap [ over v+ 2array ] curry map
concat concat >float-array ;
utf8 file-lines
[ "#" split1 drop ] map harvest [
"÷" split
- [ "×" split [ [ blank? ] trim hex> ] map harvest >string ] map
+ [
+ "×" split
+ [ [ blank? ] trim hex> ] map
+ [ { f 0 } member? not ] filter
+ >string
+ ] map
harvest
] map ;
grapheme-break-test parse-test-file [ >graphemes ] test
word-break-test parse-test-file [ >words ] test
-[ { t f t t f t } ] [ 6 [ "as df" word-break-at? ] map ] unit-test
+[ { t f t t f t } ] [ 6 iota [ "as df" word-break-at? ] map ] unit-test
: make-grapheme-table ( -- )
{ CR } { LF } connect
- { Control CR LF } graphemes disconnect
- graphemes { Control CR LF } disconnect
+ { Control CR LF } graphemes iota disconnect
+ graphemes iota { Control CR LF } disconnect
{ L } { L V LV LVT } connect
{ LV V } { V T } connect
{ LVT T } { T } connect
- graphemes { Extend } connect
- graphemes { SpacingMark } connect
- { Prepend } graphemes connect ;
+ graphemes iota { Extend } connect
+ graphemes iota { SpacingMark } connect
+ { Prepend } graphemes iota connect ;
VALUE: grapheme-table
: make-word-table ( -- )
{ wCR } { wLF } connect
- { wNewline wCR wLF } words disconnect
- words { wNewline wCR wLF } disconnect
+ { wNewline wCR wLF } words iota disconnect
+ words iota { wNewline wCR wLF } disconnect
{ wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
{ wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
{ wNumeric wALetter } { wNumeric wALetter } connect
over tail-slice first-word + ;
: last-word ( str -- i )
- [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+ [ length iota ] keep '[ _ word-break-at? ] find-last drop 0 or ;
: last-word-from ( end str -- i )
swap head-slice last-word ;
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
- dup possible-bases dup length\r
+ dup possible-bases dup length iota\r
[ ?combine ] with with any?\r
[ drop ] [ 1string , ] if\r
] if ;\r
: exclusions ( -- set )
exclusions-file utf8 file-lines
- [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ;
+ [ "#" split1 drop [ blank? ] trim-tail hex> ] map
+ [ 0 = not ] filter ;
: remove-exclusions ( alist -- alist )
exclusions [ dup ] H{ } map>assoc assoc-diff ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc
-sequences continuations byte-arrays strings math namespaces
-system combinators vocabs.loader accessors
-stack-checker macros locals generalizations unix.types
-io vocabs classes.struct unix.time alien.libraries ;
+USING: alien alien.c-types alien.syntax kernel libc sequences
+continuations byte-arrays strings math namespaces system
+combinators combinators.smart vocabs.loader accessors
+stack-checker macros locals generalizations unix.types io vocabs
+classes.struct unix.time alien.libraries ;
IN: unix
CONSTANT: PROT_NONE 0
ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- )
- quot infer in>> :> n
+ quot inputs :> n
quot first :> word
[
n ndup quot call dup 0 < [
USING: unrolled-lists tools.test deques kernel sequences
-random prettyprint grouping ;
+random prettyprint grouping math ;
IN: unrolled-lists.tests
[ 1 ] [ <unrolled-list> 1 over push-front pop-front ] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-back ] replicate
nip
] unit-test
[ { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } ] [
<unrolled-list>
- 32 [ over push-front ] each
+ 32 [ over push-front ] each-integer
32 [ dup pop-front ] replicate reverse
nip
] unit-test
<unrolled-list>
1000 [ 1000 random ] replicate
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
[ ]
tri
=
[
10 group [
[ [ over push-front ] each ]
- [ [ dup pop-back ] replicate ]
+ [ length [ dup pop-back ] replicate ]
bi
] map concat
] keep
-! Copyright (C) 2009 Phil Dawes.
+! Copyright (C) 2009, 2010 Phil Dawes, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
{ callstack-top void* }
{ callstack-bottom void* }
{ datastack cell }
-{ callstack cell }
+{ retainstack cell }
{ magic-frame void* }
{ datastack-region void* }
{ retainstack-region void* }
{ nursery zone }
{ cards-offset cell }
{ decks-offset cell }
-{ userenv cell[70] } ;
+{ special-objects cell[70] } ;
: vm-field-offset ( field -- offset ) vm offset-of ; inline
: >64bit ( lo hi -- n )
32 shift bitor ; inline
-: windows-1601 ( -- timestamp )
- 1601 1 1 0 0 0 instant <timestamp> ;
+: windows-1601 ( -- timestamp ) 1601 <year-gmt> ;
: FILETIME>windows-time ( FILETIME -- n )
[ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ;
-USING: accessors assocs combinators continuations fry generalizations
-io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.traversal xml.writer arrays xml.data ;
+USING: accessors assocs combinators combinators.smart
+continuations fry generalizations io.pathnames kernel macros
+sequences stack-checker tools.test xml xml.traversal xml.writer
+arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
CONSTANT: base "vocab:xml/tests/xmltest/"
-MACRO: drop-output ( quot -- newquot )
- dup infer out>> '[ @ _ ndrop ] ;
-
-MACRO: drop-input ( quot -- newquot )
- infer in>> '[ _ ndrop ] ;
+MACRO: drop-inputs ( quot -- newquot )
+ inputs '[ _ ndrop ] ;
: fails? ( quot -- ? )
- [ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
+ [ drop-outputs f ] [ nip drop-inputs t ] bi-curry recover ; inline
: well-formed? ( uri -- answer )
[ file>xml ] fails? "not-wf" "valid" ? ;
get-char [ missing-close ] unless next ;
: expect ( string -- )
- dup spot get '[ _ [ char>> ] keep next* ] replicate
+ dup length spot get '[ _ [ char>> ] keep next* ] "" replicate-as
2dup = [ 2drop ] [ expected ] if ;
! Suddenly XML-specific
OS=
ARCH=
WORD=
-NO_UI=
+NO_UI=${NO_UI-}
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
SCRIPT_ARGS="$*"
exit_script() {
if [[ $FIND_MAKE_TARGET -eq true ]] ; then
- echo $MAKE_TARGET;
- fi
- exit $1
+ echo $MAKE_TARGET;
+ fi
+ exit $1
}
ensure_program_installed() {
}
check_X11_libraries() {
- check_library_exists GL
- check_library_exists X11
- check_library_exists pango-1.0
+ if [ -z "$NO_UI" ]; then
+ check_library_exists GL
+ check_library_exists X11
+ check_library_exists pango-1.0
+ fi
}
check_libraries() {
update_script() {
update_script=`update_script_name`
-
- echo "#!/bin/sh" >"$update_script"
+ bash_path=`which bash`
+ echo "#!$bash_path" >"$update_script"
echo "git pull \"$GIT_URL\" master" >>"$update_script"
echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
>>"$update_script"
update_boot_images() {
echo "Deleting old images..."
$DELETE checksums.txt* > /dev/null 2>&1
- # delete boot images with one or two characters after the dot
+ # delete boot images with one or two characters after the dot
$DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
$DELETE temp/staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
USING: byte-arrays arrays help.syntax help.markup
alien.syntax compiler definitions math libc eval
debugger parser io io.backend system alien.accessors
-alien.libraries ;
+alien.libraries alien.c-types quotations ;
IN: alien
HELP: alien
HELP: c-ptr
{ $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
+HELP: alien-invoke-error
+{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
+ { $list
+ { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
+ { "The return type or parameter list references an unknown C type." }
+ { "The symbol or library could not be found." }
+ { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
+ }
+} ;
+
HELP: alien-invoke
{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected." }
+{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ;
HELP: alien-indirect-error
-{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
+{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
- { "The return type or parameter list references an unknown C type." }
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
}
} ;
HELP: alien-indirect
{ $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description
- "Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $snippet "\"void\"" } " indicates that no value is to be expected."
+ "Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
{ $errors "Throws an " { $link alien-indirect-error } " if the word calling " { $link alien-indirect } " is not compiled." } ;
HELP: alien-callback-error
-{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
+{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
- { "The return type or parameter list references an unknown C type." }
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
}
} ;
HELP: alien-callback
-{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
+{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "alien" alien } }
{ $description
"Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
-{ alien-invoke alien-indirect alien-callback } related-words
+HELP: alien-assembly-error
+{ $error-description "Thrown if the word calling " { $link alien-assembly } " was not compiled with the optimizing compiler. This may be a result of one of two failure conditions:"
+ { $list
+ { "This can happen when experimenting with " { $link alien-assembly } " in this listener. To fix the problem, place the " { $link alien-assembly } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
+ { "One of the four inputs to " { $link alien-assembly } " is not a literal value." }
+ }
+} ;
+
+HELP: alien-assembly
+{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } }
+{ $description
+ "Invokes arbitrary machine code, generated at compile-time by the quotation. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
+}
+{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
+{ $errors "Throws an " { $link alien-assembly-error } " if the word calling " { $link alien-assembly } " is not compiled." } ;
+
+{ alien-invoke alien-indirect alien-assembly alien-callback } related-words
ARTICLE: "alien-expiry" "Alien expiry"
"When an image is loaded, any alien objects which persisted from the previous session are marked as having expired. This is because the C pointers they contain are almost certainly no longer valid."
{ $subsections alien-indirect }
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
-HELP: alien-invoke-error
-{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
- { $list
- { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
- { "The return type or parameter list references an unknown C type." }
- { "The symbol or library could not be found." }
- { "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
- }
-} ;
-
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsections
POSTPONE: &:
} ;
+ARTICLE: "alien-assembly" "Calling arbitrary assembly code"
+"It is possible to write a word whose body consists of arbitrary assembly code. The assembly receives parameters and returns values as per the platform's ABI; marshalling and unmarshalling Factor values is taken care of by the C library interface, as with " { $link alien-invoke } "."
+$nl
+"Assembler opcodes are defined in CPU-specific vocabularies:"
+{ $list
+ { $vocab-link "cpu.arm.assembler" }
+ { $vocab-link "cpu.ppc.assembler" }
+ { $vocab-link "cpu.x86.assembler" }
+}
+"The combinator for generating arbitrary assembly by calling a quotation at compile time:"
+{ $subsection alien-assembly } ;
+
ARTICLE: "dll.private" "DLL handles"
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
$nl
"c-data"
"classes.struct"
"alien-globals"
+ "alien-assembly"
"dll.private"
"embedding"
} ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays init ;
ERROR: alien-indirect-error ;
-: alien-indirect ( ... funcptr return parameters abi -- )
+: alien-indirect ( ... funcptr return parameters abi -- ... )
alien-indirect-error ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
2over alien-invoke-error ;
+ERROR: alien-assembly-error code ;
+
+: alien-assembly ( ... return parameters abi quot -- ... )
+ dup alien-assembly-error ;
+
! Callbacks are registered in a global hashtable. Note that they
! are also pinned in a special callback area, so clearing this
! hashtable will not reclaim callbacks. It should only be
M: sequence string>symbol [ string>symbol* ] map ;
[
- 8 getenv utf8 alien>string string>cpu \ cpu set-global
- 9 getenv utf8 alien>string string>os \ os set-global
+ 8 special-object utf8 alien>string string>cpu \ cpu set-global
+ 9 special-object utf8 alien>string string>os \ os set-global
] "alien.strings" add-startup-hook
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math sequences.private vectors
accessors ;
M: enum delete-at seq>> remove-nth! drop ; inline
M: enum >alist ( enum -- alist )
- seq>> [ length ] keep zip ; inline
+ seq>> [ length iota ] keep zip ; inline
M: enum assoc-size seq>> length ; inline
[ create dup 1quotation ] dip define-declared ;
{
- { "(execute)" "kernel.private" (( word -- )) }
- { "(call)" "kernel.private" (( quot -- )) }
- { "both-fixnums?" "math.private" (( x y -- ? )) }
- { "fixnum+fast" "math.private" (( x y -- z )) }
- { "fixnum-fast" "math.private" (( x y -- z )) }
- { "fixnum*fast" "math.private" (( x y -- z )) }
- { "fixnum-bitand" "math.private" (( x y -- z )) }
- { "fixnum-bitor" "math.private" (( x y -- z )) }
- { "fixnum-bitxor" "math.private" (( x y -- z )) }
- { "fixnum-bitnot" "math.private" (( x -- y )) }
- { "fixnum-mod" "math.private" (( x y -- z )) }
- { "fixnum-shift-fast" "math.private" (( x y -- z )) }
- { "fixnum/i-fast" "math.private" (( x y -- z )) }
- { "fixnum/mod-fast" "math.private" (( x y -- z w )) }
- { "fixnum+" "math.private" (( x y -- z )) }
- { "fixnum-" "math.private" (( x y -- z )) }
- { "fixnum*" "math.private" (( x y -- z )) }
- { "fixnum<" "math.private" (( x y -- ? )) }
- { "fixnum<=" "math.private" (( x y -- z )) }
- { "fixnum>" "math.private" (( x y -- ? )) }
- { "fixnum>=" "math.private" (( x y -- ? )) }
+ { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
+ { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+ { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "drop" "kernel" (( x -- )) }
{ "2drop" "kernel" (( x y -- )) }
{ "3drop" "kernel" (( x y z -- )) }
{ "swap" "kernel" (( x y -- y x )) }
{ "eq?" "kernel" (( obj1 obj2 -- ? )) }
{ "tag" "kernel.private" (( object -- n )) }
+ { "(execute)" "kernel.private" (( word -- )) }
+ { "(call)" "kernel.private" (( quot -- )) }
+ { "unwind-native-frames" "kernel.private" (( -- )) }
+ { "set-callstack" "kernel.private" (( cs -- * )) }
+ { "lazy-jit-compile" "kernel.private" (( -- )) }
+ { "c-to-factor" "kernel.private" (( -- )) }
{ "slot" "slots.private" (( obj m -- value )) }
{ "get-local" "locals.backend" (( n -- obj )) }
{ "load-local" "locals.backend" (( obj -- )) }
{ "drop-locals" "locals.backend" (( n -- )) }
- { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
- { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
- { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
+ { "both-fixnums?" "math.private" (( x y -- ? )) }
+ { "fixnum+fast" "math.private" (( x y -- z )) }
+ { "fixnum-fast" "math.private" (( x y -- z )) }
+ { "fixnum*fast" "math.private" (( x y -- z )) }
+ { "fixnum-bitand" "math.private" (( x y -- z )) }
+ { "fixnum-bitor" "math.private" (( x y -- z )) }
+ { "fixnum-bitxor" "math.private" (( x y -- z )) }
+ { "fixnum-bitnot" "math.private" (( x -- y )) }
+ { "fixnum-mod" "math.private" (( x y -- z )) }
+ { "fixnum-shift-fast" "math.private" (( x y -- z )) }
+ { "fixnum/i-fast" "math.private" (( x y -- z )) }
+ { "fixnum/mod-fast" "math.private" (( x y -- z w )) }
+ { "fixnum+" "math.private" (( x y -- z )) }
+ { "fixnum-" "math.private" (( x y -- z )) }
+ { "fixnum*" "math.private" (( x y -- z )) }
+ { "fixnum<" "math.private" (( x y -- ? )) }
+ { "fixnum<=" "math.private" (( x y -- z )) }
+ { "fixnum>" "math.private" (( x y -- ? )) }
+ { "fixnum>=" "math.private" (( x y -- ? )) }
} [ first3 make-sub-primitive ] each
! Primitive words
{ "float-u>=" "math.private" (( x y -- ? )) }
{ "(word)" "words.private" (( name vocab -- word )) }
{ "word-xt" "words" (( word -- start end )) }
- { "getenv" "kernel.private" (( n -- obj )) }
- { "setenv" "kernel.private" (( obj n -- )) }
+ { "special-object" "kernel.private" (( n -- obj )) }
+ { "set-special-object" "kernel.private" (( obj n -- )) }
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "retainstack" "kernel" (( -- rs )) }
{ "callstack" "kernel" (( -- cs )) }
- { "set-datastack" "kernel" (( ds -- )) }
- { "set-retainstack" "kernel" (( rs -- )) }
- { "set-callstack" "kernel" (( cs -- * )) }
+ { "set-datastack" "kernel.private" (( ds -- )) }
+ { "set-retainstack" "kernel.private" (( rs -- )) }
{ "(exit)" "system" (( n -- )) }
{ "data-room" "memory" (( -- data-room )) }
{ "code-room" "memory" (( -- code-room )) }
USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
+prettyprint math ;\r
IN: byte-vectors.tests\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
: do-it ( seq -- seq )\r
- 123 [ over push ] each ;\r
+ 123 [ over push ] each-integer ;\r
\r
[ t ] [\r
3 <byte-vector> do-it\r
\r
! class<=>\r
\r
-[ +lt+ ] [ integer sequence class<=> ] unit-test\r
[ +lt+ ] [ sequence object class<=> ] unit-test\r
[ +gt+ ] [ object sequence class<=> ] unit-test\r
[ +eq+ ] [ integer integer class<=> ] unit-test\r
10 [\r
[ ] [\r
20 [ random-op ] [ ] replicate-as\r
- [ infer in>> [ random-class ] times ] keep\r
+ [ infer in>> length [ random-class ] times ] keep\r
call\r
drop\r
] unit-test\r
20 [\r
[ t ] [\r
20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> [ random-boolean ] replicate dup . ] keep\r
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
\r
[ [ [ ] each ] dip call ] 2keep\r
\r
: execute-effect-unsafe ( word effect -- ) drop execute ;
-M: object throw 5 getenv [ die ] or (( error -- * )) call-effect-unsafe ;
+M: object throw
+ 5 special-object [ die ] or
+ (( error -- * )) call-effect-unsafe ;
PRIVATE>
USING: compiler definitions compiler.units tools.test arrays sequences words kernel
-accessors namespaces fry eval ;
+accessors namespaces fry eval quotations math ;
IN: compiler.units.tests
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
observer remove-definition-observer
+
+! Make sure that non-optimized calls to a generic word which
+! hasn't been compiled yet work properly
+GENERIC: uncompiled-generic-test ( a -- b )
+
+M: integer uncompiled-generic-test 1 + ;
+
+<< [ uncompiled-generic-test ] [ jit-compile ] [ suffix! ] bi >>
+"q" set
+
+[ 4 ] [ 3 "q" get call ] unit-test
+
+[ ] [ [ \ uncompiled-generic-test forget ] with-compilation-unit ] unit-test
! Incremented each time stack effects potentially changed, used
! by compiler.tree.propagation.call-effect for call( and execute(
! inline caching
-: effect-counter ( -- n ) 47 getenv ; inline
+: effect-counter ( -- n ) 47 special-object ; inline
GENERIC: bump-effect-counter* ( defspec -- ? )
or ;
: bump-effect-counter ( -- )
- bump-effect-counter? [ 47 getenv 0 or 1 + 47 setenv ] when ;
+ bump-effect-counter? [
+ 47 special-object 0 or
+ 1 +
+ 47 set-special-object
+ ] when ;
: notify-observers ( -- )
updated-definitions dup assoc-empty?
] with-scope
] callcc0 "x" get 5 = ;
-[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
+[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with
<PRIVATE
: catchstack* ( -- catchstack )
- 1 getenv { vector } declare ; inline
+ 1 special-object { vector } declare ; inline
: >c ( continuation -- ) catchstack* push ;
: dummy-1 ( -- obj ) f ;
: dummy-2 ( obj -- obj ) dup drop ;
-: init-catchstack ( -- ) V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
PRIVATE>
: catchstack ( -- catchstack ) catchstack* clone ; inline
-: set-catchstack ( catchstack -- ) >vector 1 setenv ; inline
+: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
TUPLE: continuation data call retain name catch ;
: continue-with ( obj continuation -- * )
[
- swap 4 setenv
+ swap 4 set-special-object
>continuation<
set-catchstack
set-namestack
set-retainstack
- [ set-datastack drop 4 getenv f 4 setenv f ] dip
+ [ set-datastack drop 4 special-object f 4 set-special-object f ] dip
set-callstack
] (( obj continuation -- * )) call-effect-unsafe ;
! VM calls on error
[
! 63 = self
- 63 getenv error-thread set-global
+ 63 special-object error-thread set-global
continuation error-continuation set-global
rethrow
- ] 5 setenv
+ ] 5 set-special-object
! VM adds this to kernel errors, so that user-space
! can identify them
- "kernel-error" 6 setenv ;
+ "kernel-error" 6 set-special-object ;
PRIVATE>
{ $values { "obj" object } { "str" string } }
{ $description "Turns a stack effect object into a string mnemonic." }
{ $examples
- { $example "USING: effects io ;" "1 2 <effect> effect>string print" "( object -- object object )" }
+ { $example "USING: effects io ;" "{ \"x\" } { \"y\" \"z\" } <effect> effect>string print" "( x -- y z )" }
} ;
HELP: stack-effect
quotations sequences ;
IN: effects.tests
-[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
+[ t ] [ { "a" } { "a" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" } { } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ t ] [ { "a" "b" } { "a" "b" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" "c" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
+[ f ] [ { "a" "b" } { "a" "b" "c" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.order namespaces make sequences strings
words assocs combinators accessors arrays quotations ;
IN: effects
-TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
-
-GENERIC: effect-length ( obj -- n )
-M: sequence effect-length length ;
-M: integer effect-length ;
+TUPLE: effect
+{ in array read-only }
+{ out array read-only }
+{ terminated? read-only } ;
: <effect> ( in out -- effect )
- dup { "*" } sequence= [ drop { } t ] [ f ] if
+ dup { "*" } = [ drop { } t ] [ f ] if
effect boa ;
: effect-height ( effect -- n )
- [ out>> effect-length ] [ in>> effect-length ] bi - ; inline
+ [ out>> length ] [ in>> length ] bi - ; inline
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
- { [ 2dup [ in>> effect-length ] bi@ > ] [ f ] }
+ { [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ; inline
: effect= ( effect1 effect2 -- ? )
- [ [ in>> effect-length ] bi@ = ]
- [ [ out>> effect-length ] bi@ = ]
+ [ [ in>> length ] bi@ = ]
+ [ [ out>> length ] bi@ = ]
[ [ terminated?>> ] bi@ = ]
2tri and and ;
M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
: stack-picture ( seq -- string )
- dup integer? [ "object" <repetition> ] when
[ [ effect>string % CHAR: \s , ] each ] "" make ;
M: effect effect>string ( effect -- string )
GENERIC: effect>type ( obj -- type )
M: object effect>type drop object ;
M: word effect>type ;
-! attempting to specialize on callable breaks compiling
-! M: effect effect>type drop callable ;
M: pair effect>type second effect>type ;
+: effect-in-types ( effect -- input-types )
+ in>> [ effect>type ] map ;
+
+: effect-out-types ( effect -- input-types )
+ out>> [ effect>type ] map ;
+
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect "declared-effect" word-prop ;
stack-effect effect-height ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
- in>> effect-length cut* ;
+ in>> length cut* ;
: shuffle-mapping ( effect -- mapping )
[ out>> ] [ in>> ] bi [ index ] curry map ;
over terminated?>> [
drop
] [
- [ [ [ in>> effect-length ] [ out>> effect-length ] bi ] [ in>> effect-length ] bi* swap [-] + ]
- [ [ out>> effect-length ] [ [ in>> effect-length ] [ out>> effect-length ] bi ] bi* [ [-] ] dip + ]
+ [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+ [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
- [ [ [ "obj" ] replicate ] bi@ ] dip
+ [ [ "x" <array> ] bi@ ] dip
effect boa
] if ; inline
-
-: effect-in-types ( effect -- input-types )
- in>> [ effect>type ] map ;
-: effect-out-types ( effect -- input-types )
- out>> [ effect>type ] map ;
{ $code
"GENERIC: explain ( object -- )"
"M: object explain drop \"an object\" print ;"
- "M: number explain drop \"a number\" print ;"
- "M: sequence explain drop \"a sequence\" print ;"
+ "M: generic explain drop \"a class word\" print ;"
+ "M: class explain drop \"a generic word\" print ;"
}
"The linear order is the following, from least-specific to most-specific:"
-{ $code "{ object sequence number }" }
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"Now, the linear order is the following, from least-specific to most-specific:"
-{ $code "{ object sequence number integer }" }
+{ $code "{ object generic class }" }
+"Neither " { $link class } " nor " { $link generic } " are subclasses of each other, and their intersection is non-empty. Calling " { $snippet "explain" } " with a word on the stack that is both a class and a generic word will print " { $snippet "a generic word" } " because " { $link class } " precedes " { $link generic } " in the class linearization order. (One example of a word which is both a class and a generic word is the class of classes, " { $link class } ", which is also a word to get the class of an object.)"
+$nl
"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsections order } ;
continuations ;
IN: hashtables.tests
-[ f ] [ "hi" V{ 1 2 3 } at ] unit-test
-
[ H{ } ] [ { } [ dup ] H{ } map>assoc ] unit-test
-[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
+[ ] [ 1000 iota [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
+[ 1000 iota [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]
! Resource leak...
H{ } "x" set
-100 [ drop "x" get clear-assoc ] each
+100 [ drop "x" get clear-assoc ] each-integer
! Crash discovered by erg
[ t ] [ 0.75 <hashtable> dup clone = ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
! Random test case
-[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
+[ "A" ] [ 100 iota [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
: boot ( -- ) init-namespaces init-catchstack init-error-handler ;
-: startup-quot ( -- quot ) 20 getenv ;
+: startup-quot ( -- quot ) 20 special-object ;
-: set-startup-quot ( quot -- ) 20 setenv ;
+: set-startup-quot ( quot -- ) 20 set-special-object ;
-: shutdown-quot ( -- quot ) 22 getenv ;
+: shutdown-quot ( -- quot ) 22 special-object ;
-: set-shutdown-quot ( quot -- ) 22 setenv ;
+: set-shutdown-quot ( quot -- ) 22 set-special-object ;
[ do-shutdown-hooks ] set-shutdown-quot
[ 3 ] [ 2 "lápis" >utf8-index ] unit-test
-[ V{ } ] [ 100000 [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
+[ V{ } ] [ 100000 iota [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test
[
cwd current-directory set-global
- 13 getenv alien>native-string cwd prepend-path \ image set-global
- 14 getenv alien>native-string cwd prepend-path \ vm set-global
+ 13 special-object alien>native-string cwd prepend-path \ image set-global
+ 14 special-object alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-startup-hook
M: c-io-backend init-io ;
-: stdin-handle ( -- alien ) 11 getenv ;
-: stdout-handle ( -- alien ) 12 getenv ;
-: stderr-handle ( -- alien ) 61 getenv ;
+: stdin-handle ( -- alien ) 11 special-object ;
+: stdout-handle ( -- alien ) 12 special-object ;
+: stderr-handle ( -- alien ) 61 special-object ;
: init-c-stdio ( -- )
stdin-handle <c-reader>
{ $values { "object" object } { "n" "a tag number" } }
{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-HELP: getenv ( n -- obj )
+HELP: special-object ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }
-{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Reads an object from the Factor VM's special object table. User code never has to read the special object table directly; instead, use one of the callers of this word." } ;
-HELP: setenv ( obj n -- )
+HELP: set-special-object ( obj n -- )
{ $values { "obj" object } { "n" "a non-negative integer" } }
-{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
+{ $description "Writes an object to the Factor VM's special object table. User code never has to write to the special object table directly; instead, use one of the callers of this word." } ;
HELP: object
{ $class-description
! We do this in its own compilation unit so that they can be
! folded below
<<
-: cell ( -- n ) 7 getenv ; foldable
+: cell ( -- n ) 7 special-object ; foldable
: (first-bignum) ( m -- n ) tag-bits get - 1 - 2^ ; foldable
>>
-USING: kernel math math.constants tools.test sequences
+USING: kernel math math.constants math.order tools.test sequences
grouping ;
IN: math.floats.tests
[ 0 ] [ 1/0. >bignum ] unit-test
-[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
+[ t ] [ 64 iota [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
[ 5 ] [ 10.5 1.9 /i ] unit-test
[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test
[ 1.5 ] [ -1.5 abs ] unit-test
[ 1.5 ] [ 1.5 abs ] unit-test
+
+[ 5.0 ] [ 3 5.0 max ] unit-test
+[ 3 ] [ 3 5.0 min ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2004, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.private ;
+USING: kernel math math.private math.order ;
IN: math.floats.private
: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
M: float u> float-u> ; inline
M: float u>= float-u>= ; inline
+M: float min over float? [ float-min ] [ call-next-method ] if ; inline
+M: float max over float? [ float-max ] [ call-next-method ] if ; inline
+
M: float + float+ ; inline
M: float - float- ; inline
M: float * float* ; inline
-USING: kernel math math.functions namespaces prettyprint
-math.private continuations tools.test sequences random ;
+USING: kernel math math.functions math.order namespaces
+prettyprint math.private continuations tools.test sequences
+random ;
IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
random-integer
random-integer
[ >float / ] [ /f ] 2bi 0.1 ~
- ] all?
+ ] all-integers?
] unit-test
! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms
[ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test
[ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test
+
+[ 17 ] [ 17 >bignum 5 max ] unit-test
+[ 5 ] [ 17 >bignum 5 min ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private sequences
-sequences.private math math.private combinators ;
+USING: kernel kernel.private sequences sequences.private math
+math.private math.order combinators ;
IN: math.integers.private
: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable
M: fixnum u> fixnum> ; inline
M: fixnum u>= fixnum>= ; inline
+M: fixnum min over fixnum? [ fixnum-min ] [ call-next-method ] if ; inline
+M: fixnum max over fixnum? [ fixnum-max ] [ call-next-method ] if ; inline
+
M: fixnum + fixnum+ ; inline
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
{ $examples "This word is equivalent to " { $link if-zero } " with an empty first quotation:"
{ $example
"USING: sequences math prettyprint ;"
- "3 [ ] [ sq ] if-empty ."
+ "3 [ ] [ sq ] if-zero ."
"9"
}
{ $example
} ;
HELP: max
-{ $values { "x" object } { "y" object } { "z" object } }
+{ $values { "obj1" object } { "obj2" object } { "obj" object } }
{ $description "Outputs the greatest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: min
-{ $values { "x" object } { "y" object } { "z" object } }
+{ $values { "obj1" object } { "obj2" object } { "obj" object } }
{ $description "Outputs the smallest of two ordered values." }
{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
HELP: clamp
{ $values { "x" object } { "min" object } { "max" object } { "y" object } }
-{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
+{ $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or else outputs one of the endpoints." } ;
HELP: between?
{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math ;
IN: math.order
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
-: min ( x y -- z ) [ before? ] most ;
-: max ( x y -- z ) [ after? ] most ;
+GENERIC: min ( obj1 obj2 -- obj )
+GENERIC: max ( obj1 obj2 -- obj )
+
+M: object min [ before? ] most ; inline
+M: object max [ after? ] most ; inline
+
: clamp ( x min max -- y ) [ max ] dip min ; inline
: between? ( x y z -- ? )
ABOUT: "number-strings"
HELP: digits>integer
-{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 16" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: >digit
-{ $values { "n" "an integer between 0 and 35" } { "ch" "a character" } }
+{ $values { "n" "an integer between 0 and 15" } { "ch" "a character" } }
{ $description "Outputs a character representation of a digit." }
{ $notes "This is one of the factors of " { $link number>string } "." } ;
{ $notes "This is one of the factors of " { $link string>number } "." } ;
HELP: base>
-{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } }
+{ $values { "str" string } { "radix" "an integer between 2 and 16" } { "n/f" "a real number or " { $link f } } }
{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10."
$nl
"Outputs " { $link f } " if the string does not represent a number." } ;
{ >hex POSTPONE: HEX: hex> .h } related-words
HELP: >base
-{ $values { "n" real } { "radix" "an integer between 2 and 36" } { "str" string } }
+{ $values { "n" real } { "radix" "an integer between 2 and 16" } { "str" string } }
{ $description "Converts a real number into a string representation using the given radix. If the number is a float, the radix is ignored and the output is always in base 10." } ;
HELP: >bin
<PRIVATE
-: namestack* ( -- namestack ) 0 getenv { vector } declare ; inline
+: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
-: set-namestack ( namestack -- ) >vector 0 setenv ;
-: global ( -- g ) 21 getenv { hashtable } declare ; inline
+: set-namestack ( namestack -- ) >vector 0 set-special-object ;
+: global ( -- g ) 21 special-object { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; inline
: set ( value variable -- ) namespace set-at ;
execute( accum -- accum ) ;
: scan-object ( -- object )
- scan-word dup parsing-word?
- [ V{ } clone swap execute-parsing first ] when ;
+ scan-word {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup parsing-word? ] [ V{ } clone swap execute-parsing first ] }
+ [ ]
+ } cond ;
: parse-step ( accum end -- accum ? )
scan-word {
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] SBUF" " map-as length class ] unit-test
{ "quot" quotation } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
- "10 [ even? ] pusher [ each ] dip ."
+ "10 iota [ even? ] pusher [ each ] dip ."
"V{ 0 2 4 6 8 }"
}
{ $notes "Used to implement the " { $link filter } " word. Compare this word with " { $link accumulator } ", which is an unfiltering version." } ;
HELP: replicate
{ $values
- { "seq" sequence } { "quot" { $quotation "( -- elt )" } }
+ { "len" integer } { "quot" { $quotation "( -- elt )" } }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
{ $examples
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
HELP: replicate-as
{ $values
- { "seq" sequence } { "quot" quotation } { "exemplar" sequence }
+ { "len" integer } { "quot" quotation } { "exemplar" sequence }
{ "newseq" sequence } }
-{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the exemplar sequence." }
+ { $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;"
"5 [ 100 random ] B{ } replicate-as ."
"B{ 44 8 2 33 18 }"
}
} ;
+
{ replicate replicate-as } related-words
HELP: partition
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
{ $example "USING: prettyprint sequences math ;"
- "40 rest-slice 1 [ * ] binary-reduce ."
+ "40 iota rest-slice 1 [ * ] binary-reduce ."
"20397882081197443358640281739902897356800000000" }
} ;
"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
$nl
"Implementations include the following:"
-{ $subsections reversed slice iota }
-"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence." ;
+{ $subsections reversed slice }
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence."
+{ $see-also "sequences-integers" } ;
ARTICLE: "sequences-integers" "Counted loops"
-"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
+"A virtual sequence is defined for iterating over integers from zero."
+{ $subsection iota }
+"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
-"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
-{ $example "3 [ . ] each" "0\n1\n2" }
+"This means the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
+{ $example "3 iota [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
-"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer."
+"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an instance of " { $link iota } "."
$nl
"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
-[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
-[ 3 ] [ 1 4 dup <slice> length ] unit-test
+[ V{ 1 2 3 4 } ] [ 1 5 dup iota <slice> >vector ] unit-test
+[ 3 ] [ 1 4 dup iota <slice> length ] unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ V{ 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
[ V{ 4 5 } ] [ { 1 2 3 4 5 } 2 tail-slice* >vector ] unit-test
-[ V{ 3 4 } ] [ 2 4 1 10 dup <slice> subseq >vector ] unit-test
-[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup <slice> <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 2 4 1 10 dup iota <slice> subseq >vector ] unit-test
+[ V{ 3 4 } ] [ 0 2 2 4 1 10 dup iota <slice> <slice> subseq >vector ] unit-test
[ 0 10 "hello" <slice> ] must-fail
[ -10 3 "hello" <slice> ] must-fail
[ 2 1 "hello" <slice> ] must-fail
[ { 1 3 2 4 } ] [ { 1 2 3 4 } clone 1 2 pick exchange ] unit-test
[ { "" "a" "aa" "aaa" } ]
-[ 4 [ CHAR: a <string> ] map ]
+[ 4 [ CHAR: a <string> ] { } map-integers ]
unit-test
[ V{ } ] [ "f" V{ } clone remove! ] unit-test
[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone remove! ] unit-test
[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone remove! ] unit-test
-[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
+[ V{ 0 1 4 5 } ] [ 6 iota >vector 2 4 pick delete-slice ] unit-test
[ 6 >vector 2 8 pick delete-slice ] must-fail
-[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
+[ V{ } ] [ 6 iota >vector 0 6 pick delete-slice ] unit-test
[ { 1 2 "a" "b" 5 6 7 } ] [
{ "a" "b" } 2 4 { 1 2 3 4 5 6 7 }
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
-[ 3 ] [ 3 10 nth ] unit-test
-[ 3 ] [ 3 10 nth-unsafe ] unit-test
-[ -3 10 nth ] must-fail
-[ 11 10 nth ] must-fail
+[ 3 ] [ 3 10 iota nth ] unit-test
+[ 3 ] [ 3 10 iota nth-unsafe ] unit-test
+[ -3 10 iota nth ] must-fail
+[ 11 10 iota nth ] must-fail
[ -1/0. 0 remove-nth! ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
-[ 328350 ] [ 100 [ sq ] map-sum ] unit-test
+[ 328350 ] [ 100 iota [ sq ] map-sum ] unit-test
-[ 50 ] [ 100 [ even? ] count ] unit-test
-[ 50 ] [ 100 [ odd? ] count ] unit-test
+[ 50 ] [ 100 iota [ even? ] count ] unit-test
+[ 50 ] [ 100 iota [ odd? ] count ] unit-test
[ { "b" "d" } ] [ { 1 3 } { "a" "b" "c" "d" } nths ] unit-test
[ { "a" "b" "c" "d" } ] [ { 0 1 2 3 } { "a" "b" "c" "d" } nths ] unit-test
-! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private slots.private math
math.private math.order ;
INSTANCE: f immutable-sequence
-! Integers used to support the sequence protocol
-M: integer length ; inline
-M: integer nth-unsafe drop ; inline
-
-INSTANCE: integer immutable-sequence
-
PRIVATE>
! In the future, this will replace integer sequences
: map ( seq quot -- newseq )
over map-as ; inline
-: replicate ( seq quot -- newseq )
- [ drop ] prepose map ; inline
+: replicate-as ( len quot exemplar -- newseq )
+ [ [ drop ] prepose ] dip map-integers ; inline
-: replicate-as ( seq quot exemplar -- newseq )
- [ [ drop ] prepose ] dip map-as ; inline
+: replicate ( len quot -- newseq )
+ { } replicate-as ; inline
: map! ( seq quot -- seq )
over [ map-into ] keep ; inline
(2each) all-integers? ; inline
: 3each ( seq1 seq2 seq3 quot -- )
- (3each) each ; inline
+ (3each) each-integer ; inline
: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
[ (3each) ] dip map-integers ; inline
[ { } ] [ { } natural-sort ] unit-test
[ { 270000000 270000001 } ]
-[ T{ slice f 270000000 270000002 270000002 } natural-sort ]
+[ T{ slice f 270000000 270000002 T{ iota f 270000002 } } natural-sort ]
unit-test
[ t ] [
100 [ 20 random [ 1000 random ] replicate ] replicate
dup natural-sort
[ set= ] [ nip [ before=? ] monotonic? ] 2bi and
- ] all?
+ ] all-integers?
] unit-test
[ ] [ { 1 2 } [ 2drop 1 ] sort drop ] unit-test
M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
- [ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
+ [ [ line#>> 0 or ] sort-with ] { } assoc-map-as sort-keys ;
: group-by-source-file ( errors -- assoc )
H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
drop
300 100 CHAR: \u123456
[ <string> clone resize-string first ] keep =
- ] all?
+ ] all-integers?
] unit-test
: vm ( -- path ) \ vm get-global ;
-: embedded? ( -- ? ) 15 getenv ;
+: embedded? ( -- ? ) 15 special-object ;
: exit ( n -- ) do-shutdown-hooks (exit) ;
[ 4 ] [ 5 V{ 1 2 3 4 5 } index ] unit-test
[ t ] [
- 100 >array dup >vector <reversed> >array [ reverse ] dip =
+ 100 iota >array dup >vector <reversed> >array [ reverse ] dip =
] unit-test
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
-[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
+[ fixnum ] [ 1 >bignum iota [ ] V{ } map-as length class ] unit-test
[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test
[ end-game ]
[ dup quit? [ quit-game ] [ repeat ] if ]
if ;
-: build-quad ( -- array ) 4 [ 10 random ] replicate >array ;
+: build-quad ( -- array ) 4 [ 10 random ] replicate ;
: 24-able? ( quad -- t/f ) [ makes-24? ] with-datastack first ;
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel locals math.vectors
-math.vectors.conversion math math.vectors.simd sequences
+math.vectors.conversion math math.vectors.simd math.ranges sequences
specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ;
SPECIALIZED-ARRAYS: int float float-4 uchar-16 ;
B{ 15 25 35 45 55 65 75 85 95 105 115 125 135 145 155 165 }
fold-rgba-planes
] unit-test
+
+: data-map-compiler-bug-test ( n -- byte-array )
+ [ 0.0 1.0 1.0 ] dip /f <range>
+ [ ] data-map( object -- float ) ;
+
+[ float-array{ 0.0 0.5 1.0 } ]
+[ 2 data-map-compiler-bug-test byte-array>float-array ]
+unit-test
IN: benchmark.base64
: base64-benchmark ( -- )
- 65535 [ 255 bitand ] "" map-as
+ 65535 iota [ 255 bitand ] "" map-as
20 [ >base64 base64> ] times
drop ;
: count-ones ( int-array -- n ) [ 1 = ] count ; inline
: make-int-array ( -- int-array )
- 120000 [ 255 bitand ] int-array{ } map-as ; inline
+ 120000 iota [ 255 bitand ] int-array{ } map-as ; inline
: dawes-benchmark ( -- )
200 make-int-array '[ _ count-ones ] replicate drop ;
: sequences ( -- seq )
[
- 1 ,
- 10 >bignum ,
+ 1 iota ,
+ 10 >bignum iota ,
{ 1 2 3 } ,
"hello world" ,
SBUF" sbuf world" ,
double-array{ 1.0 2.0 3.0 } ,
"hello world" 4 tail-slice ,
10 f <repetition> ,
- 100 2 <sliced-groups> ,
+ 100 iota 2 <sliced-groups> ,
"hello" <reversed> ,
{ { 1 2 } { 3 4 } } 0 <column> ,
?{ t f t } ,
20000000 [
20 [
foobar-1 drop
- ] each
+ ] each-integer
] times ;
: foobar-test-2 ( -- )
20000000 [
20 [
foobar-2 drop
- ] each
+ ] each-integer
] times ;
MAIN: foobar-test-1
IN: benchmark.e-decimals
: D-factorial ( n -- D! )
- D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
+ iota D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
:: calculate-e-decimals ( n -- e )
n [1,b] D: 1
IN: benchmark.empty-loop-2
: empty-loop-2 ( n -- )
- [ drop ] each ;
+ iota [ drop ] each ;
: empty-loop-main ( -- )
50000000 empty-loop-2 ;
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
- [ rot drop select-random ] 2curry "" map-as print ; inline
+ [ iota ] 2dip [ [ drop ] 2dip select-random ] 2curry "" map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
:: make-repeat-fasta ( k len alu -- k' )
alu length :> kn
- len [ k + kn mod alu nth-unsafe ] "" map-as print
+ len iota [ k + kn mod alu nth-unsafe ] "" map-as print
k len + ; inline
: write-repeat-fasta ( n alu desc id -- )
USING: math sequences kernel ;
IN: benchmark.gc1
-: gc1 ( -- ) 600000 [ >bignum 1 + ] map drop ;
+: gc1 ( -- ) 600000 iota [ >bignum 1 + ] map drop ;
MAIN: gc1
USING: sequences vectors arrays strings sbufs math math.vectors
kernel ;
-: <range> ( from to -- seq ) dup <slice> ; inline
+: <range> ( from to -- seq ) dup iota <slice> ; inline
: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
: small-groups ( x n -- b )
swap
- [ length swap - 1 + ] 2keep
+ [ length swap - 1 + iota ] 2keep
[ [ over + ] dip subseq ] 2curry map ;
: handle-table ( inputs n -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.functions kernel io io.styles prettyprint
combinators hints fry namespaces sequences ;
IN: benchmark.partial-sums
! Helper words
-: summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1 + @ + ] each ; inline
+: summing-integers ( n quot -- y ) [ 0.0 ] [ iota ] [ ] tri* '[ 1 + @ + ] each ; inline
: summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
: cube ( x -- y ) dup dup * * ; inline
: -1^ ( n -- -1/1 ) 2 mod 2 * 1 - ; inline
USING: io io.files io.files.temp io.encodings.ascii random
-math.parser math ;
+math.parser math sequences ;
IN: benchmark.random
: random-numbers-path ( -- path )
[ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
: ss-grid ( -- ss-grid )
- oversampling [ oversampling [ ss-point ] with map ] map ;
+ oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
: ray-grid ( point ss-grid -- ray-grid )
[
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
- size reverse [
- size [
+ size iota reverse [
+ size iota [
[ size 0.5 * - ] bi@ swap size
0.0 double-4-boa
] with map
[ oversampling /f ] bi@ 0.0 double-array{ } 3sequence ;
: ss-grid ( -- ss-grid )
- oversampling [ oversampling [ ss-point ] with map ] map ;
+ oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
: ray-grid ( point ss-grid -- ray-grid )
[
[ [ swap cast-ray + ] with each ] with each ;
: pixel-grid ( -- grid )
- size reverse [
- size [
+ size iota reverse [
+ size iota [
[ size 0.5 * - ] bi@ swap size
double-array{ } 3sequence
] with map
] times ;
: send-messages ( messages target -- )
- dupd [ send ] curry each [ receive drop ] times ;
+ [ dup iota ] dip [ send ] curry each [ receive drop ] times ;
: destroy-ring ( target -- )
done swap send [ done eq? ] receive-if drop ;
IN: benchmark.spectral-norm
:: inner-loop ( u n quot -- seq )
- n [| i |
- n 0.0 [| j |
+ n iota [| i |
+ n iota 0.0 [| j |
u i j quot call +
] reduce
] double-array{ } map-as ; inline
TUPLE-ARRAY: point
: tuple-array-benchmark ( -- )
- 100 [
+ 100 iota [
drop 5000 <point-array> [
[ 1 + ] change-x
[ 1 - ] change-y
IN: benchmark.ui-panes
: ui-pane-benchmark ( -- )
- <pane> <pane-stream> [ 10000 [ . ] each ] with-output-stream* ;
+ <pane> <pane-stream> [ 10000 iota [ . ] each ] with-output-stream* ;
MAIN: ui-pane-benchmark
h >>uv_height
w >>y_stride
w >>uv_stride
- w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
- w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
- w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
+ w h * iota [ dup * ] B{ } map-as malloc-byte-array &free >>y
+ w h * 2/ iota [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+ w h * 2/ iota [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
: clamp ( n -- n )
255 min 0 max ; inline
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
- pick y_width>>
+ pick y_width>> iota
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
- dup y_height>>
+ dup y_height>> iota
[ yuv>rgb-row ] with with each
drop ;
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
full-bloom-filter
[ bloom-filter-member? ] curry map
- [ ] filter
+ [ ] count
! TODO: This should be 10, but the false positive rate is currently very
! high. 300 is large enough not to prevent builds from succeeding.
- length 300 <=
+ 300 <=
] unit-test
math.functions multiline sequences ;
IN: bloom-filters
-FROM: math.ranges => [1,b] [0,b) ;
+FROM: math.ranges => [1,b] ;
FROM: math.intervals => (a,b) interval-contains? ;
/*
[infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
: enhanced-double-hashes ( hash0 hash1 n -- seq )
- [0,b)
+ iota
[ '[ _ _ enhanced-double-hash ] ] dip
swap map ;
USING: accessors assocs bson.constants calendar fry io io.binary
io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize ;
+sequences serialize locals ;
FROM: kernel.private => declare ;
FROM: io.encodings.private => (read-until) ;
: read-byte ( -- byte )
read-byte-raw first ; inline
-: utf8-read-until ( seps stream encoding -- string/f sep/f )
- [ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ]
- 3curry (read-until) ;
-
: read-cstring ( -- string )
- "\0" input-stream get utf8 utf8-read-until drop ; inline
+ "\0" read-until drop "" like ; inline
: read-sized-string ( length -- string )
- drop read-cstring ; inline
+ read 1 head-slice* "" like ; inline
: read-element-type ( -- type )
read-byte ; inline
-: push-element ( type name -- element )
- element boa
- [ get-state element>> push ] keep ; inline
+: push-element ( type name -- )
+ element boa get-state element>> push ; inline
: pop-element ( -- element )
get-state element>> pop ; inline
drop ;
M: bson-array fix-result ( assoc type -- result )
- drop
- values ;
+ drop values ;
GENERIC: end-element ( type -- )
drop ;
M: object end-element ( type -- )
- drop
- pop-element drop ;
+ pop-element 2drop ;
-M: bson-eoo element-read ( type -- cont? )
- drop
- get-state scope>> [ pop ] keep swap ! vec assoc
- pop-element [ type>> ] keep ! vec assoc element
- [ fix-result ] dip
- rot length 0 > ! assoc element
- [ name>> peek-scope set-at t ]
- [ drop [ get-state ] dip >>result drop f ] if ;
-
-M: bson-not-eoo element-read ( type -- cont? )
- [ peek-scope ] dip ! scope type
- '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
- [ element-data-read ] keep
- end-element
- swap
- ] dip set-at t ;
+M:: bson-eoo element-read ( type -- cont? )
+ pop-element :> element
+ get-state scope>>
+ [ pop element type>> fix-result ] [ empty? ] bi
+ [ [ get-state ] dip >>result drop f ]
+ [ element name>> peek-scope set-at t ] if ;
+
+M:: bson-not-eoo element-read ( type -- cont? )
+ peek-scope :> scope
+ type read-cstring [ push-element ] 2keep
+ [ [ element-data-read ] [ end-element ] bi ]
+ [ scope set-at t ] bi* ;
: [scope-changer] ( state -- state quot )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
read-cstring >>regexp read-cstring >>options ;
M: bson-null element-data-read ( type -- bf )
- drop
- f ;
+ drop f ;
M: bson-oid element-data-read ( type -- oid )
drop
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
-: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
-
: write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline
+: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
M: assoc bson-write ( assoc -- )
- '[ _ [ write-oid ] keep
- [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
- write-eoo ] with-length-prefix ;
+ '[
+ _ [ write-oid ] keep
+ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ write-eoo
+ ] with-length-prefix ;
: (serialize-code) ( code -- )
object>bytes [ length write-int32 ] keep
reverse? [ reverse ] when
'[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
-: scan-constructor ( -- class word )
- scan-word [ name>> "<" ">" surround create-in ] keep ;
+: scan-constructor ( -- word class )
+ scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
: parse-constructor ( -- class word effect def )
scan-constructor complete-effect parse-definition ;
: inv-sbox ( -- array )
256 0 <array>
- dup 256 [ dup sbox nth rot set-nth ] with each ;
+ dup 256 [ dup sbox nth rot set-nth ] with each-integer ;
: rcon ( -- array )
{
MEMO:: t-table ( -- array )
1024 0 <array>
- dup 256 [ set-t ] with each ;
+ dup 256 [ set-t ] with each-integer ;
:: set-d ( D i -- )
i inv-sbox nth :> a1
MEMO:: d-table ( -- array )
1024 0 <array>
- dup 256 [ set-d ] with each ;
+ dup 256 [ set-d ] with each-integer ;
USE: multiline
: test-decimal-op ( quot1 quot2 -- ? )
[ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
-[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
-[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all-integers? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all-integers? ] unit-test
[ t ] [
1000 [
drop
[ [ 100 D/ ] [ /f ] test-decimal-op ]
[ { "kernel-error" 4 f f } = ] recover
- ] all?
+ ] all-integers?
] unit-test
[ t ] [
--- /dev/null
+USING: accessors http.server http.server.filters io.pools kernel
+mongodb.driver mongodb.connection namespaces unix destructors continuations ;
+
+IN: furnace.mongodb
+
+TUPLE: mdb-persistence < filter-responder pool ;
+
+: <mdb-persistence> ( responder mdb -- responder' )
+ <mdb-pool> mdb-persistence boa ;
+
+M: mdb-persistence call-responder*
+ dup pool>> [ mdb-connection set call-next-method ] with-pooled-connection ;
--- /dev/null
+IN: grid-meshes.tests
+USING: alien.c-types grid-meshes grid-meshes.private
+specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: float
+
+[
+ float-array{
+ 0.0 0.0 0.0 1.0
+ 0.0 0.0 0.5 1.0
+ 0.5 0.0 0.0 1.0
+ 0.5 0.0 0.5 1.0
+ 1.0 0.0 0.0 1.0
+ 1.0 0.0 0.5 1.0
+ 0.0 0.0 0.5 1.0
+ 0.0 0.0 1.0 1.0
+ 0.5 0.0 0.5 1.0
+ 0.5 0.0 1.0 1.0
+ 1.0 0.0 0.5 1.0
+ 1.0 0.0 1.0 1.0
+ }
+] [ { 2 2 } vertex-array byte-array>float-array ] unit-test
] map ;
: find-by-id ( vector id -- vector' elt/f )
- '[ attributes>> "id" at _ = ] find ;
+ '[ attributes>> "id" swap at _ = ] find ;
: find-by-class ( vector id -- vector' elt/f )
- '[ attributes>> "class" at _ = ] find ;
+ '[ attributes>> "class" swap at _ = ] find ;
: find-by-name ( vector string -- vector elt/f )
>lower '[ name>> _ = ] find ;
[ t ]
-[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
+[ 10000 iota [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
{ $example
"USING: arrays infix locals ;"
- ":: add-2nd-element ( x y -- res )"
+ ":: add-2nd-elements ( x y -- res )"
" [infix x[1] + y[1] infix] ;"
- "{ 1 2 3 } 5 add-2nd-element ."
+ "{ 1 2 3 } { 0 1 2 3 } add-2nd-elements ."
"3"
}
;
: equally-spaced-radians ( n -- seq )
#! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
+ [ iota ] keep [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
over color>> gl-color segment-vertex-and-normal
: random-float+- ( n -- m )
#! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
+ dup 10000 * >integer random 10000 / swap 2 / - ;
: random-turn ( oint theta -- )
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
[ natural-sort ] keep [ index ] curry map ;
: (inversions) ( n seq -- n )
- [ > ] with filter length ;
+ [ > ] with count ;
: inversions ( seq -- n )
- 0 swap [ length ] keep [
+ 0 swap [ length iota ] keep [
[ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
[ dup length pick nth push ] reduce ;
: nth-basis-elt ( generators n -- elt )
- over length [
+ over length iota [
3dup bit? [ nth ] [ 2drop f ] if
] map sift 2nip ;
: basis ( generators -- seq )
- natural-sort dup length 2^ [ nth-basis-elt ] with map ;
+ natural-sort dup length 2^ iota [ nth-basis-elt ] with map ;
: (tensor) ( seq1 seq2 -- seq )
[
dim-im/ker-d ;
: graded-ker/im-d ( graded-basis -- seq )
- [ length ] keep [ (graded-ker/im-d) ] curry map ;
+ [ length iota ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d unzip but-last 0 prefix v- ;
3array ;
:: bigraded-triples ( grid -- triples )
- grid length [| z |
- grid first length [| u |
+ grid length iota [| z |
+ grid first length iota [| u |
u z grid bigraded-triple
] map
] map ;
M: unix really-delete-tree delete-tree ;
: retry ( n quot -- )
+ [ iota ] dip
'[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- )
}
: gamma-z ( x n -- seq )
- [ + recip ] with map 1.0 0 pick set-nth ;
+ [ + recip ] with { } map-integers 1.0 0 pick set-nth ;
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
#! log(gamma(x+1)
first 3digits>text
] [
[ set-conjunction "" ] [ length ] [ ] tri
- [ (recombine) ] curry each
+ [ (recombine) ] curry each-integer
] if ;
: (number>text) ( n -- str )
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
- dup [ drop t <array> ] with map visited set
+ dup
iota [ drop t <array> ] with map visited set
GL_LINE_STRIP glBegin
{ 0 0 } dup vertex (draw-maze)
glEnd ;
! (c)2009 Joe Groff bsd license
USING: accessors arrays bit-arrays classes
-classes.tuple.private fry kernel locals parser
+classes.tuple.private fry kernel locals math parser
sequences sequences.private vectors words ;
IN: memory.pools
: <pool> ( size class -- pool )
[ nip new ]
- [ [ iota ] dip '[ _ new ] V{ } replicate-as ] 2bi
+ [ '[ _ new ] V{ } replicate-as ] 2bi
pool boa ;
: pool-size ( pool -- size )
:: copy-tuple ( from to -- to )
from tuple-size :> size
- size [| n | n from array-nth n to set-array-nth ] each
+ size [| n | n from array-nth n to set-array-nth ] each-integer
to ; inline
: (pool-new) ( pool -- object )
[ index>> bchar ] keep
lasterror>> bchar
trial-size ] dip
- 1000000 / /i
- "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+ 1000000000 / [ /i ] [ result get batch>> [ [ batch-size /i ] dip ] when /i ] 2bi
+ "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s %10s ops/s"
sprintf print flush ;
: print-separator ( -- )
- "----------------------------------------------------------------" print flush ; inline
+ "---------------------------------------------------------------------------------" print flush ; inline
: print-separator-bold ( -- )
- "================================================================" print flush ; inline
+ "=================================================================================" print flush ; inline
: print-header ( -- )
trial-size
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline
-GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
-
-M: mdb-cursor get-more
+: get-more ( mdb-cursor -- mdb-cursor seq )
[ [ query>> dup [ collection>> ] [ return#>> ] bi ]
[ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
[ f f ] if* ;
: <query> ( collection assoc -- mdb-query-msg )
<mdb-query-msg> ; inline
-GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
-
-M: mdb-query-msg limit
+: limit ( mdb-query-msg limit# -- mdb-query-msg )
>>return# ; inline
-GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
-
-M: mdb-query-msg skip
+: skip ( mdb-query-msg skip# -- mdb-query-msg )
>>skip# ; inline
: asc ( key -- spec ) 1 2array ; inline
: desc ( key -- spec ) -1 2array ; inline
: sort ( mdb-query-msg sort-quot -- mdb-query-msg )
- output>array [ 1array >hashtable ] map >>orderby ; inline
+ output>array >hashtable >>orderby ; inline
+
+: filter-fields ( mdb-query-msg filterseq -- mdb-query-msg )
+ [ asc ] map >hashtable >>returnfields ; inline
: key-spec ( spec-quot -- spec-assoc )
output>array >hashtable ; inline
M: mdb-cursor find
get-more ;
-GENERIC: explain. ( mdb-query-msg -- )
-
-M: mdb-query-msg explain.
+: explain. ( mdb-query-msg -- )
t >>explain find nip . ;
-GENERIC: find-one ( mdb-query-msg -- result/f )
-
-M: mdb-query-msg find-one
+: find-one ( mdb-query-msg -- result/f )
fix-query-collection
1 >>return# send-query-plain objects>>
dup empty? [ drop f ] [ first ] if ;
-GENERIC: count ( mdb-query-msg -- result )
-
-M: mdb-query-msg count
+: count ( mdb-query-msg -- result )
[ collection>> "count" H{ } clone [ set-at ] keep ] keep
query>> [ over [ "query" ] dip set-at ] when*
[ cmd-collection ] dip <mdb-query-msg> find-one
PRIVATE>
-GENERIC: save ( collection assoc -- )
-M: assoc save
+: save ( collection assoc -- )
[ check-collection ] dip
<mdb-insert-msg> send-message-check-error ;
-GENERIC: save-unsafe ( collection assoc -- )
-M: assoc save-unsafe
+: save-unsafe ( collection assoc -- )
[ check-collection ] dip
<mdb-insert-msg> send-message ;
-GENERIC: ensure-index ( index-spec -- )
-M: index-spec ensure-index
+: ensure-index ( index-spec -- )
<linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
: >upsert ( mdb-update-msg -- mdb-update-msg )
1 >>upsert? ;
-GENERIC: update ( mdb-update-msg -- )
-M: mdb-update-msg update
+: update ( mdb-update-msg -- )
send-message-check-error ;
-GENERIC: update-unsafe ( mdb-update-msg -- )
-M: mdb-update-msg update-unsafe
+: update-unsafe ( mdb-update-msg -- )
send-message ;
-GENERIC: delete ( collection selector -- )
-M: assoc delete
+: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
-GENERIC: delete-unsafe ( collection selector -- )
-M: assoc delete-unsafe
+: delete-unsafe ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message ;
+: kill-cursor ( mdb-cursor -- )
+ id>> <mdb-killcursors-msg> send-message ;
+
: load-index-list ( -- index-list )
index-collection
H{ } clone <mdb-query-msg> find nip ;
{ return# integer initial: 0 }
{ query assoc }
{ returnfields assoc }
-{ orderby sequence }
+{ orderby assoc }
explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
:: build-query-object ( query -- selector )
H{ } clone :> selector
- query { [ orderby>> [ "orderby" selector set-at ] when* ]
+ query { [ orderby>> [ "$orderby" selector set-at ] when* ]
[ explain>> [ "$explain" selector set-at ] when* ]
[ hint>> [ "$hint" selector set-at ] when* ]
[ query>> "query" selector set-at ]
: canonicalize-specializer-1 ( specializer -- specializer' )
[
[ class? ] filter
- [ length <reversed> [ 1 + neg ] map ] keep zip
+ [ length iota <reversed> [ 1 + neg ] map ] keep zip
[ length args [ max ] change ] keep
]
[
swap "predicate" word-prop append ;
: multi-predicate ( classes -- quot )
- dup length <reversed>
+ dup length iota <reversed>
[ picker 2array ] 2map
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
--- /dev/null
+IN: noise.tests
+USING: noise tools.test sequences math ;
+
+[ t ] [ { 100 100 } perlin-noise-map-coords [ [ 100 <= ] all? ] all? ] unit-test
faded trilerp ;
MEMO: perlin-noise-map-coords ( dim -- coords )
- first2 [| x y | x [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
+ first2 iota [| x y | x iota [ y 0.0 0.0 float-4-boa ] float-4-array{ } map-as ] with map concat ;
TYPED:: perlin-noise-map ( table: byte-array transform: matrix4 coords: float-4-array -- map: float-array )
coords [| coord | table transform coord m4.v perlin-noise ] data-map( float-4 -- c:float )
: range ( r from to -- n )
over - 1 + rot [
- '[ over + @ drop ] each drop f
+ '[ over + @ drop ] each-integer drop f
] bshift 2nip ; inline
[ 55 ] [
: euler001b ( -- answer )
- 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+ 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
- 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+ 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: pad-front ( matrix -- matrix )
[
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ append ] 2map ;
: pad-back ( matrix -- matrix )
<reversed> [
- length [ 0 <repetition> ] map
+ length iota [ 0 <repetition> ] map
] keep [ <reversed> append ] 2map ;
: diagonal/ ( -- matrix )
[ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ;
: euler014 ( -- answer )
- 1000000 [1,b] 0 [ collatz longest ] reduce first ;
+ 1000000 [1,b] { } [ collatz longest ] reduce first ;
! [ euler014 ] time
! 52868 ms run / 483 ms GC time
PRIVATE>
: euler014a ( -- answer )
- 500000 1000000 [a,b] 1 [
+ 500000 1000000 [a,b] { 1 } [
dup worth-calculating? [ collatz longest ] [ drop ] if
] reduce first ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.combinatorics math.parser project-euler.common ;
+USING: kernel math.combinatorics math.parser project-euler.common
+sequences ;
IN: project-euler.024
! http://projecteuler.net/index.php?section=problems&id=24
! --------
: euler024 ( -- answer )
- 999999 10 permutation 10 digits>integer ;
+ 999999 10 iota permutation 10 digits>integer ;
! [ euler024 ] 100 ave-time
! 0 ms ave run time - 0.27 SD (100 trials)
<PRIVATE
: source-027 ( -- seq )
- 1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
+ 1000 iota [ prime? ] filter [ dup [ neg ] map append ] keep
cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )
PRIVATE>
: euler030 ( -- answer )
- 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1 - ;
+ 325537 iota [ dup sum-fifth-powers = ] filter sum 1 - ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1 + ] map 10 digits>integer
+ 9 iota permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
: interesting? ( seq -- ? )
{
- [ 17 8 rot subseq-divisible? ]
- [ 13 7 rot subseq-divisible? ]
- [ 11 6 rot subseq-divisible? ]
- [ 7 5 rot subseq-divisible? ]
- [ 5 4 rot subseq-divisible? ]
- [ 3 3 rot subseq-divisible? ]
- [ 2 2 rot subseq-divisible? ]
+ [ [ 17 8 ] dip subseq-divisible? ]
+ [ [ 13 7 ] dip subseq-divisible? ]
+ [ [ 11 6 ] dip subseq-divisible? ]
+ [ [ 7 5 ] dip subseq-divisible? ]
+ [ [ 5 4 ] dip subseq-divisible? ]
+ [ [ 3 3 ] dip subseq-divisible? ]
+ [ [ 2 2 ] dip subseq-divisible? ]
} 1&& ;
PRIVATE>
[ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 swap diff prepend ;
+ dup natural-sort 10 iota swap diff prepend ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
<PRIVATE
: map-nx ( n x -- seq )
- [ 1 + * ] with map ; inline
+ iota [ 1 + * ] with map ; inline
: all-same-digits? ( seq -- ? )
[ number>digits natural-sort ] map all-equal? ;
! --------
: euler053 ( -- answer )
- 23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] map-sum ;
+ 23 100 [a,b] [ dup iota [ nCk 1000000 > ] with count ] map-sum ;
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)
PRIVATE>
: euler055 ( -- answer )
- 10000 [0,b) [ lychrel? ] count ;
+ 10000 iota [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
- 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
+ 0 1000 iota [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
! [ euler057 ] 100 ave-time
! 1728 ms ave run time - 80.81 SD (100 trials)
3dup minimal-path-sum-to '[ _ + ] change-matrix ;
: (euler081) ( matrix -- n )
- dup first length [0,b) dup cartesian-product
+ dup first length iota dup cartesian-product
[ first2 pick update-minimal-path-sum ] each
last last ;
:: (euler150) ( m -- n )
sums-triangle :> table
- m [| x |
- x 1 + [| y |
- m x - [0,b) [| z |
+ m iota [| x |
+ x 1 + iota [| y |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1 + swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
{ { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1 + ] }
{ { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1 + ] }
{ { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1 + ] }
- [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+ [ [ dup length iota [ pick-sheet ] with map sum ] [ sum ] bi / ]
} case ] cache ;
: euler151 ( -- answer )
<PRIVATE
: next-keys ( key -- keys )
- [ last ] [ 10 swap sum - ] bi [ 2array ] with map ;
+ [ last ] [ 10 swap sum - iota ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
<PRIVATE
: max-children ( seq -- seq )
- [ dup length 1 - [ nth-pair max , ] with each ] { } make ;
+ [ dup length 1 - iota [ nth-pair max , ] with each ] { } make ;
! Propagate one row into the upper one
: propagate ( bottom top -- newtop )
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
[ first3 ] dip head 3array ;
: strip-tease ( data -- seq )
- dup third length 1 - [
+ dup third length 1 - iota [
2 + (strip-tease)
] with map ;
] with-compilation-unit ;
: test-inference ( ast -- in# out# )
- test-compilation infer [ in>> ] [ out>> ] bi ;
+ test-compilation infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
[ 2 1 ] [
T{ ast-block f
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators effects generic generic.standard
+USING: arrays combinators effects generic generic.standard
kernel sequences words lexer ;
IN: smalltalk.selectors
: selector>effect ( selector -- effect )
dup selector-type {
- { unary [ drop 0 ] }
- { binary [ drop 1 ] }
- { keyword [ [ CHAR: : = ] count ] }
+ { unary [ drop { } ] }
+ { binary [ drop { "x" } ] }
+ { keyword [ [ CHAR: : = ] count "x" <array> ] }
} case "receiver" suffix { "result" } <effect> ;
: selector>generic ( selector -- generic )
--- /dev/null
+IN: sudoku.tests
+USING: tools.test sudoku ;
+
+[ ] [ sudoku-demo ] unit-test
: box-any? ( n x y -- ? )
[ 3 /i 3 * ] bi@
- 9 [ [ 3dup ] dip cell-any? ] any?
+ 9 iota [ [ 3dup ] dip cell-any? ] any?
[ 3drop ] dip ;
DEFER: search
[ assume ]
} cond ;
-: solve ( x y -- ) 9 [ 1 + 2over attempt ] each 2drop ;
+: solve ( x y -- ) 9 [ 1 + 2over attempt ] each-integer 2drop ;
: board. ( board -- )
standard-table-style [
] each
] with-row
] each
- ] tabular-output ;
+ ] tabular-output nl ;
: solution. ( -- )
solutions inc "Solution:" print board get board. ;
: fica-base-rate ( year -- x )
H{
+ { 2009 106800 }
{ 2008 102000 }
{ 2007 97500 }
} at [ fica-base-unknown ] unless* ;
TUPLE: board { width integer } { height integer } rows ;
: make-rows ( width height -- rows )
- [ drop f <array> ] with map ;
+
iota [ drop f <array> ] with map ;
: <board> ( width height -- board )
2dup make-rows board boa ;
: block-free? ( board block -- ? ) block not ;
: block-in-bounds? ( board block -- ? )
- [ first swap width>> bounds-check? ] 2keep
- second swap height>> bounds-check? and ;
+ [ first swap width>> iota bounds-check? ]
+ [ second swap height>> iota bounds-check? ] 2bi and ;
: location-valid? ( board block -- ? )
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
[ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
- dup length -rot [ (draw-row) ] 2curry each ;
+ [ length iota swap ] keep [ (draw-row) ] 2curry each ;
: draw-board ( board -- )
- rows>> dup length swap
+ rows>> [ length iota ] keep
[ dupd nth draw-row ] curry each ;
: scale-board ( width height board -- )
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
- 100 [ drop 100 random swap at drop ] with each ;
+ 100 iota [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ conjoin ] curry each ] keep ;
+ iota <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
-PLAF_DLL_OBJS += vmpp/cpu-arm.o
+
-CFLAGS += -DWINDOWS -mno-cygwin
+CFLAGS += -mno-cygwin
LIBS = -lm
PLAF_DLL_OBJS += vm/os-windows.o
SHARED_FLAG = -shared
-BOOT_ARCH = x86
-PLAF_DLL_OBJS += vm/cpu-x86.32.o
+
-PLAF_DLL_OBJS += vm/cpu-x86.64.o
-CFLAGS += -DFACTOR_64
+
+++ /dev/null
-#if defined(__APPLE__) || (defined(WINDOWS) && !defined(__arm__))
- #define MANGLE(sym) _##sym
-#else
- #define MANGLE(sym) sym
-#endif
-
-/* Apple's PPC assembler is out of date? */
-#if defined(__APPLE__) && defined(__ppc__)
- #define XX @
-#else
- #define XX ;
-#endif
-
-/* The returns and args are just for documentation */
-#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \
-MANGLE(symbol)
callbacks = new callback_heap(size,this);
}
-void callback_heap::update(code_block *stub)
+void callback_heap::store_callback_operand(code_block *stub, cell index, cell value)
{
tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
- cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
- cell rel_type = untag_fixnum(array_nth(code_template.untagged(),2));
- cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
+ cell rel_class = untag_fixnum(array_nth(code_template.untagged(),3 * index + 1));
+ cell rel_type = untag_fixnum(array_nth(code_template.untagged(),3 * index + 2));
+ cell offset = untag_fixnum(array_nth(code_template.untagged(),3 * index + 3));
relocation_entry rel(
(relocation_type)rel_type,
offset);
instruction_operand op(rel,stub,0);
- op.store_value((cell)callback_xt(stub));
+ op.store_value(value);
+}
+void callback_heap::update(code_block *stub)
+{
+ store_callback_operand(stub,1,(cell)callback_xt(stub));
stub->flush_icache();
}
memcpy(stub->xt(),insns->data<void>(),size);
+ /* Store VM pointer */
+ store_callback_operand(stub,0,(cell)parent);
+
/* On x86, the RET instruction takes an argument which depends on
the callback's calling convention */
- if(array_capacity(code_template.untagged()) == 7)
- {
- cell rel_class = untag_fixnum(array_nth(code_template.untagged(),4));
- cell rel_type = untag_fixnum(array_nth(code_template.untagged(),5));
- cell offset = untag_fixnum(array_nth(code_template.untagged(),6));
-
- relocation_entry rel(
- (relocation_type)rel_type,
- (relocation_class)rel_class,
- offset);
-
- instruction_operand op(rel,stub,0);
- op.store_value(return_rewind);
- }
+#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
+ store_callback_operand(stub,2,return_rewind);
+#endif
update(stub);
return w->xt;
}
+ void store_callback_operand(code_block *stub, cell index, cell value);
+
void update(code_block *stub);
+
code_block *add(cell owner, cell return_rewind);
void update();
ctx->push(tag<callstack>(stack));
}
-void factor_vm::primitive_set_callstack()
-{
- callstack *stack = untag_check<callstack>(ctx->pop());
-
- set_callstack(this,
- ctx->callstack_bottom,
- stack->top(),
- untag_fixnum(stack->length),
- memcpy);
-
- /* We cannot return here ... */
- critical_error("Bug in set_callstack()",0);
-}
-
code_block *factor_vm::frame_code(stack_frame *frame)
{
check_frame(frame);
quotation *q = (quotation *)obj;
if(q->code)
parent->set_quot_xt(q,visitor(q->code));
- else
- q->xt = (void *)lazy_jit_compile_impl;
break;
}
case CALLSTACK_TYPE:
else
{
quotation *quot = untag<quotation>(tagged_quot);
- if(quot->code)
+ if(quot_compiled_p(quot))
return (cell)quot->xt;
else
return (cell)w->xt;
+++ /dev/null
-#include "asm.h"
-
-/* Note that the XT is passed to the quotation in r12 */
-#define CALL_QUOT \
- ldr r12,[r0, #9] /* load quotation-xt slot */ ; \
- mov lr,pc ; \
- mov pc,r12
-
-#define JUMP_QUOT \
- ldr r12,[r0, #9] /* load quotation-xt slot */ ; \
- mov pc,r12
-
-#define SAVED_REGS_SIZE 32
-
-#define FRAME (RESERVED_SIZE + SAVED_REGS_SIZE + 8)
-
-#define LR_SAVE [sp, #-4]
-#define RESERVED_SIZE 8
-
-#define SAVE_LR str lr,LR_SAVE
-
-#define LOAD_LR ldr lr,LR_SAVE
-
-#define SAVE_AT(offset) (RESERVED_SIZE + 4 * offset)
-
-#define SAVE(register,offset) str register,[sp, #SAVE_AT(offset)]
-
-#define RESTORE(register,offset) ldr register,[sp, #SAVE_AT(offset)]
-
-#define PROLOGUE \
- SAVE_LR ; \
- sub sp,sp,#FRAME
-
-#define EPILOGUE \
- add sp,sp,#FRAME ; \
- LOAD_LR
-
-DEF(void,c_to_factor,(CELL quot)):
- PROLOGUE
-
- SAVE(r4,0) /* save GPRs */
- /* don't save ds pointer */
- /* don't save rs pointer */
- SAVE(r7,3)
- SAVE(r8,4)
- SAVE(r9,5)
- SAVE(r10,6)
- SAVE(r11,7)
- SAVE(r0,8) /* save quotation since we're about to mangle it */
-
- sub r0,sp,#4 /* pass call stack pointer as an argument */
- bl MANGLE(save_callstack_bottom)
-
- RESTORE(r0,8) /* restore quotation */
- CALL_QUOT
-
- RESTORE(r11,7) /* restore GPRs */
- RESTORE(r10,6)
- RESTORE(r9,5)
- RESTORE(r8,4)
- RESTORE(r7,3)
- /* don't restore rs pointer */
- /* don't restore ds pointer */
- RESTORE(r4,0)
-
- EPILOGUE
- mov pc,lr
-
-/* The JIT compiles an 'mov r1',sp in front of every primitive call, since a
-word which was defined as a primitive will not change its definition for the
-lifetime of the image -- adding new primitives requires a bootstrap. However,
-an undefined word can certainly become defined,
-
-DEFER: foo
-...
-: foo ... ;
-
-And calls to non-primitives do not have this one-instruction prologue, so we
-set the XT of undefined words to this symbol. */
-DEF(void,undefined,(CELL word)):
- sub r1,sp,#4
- b MANGLE(undefined_error)
-
-/* Here we have two entry points. The first one is taken when profiling is
-enabled */
-DEF(void,docol_profiling,(CELL word)):
- ldr r1,[r0, #25] /* load profile-count slot */
- add r1,r1,#8 /* increment count */
- str r1,[r0, #25] /* store profile-count slot */
-DEF(void,docol,(CELL word)):
- ldr r0,[r0, #13] /* load word-def slot */
- JUMP_QUOT
-
-/* We must pass the XT to the quotation in r12. */
-DEF(void,primitive_call,(void)):
- ldr r0,[r5], #-4 /* load quotation from data stack */
- JUMP_QUOT
-
-/* We must preserve r1 here in case we're calling a primitive */
-DEF(void,primitive_execute,(void)):
- ldr r0,[r5], #-4 /* load word from data stack */
- ldr pc,[r0, #29] /* jump to word-xt */
-
-DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length)):
- sub sp,r0,r2 /* compute new stack pointer */
- mov r0,sp /* start of destination of memcpy() */
- sub sp,sp,#12 /* alignment */
- bl MANGLE(memcpy) /* go */
- add sp,sp,#16 /* point SP at innermost frame */
- ldr pc,LR_SAVE /* return */
-
-DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
- add sp,r1,#4 /* compute new stack pointer */
- ldr lr,LR_SAVE /* we have rewound the stack; load return address */
- JUMP_QUOT /* call the quotation */
-
-DEF(void,lazy_jit_compile,(CELL quot)):
- mov r1,sp /* save stack pointer */
- PROLOGUE
- bl MANGLE(lazy_jit_compile_impl)
- EPILOGUE
- JUMP_QUOT /* call the quotation */
-
-#ifdef WINCE
- .section .drectve
- .ascii " -export:c_to_factor"
-#endif
#define FACTOR_CPU_STRING "arm"
-register cell ds asm("r5");
-register cell rs asm("r6");
-
#define FRAME_RETURN_ADDRESS(frame,vm) *(XT *)(vm->frame_successor(frame) + 1)
-void c_to_factor(cell quot);
-void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
-void throw_impl(cell quot, stack_frame *rewind);
-void lazy_jit_compile(cell quot);
-
}
-/* Parts of this file were snarfed from SBCL src/runtime/ppc-assem.S, which is
-in the public domain. */
-#include "asm.h"
-
-#define DS_REG r13
-#define RS_REG r14
-#define VM_REG r15
-
-#define CALL_OR_JUMP_QUOT \
- lwz r11,12(r3) /* load quotation-xt slot */ XX \
-
-#define CALL_QUOT \
- CALL_OR_JUMP_QUOT XX \
- mtlr r11 /* prepare to call XT with quotation in r3 */ XX \
- blrl /* go */
-
-#define JUMP_QUOT \
- CALL_OR_JUMP_QUOT XX \
- mtctr r11 /* prepare to call XT with quotation in r3 */ XX \
- bctr /* go */
-
-#define PARAM_SIZE 32
-
-#define SAVED_INT_REGS_SIZE 96
-
-#define SAVED_FP_REGS_SIZE 144
-
-#define SAVED_V_REGS_SIZE 208
-
-#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8)
-
-#if defined( __APPLE__)
- #define LR_SAVE 8
- #define RESERVED_SIZE 24
+#if defined(__APPLE__)
+ #define MANGLE(sym) _##sym
+ #define XX @
#else
- #define LR_SAVE 4
- #define RESERVED_SIZE 8
+ #define MANGLE(sym) sym
+ #define XX ;
#endif
-#define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
-
-#define LOAD_LR(reg) lwz reg,(LR_SAVE + FRAME)(r1)
-
-#define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
-
-#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
-#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
-
-#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
-#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
-
-#define SAVE_V(register,offset) \
- li r2,SAVE_AT(offset) XX \
- stvxl register,r2,r1
-
-#define RESTORE_V(register,offset) \
- li r2,SAVE_AT(offset) XX \
- lvxl register,r2,r1
-
-#define PROLOGUE \
- mflr r0 XX /* get caller's return address */ \
- stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
- SAVE_LR(r0)
-
-#define EPILOGUE \
- LOAD_LR(r0) XX \
- lwz r1,0(r1) XX /* destroy the stack frame */ \
- mtlr r0 /* get ready to return */
-
-/* We have to save and restore nonvolatile registers because
-the Factor compiler treats the entire register file as volatile. */
-DEF(void,c_to_factor,(cell quot, void *vm)):
- PROLOGUE
-
- SAVE_INT(r13,0)
- SAVE_INT(r14,1)
- SAVE_INT(VM_REG,2)
- SAVE_INT(r16,3)
- SAVE_INT(r17,4)
- SAVE_INT(r18,5)
- SAVE_INT(r19,6)
- SAVE_INT(r20,7)
- SAVE_INT(r21,8)
- SAVE_INT(r22,9)
- SAVE_INT(r23,10)
- SAVE_INT(r24,11)
- SAVE_INT(r25,12)
- SAVE_INT(r26,13)
- SAVE_INT(r27,14)
- SAVE_INT(r28,15)
- SAVE_INT(r29,16)
- SAVE_INT(r30,17)
- SAVE_INT(r31,18)
-
- SAVE_FP(f14,20)
- SAVE_FP(f15,22)
- SAVE_FP(f16,24)
- SAVE_FP(f17,26)
- SAVE_FP(f18,28)
- SAVE_FP(f19,30)
- SAVE_FP(f20,32)
- SAVE_FP(f21,34)
- SAVE_FP(f22,36)
- SAVE_FP(f23,38)
- SAVE_FP(f24,40)
- SAVE_FP(f25,42)
- SAVE_FP(f26,44)
- SAVE_FP(f27,46)
- SAVE_FP(f28,48)
- SAVE_FP(f29,50)
- SAVE_FP(f30,52)
- SAVE_FP(f31,54)
-
- SAVE_V(v20,56)
- SAVE_V(v21,60)
- SAVE_V(v22,64)
- SAVE_V(v23,68)
- SAVE_V(v24,72)
- SAVE_V(v25,76)
- SAVE_V(v26,80)
- SAVE_V(v27,84)
- SAVE_V(v28,88)
- SAVE_V(v29,92)
- SAVE_V(v30,96)
- SAVE_V(v31,100)
-
- /* r4 vm ptr preserved */
- mfvscr v0
- li r2,SAVE_AT(104)
- stvxl v0,r2,r1
- addi r2,r2,0xc
- lwzx r5,r2,r1
- lis r6,0x1
- andc r5,r5,r6
- stwx r5,r2,r1
- subi r2,r2,0xc
- lvxl v0,r2,r1
- mtvscr v0
-
-
- /* Load context */
- mr VM_REG,r4
- lwz r16,0(VM_REG)
-
- /* Load ctx->datastack */
- lwz DS_REG,8(r16)
-
- /* Load ctx->retainstack */
- lwz RS_REG,12(r16)
-
- /* Save ctx->callstack_bottom */
- stw r1,4(r16)
-
- CALL_QUOT
-
- /* Load context */
- lwz r16,0(VM_REG)
-
- /* Save ctx->datastack */
- stw DS_REG,8(r16)
-
- /* Save ctx->retainstack */
- stw RS_REG,12(r16)
-
- RESTORE_V(v0,104)
- mtvscr v0
-
- RESTORE_V(v31,100)
- RESTORE_V(v30,96)
- RESTORE_V(v29,92)
- RESTORE_V(v28,88)
- RESTORE_V(v27,84)
- RESTORE_V(v26,80)
- RESTORE_V(v25,76)
- RESTORE_V(v24,72)
- RESTORE_V(v23,68)
- RESTORE_V(v22,64)
- RESTORE_V(v21,60)
- RESTORE_V(v20,56)
-
- RESTORE_FP(f31,54)
- RESTORE_FP(f30,52)
- RESTORE_FP(f29,50)
- RESTORE_FP(f28,48)
- RESTORE_FP(f27,46)
- RESTORE_FP(f26,44)
- RESTORE_FP(f25,42)
- RESTORE_FP(f24,40)
- RESTORE_FP(f23,38)
- RESTORE_FP(f22,36)
- RESTORE_FP(f21,34)
- RESTORE_FP(f20,32)
- RESTORE_FP(f19,30)
- RESTORE_FP(f18,28)
- RESTORE_FP(f17,26)
- RESTORE_FP(f16,24)
- RESTORE_FP(f15,22)
- RESTORE_FP(f14,20)
-
- RESTORE_INT(r31,18)
- RESTORE_INT(r30,17)
- RESTORE_INT(r29,16)
- RESTORE_INT(r28,15)
- RESTORE_INT(r27,14)
- RESTORE_INT(r26,13)
- RESTORE_INT(r25,12)
- RESTORE_INT(r24,11)
- RESTORE_INT(r23,10)
- RESTORE_INT(r22,9)
- RESTORE_INT(r21,8)
- RESTORE_INT(r20,7)
- RESTORE_INT(r19,6)
- RESTORE_INT(r18,5)
- RESTORE_INT(r17,4)
- RESTORE_INT(r16,3)
- RESTORE_INT(VM_REG,2)
- RESTORE_INT(r14,1)
- RESTORE_INT(r13,0)
-
- EPILOGUE
- blr
-
-DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length, void *memcpy)):
- /* Save VM pointer in non-volatile register */
- mr VM_REG,r3
-
- /* Compute new stack pointer */
- sub r1,r4,r6
-
- /* Call memcpy() */
- mr r3,r1
- mr r4,r5
- mr r5,r6
- stwu r1,-64(r1)
- mtlr r7
- blrl
- lwz r1,0(r1)
-
- /* Load context */
- lwz r16,0(VM_REG)
-
- /* Load ctx->datastack */
- lwz DS_REG,8(r16)
-
- /* Load ctx->retainstack */
- lwz RS_REG,12(r16)
-
- /* We have changed the stack; load return address again */
- lwz r0,LR_SAVE(r1)
- mtlr r0
- blr
-
-DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)):
- /* compute new stack pointer */
- mr r1,r4
-
- /* make vm ptr 2nd arg in case quot->xt == lazy_jit_compile */
- mr r4,r5
-
- /* Load context */
- mr VM_REG,r5
- lwz r16,0(VM_REG)
-
- /* Load ctx->datastack */
- lwz DS_REG,8(r16)
-
- /* Load ctx->retainstack */
- lwz RS_REG,12(r16)
-
- /* We have changed the stack; load return address again */
- lwz r0,LR_SAVE(r1)
- mtlr r0
-
- /* Call the quotation */
- JUMP_QUOT
-
-DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)):
- /* Load context */
- mr VM_REG,r4
- lwz r16,0(VM_REG)
-
- /* Save ctx->datastack */
- stw DS_REG,8(r16)
-
- /* Save ctx->retainstack */
- stw RS_REG,12(r16)
-
- /* Save ctx->callstack_top */
- stw r1,0(r16)
-
- /* Compile quotation */
- PROLOGUE
- bl MANGLE(lazy_jit_compile)
- EPILOGUE
-
- /* Call the quotation */
- JUMP_QUOT
+/* The returns and args are just for documentation */
+#define DEF(returns,symbol,args) .globl MANGLE(symbol) XX \
+MANGLE(symbol)
/* Thanks to Joshua Grams for this code.
On PowerPC processors, we must flush the instruction cache manually
after writing to the code heap. */
-DEF(void,flush_icache,(void *start, int len)):
- /* compute number of cache lines to flush */
- add r4,r4,r3
- clrrwi r3,r3,5 /* align addr to next lower cache line boundary */
- sub r4,r4,r3 /* then n_lines = (len + 0x1f) / 0x20 */
- addi r4,r4,0x1f
- srwi. r4,r4,5 /* note '.' suffix */
- beqlr /* if n_lines == 0, just return. */
- mtctr r4 /* flush cache lines */
-0: dcbf 0,r3 /* for each line... */
- sync
- icbi 0,r3
- addi r3,r3,0x20
- bdnz 0b
- sync /* finish up */
- isync
- blr
+DEF(void,flush_icache,(void*, int)):
+ /* compute number of cache lines to flush */
+ add r4,r4,r3
+ /* align addr to next lower cache line boundary */
+ clrrwi r3,r3,5
+ /* then n_lines = (len + 0x1f) / 0x20 */
+ sub r4,r4,r3
+ addi r4,r4,0x1f
+ /* note '.' suffix */
+ srwi. r4,r4,5
+ /* if n_lines == 0, just return. */
+ beqlr
+ /* flush cache lines */
+ mtctr r4
+ /* for each line... */
+0: dcbf 0,r3
+ sync
+ icbi 0,r3
+ addi r3,r3,0x20
+ bdnz 0b
+ /* finish up */
+ sync
+ isync
+ blr
DEF(void,get_ppc_fpu_env,(void*)):
- mffs f0
- stfd f0,0(r3)
- blr
+ mffs f0
+ stfd f0,0(r3)
+ blr
DEF(void,set_ppc_fpu_env,(const void*)):
- lfd f0,0(r3)
- mtfsf 0xff,f0
- blr
+ lfd f0,0(r3)
+ mtfsf 0xff,f0
+ blr
DEF(void,get_ppc_vmx_env,(void*)):
- mfvscr v0
- subi r4,r1,16
- li r5,0xf
- andc r4,r4,r5
- stvxl v0,0,r4
- li r5,0xc
- lwzx r6,r5,r4
- stw r6,0(r3)
- blr
+ mfvscr v0
+ subi r4,r1,16
+ li r5,0xf
+ andc r4,r4,r5
+ stvxl v0,0,r4
+ li r5,0xc
+ lwzx r6,r5,r4
+ stw r6,0(r3)
+ blr
DEF(void,set_ppc_vmx_env,(const void*)):
- subi r4,r1,16
- li r5,0xf
- andc r4,r4,r5
- li r5,0xc
- lwz r6,0(r3)
- stwx r6,r5,r4
- lvxl v0,0,r4
- mtvscr v0
- blr
+ subi r4,r1,16
+ li r5,0xf
+ andc r4,r4,r5
+ li r5,0xc
+ lwz r6,0(r3)
+ stwx r6,r5,r4
+ lvxl v0,0,r4
+ mtvscr v0
+ blr
B blah
the offset from the immediate operand to LOAD32 to the instruction after
- the branch is two instructions. */
-static const fixnum xt_tail_pic_offset = 4 * 2;
+ the branch is one instruction. */
+static const fixnum xt_tail_pic_offset = 4;
inline static void check_call_site(cell return_address)
{
}
/* Defined in assembly */
-VM_C_API void c_to_factor(cell quot, void *vm);
-VM_C_API void throw_impl(cell quot, void *new_stack, void *vm);
-VM_C_API void lazy_jit_compile_impl(cell quot, void *vm);
VM_C_API void flush_icache(cell start, cell len);
-VM_C_API void set_callstack(
- void *vm,
- stack_frame *to,
- stack_frame *from,
- cell length,
- void *(*memcpy)(void*,const void*, size_t));
-
}
+++ /dev/null
-#include "asm.h"
-
-#define DS_REG %esi
-#define RS_REG %edi
-#define RETURN_REG %eax
-
-#define QUOT_XT_OFFSET 12
-
-DEF(void,c_to_factor,(cell quot, void *vm)):
- /* Load parameters */
- mov 4(%esp),%eax
- mov 8(%esp),%edx
-
- /* Save non-volatile registers */
- push %ebx
- push %ebp
- push %esi
- push %edi
-
- /* Save old stack pointer and align */
- mov %esp,%ebx
- and $-16,%esp
- push %ebx
-
- /* Set up stack frame for the call to the boot quotation */
- sub $4,%esp
- push %edx
- push %eax
-
- /* Load context */
- mov (%edx),%ecx
-
- /* Load ctx->datastack */
- mov 8(%ecx),DS_REG
-
- /* Load ctx->retainstack */
- mov 12(%ecx),RS_REG
-
- /* Save ctx->callstack_bottom */
- lea -4(%esp),%ebx
- mov %ebx,4(%ecx)
-
- /* Call quot-xt */
- call *QUOT_XT_OFFSET(%eax)
-
- /* Tear down stack frame for the call to the boot quotation */
- pop %eax
- pop %edx
- add $4,%esp
-
- /* Undo stack alignment */
- mov (%esp),%esp
-
- /* Load context */
- mov (%edx),%ecx
-
- /* Save ctx->datastack */
- mov DS_REG,8(%ecx)
-
- /* Save ctx->retainstack */
- mov RS_REG,12(%ecx)
-
- /* Restore non-volatile registers */
- pop %edi
- pop %esi
- pop %ebp
- pop %ebx
-
- ret
-
-DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length, void *memcpy)):
- /* load arguments */
- mov 4(%esp),%ebx /* vm - to non-volatile register */
- mov 8(%esp),%ebp /* to */
- mov 12(%esp),%edx /* from */
- mov 16(%esp),%ecx /* length */
- mov 20(%esp),%eax /* memcpy */
-
- /* compute new stack pointer */
- sub %ecx,%ebp
- mov %ebp,%esp
-
- /* call memcpy */
- push %ecx /* pass length */
- push %edx /* pass src */
- push %ebp /* pass dst */
- call *%eax
- add $12,%esp
-
- /* load context */
- mov (%ebx),%ecx
- /* load datastack */
- mov 8(%ecx),DS_REG
- /* load retainstack */
- mov 12(%ecx),RS_REG
-
- /* return with new stack */
- ret
-
-DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)):
- /* clear x87 stack, but preserve rounding mode and exception flags */
- sub $2,%esp
- fnstcw (%esp)
- fninit
- fldcw (%esp)
- add $2,%esp
-
- /* load quotation and vm parameters */
- mov 4(%esp),%eax
- mov 12(%esp),%edx
-
- /* load new stack pointer */
- mov 8(%esp),%esp
-
- /* load context */
- mov (%edx),%ecx
- /* load datastack */
- mov 8(%ecx),DS_REG
- /* load retainstack */
- mov 12(%ecx),RS_REG
-
- /* call the error handler */
- jmp *QUOT_XT_OFFSET(%eax)
-
-DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)):
- /* load context */
- mov (%edx),%ecx
- /* save datastack */
- mov DS_REG,8(%ecx)
- /* save retainstack */
- mov RS_REG,12(%ecx)
- /* save callstack */
- lea -4(%esp),%ebp
- mov %ebp,(%ecx)
-
- /* compile quotation */
- sub $4,%esp
- push %edx
- push %eax
- call MANGLE(lazy_jit_compile)
- add $12,%esp
-
- /* call quotation */
- jmp *QUOT_XT_OFFSET(%eax)
-
-DEF(long long,read_timestamp_counter,(void)):
- rdtsc
- ret
-
-DEF(void,get_sse_env,(void*)):
- movl 4(%esp), %eax
- stmxcsr (%eax)
- ret
-
-DEF(void,set_sse_env,(const void*)):
- movl 4(%esp), %eax
- ldmxcsr (%eax)
- ret
-
-DEF(void,get_x87_env,(void*)):
- movl 4(%esp), %eax
- fnstsw (%eax)
- fnstcw 2(%eax)
- ret
-
-DEF(void,set_x87_env,(const void*)):
- movl 4(%esp), %eax
- fnclex
- fldcw 2(%eax)
- ret
-
-#include "cpu-x86.S"
-
-#ifdef WINDOWS
- .section .drectve
- .ascii " -export:read_timestamp_counter"
- .ascii " -export:get_sse_env"
- .ascii " -export:set_sse_env"
- .ascii " -export:get_x87_env"
- .ascii " -export:set_x87_env"
-#endif
+++ /dev/null
-#include "asm.h"
-
-#define DS_REG %r14
-#define RS_REG %r15
-#define RETURN_REG %rax
-
-#define QUOT_XT_OFFSET 28
-
-#ifdef WINDOWS
-
- #define ARG0 %rcx
- #define ARG1 %rdx
- #define ARG2 %r8
- #define ARG3 %r9
-
- #define PUSH_NONVOLATILE \
- push %r15 ; \
- push %r14 ; \
- push %r12 ; \
- push %r13 ; \
- push %rdi ; \
- push %rsi ; \
- push %rbx ; \
- push %rbp
-
- #define POP_NONVOLATILE \
- pop %rbp ; \
- pop %rbx ; \
- pop %rsi ; \
- pop %rdi ; \
- pop %r13 ; \
- pop %r12 ; \
- pop %r14 ; \
- pop %r15
-
-#else
-
- #define ARG0 %rdi
- #define ARG1 %rsi
- #define ARG2 %rdx
- #define ARG3 %rcx
-
- #define PUSH_NONVOLATILE \
- push %rbx ; \
- push %rbp ; \
- push %r12 ; \
- push %r13 ; \
- push %r14 ; \
- push %r15
-
- #define POP_NONVOLATILE \
- pop %r15 ; \
- pop %r14 ; \
- pop %r13 ; \
- pop %r12 ; \
- pop %rbp ; \
- pop %rbx
-
-#endif
-
-DEF(void,c_to_factor,(cell quot, void *vm)):
- PUSH_NONVOLATILE
-
- /* Save old stack pointer and align */
- mov %rsp,%rbp
- and $-16,%rsp
- push %rbp
-
- /* Set up stack frame for the call to the boot quotation */
- push ARG0
- push ARG1
-
- /* Create register shadow area (required for Win64 only) */
- sub $40,%rsp
-
- /* Load context */
- mov (ARG1),ARG2
-
- /* Save ctx->callstack_bottom */
- lea -8(%rsp),ARG3
- mov ARG3,8(ARG2)
-
- /* Load ctx->datastack */
- mov 16(ARG2),DS_REG
-
- /* Load ctx->retainstack */
- mov 24(ARG2),RS_REG
-
- /* Call quot-xt */
- call *QUOT_XT_OFFSET(ARG0)
-
- /* Tear down register shadow area */
- add $40,%rsp
-
- /* Tear down stack frame for the call to the boot quotation */
- pop ARG1
- pop ARG0
-
- /* Undo stack alignment */
- pop %rbp
- mov %rbp,%rsp
-
- /* Load context */
- mov (ARG1),ARG2
-
- /* Save ctx->datastack */
- mov DS_REG,16(ARG2)
-
- /* Save ctx->retainstack */
- mov RS_REG,24(ARG2)
-
- POP_NONVOLATILE
- ret
-
-DEF(void,set_callstack,(void *vm, stack_frame *to, stack_frame *from, cell length)):
- /* save VM pointer in non-volatile register */
- mov ARG0,%rbp
-
- /* compute new stack pointer */
- sub ARG3,ARG1
- mov ARG1,%rsp
-
- /* call memcpy */
- mov ARG1,ARG0
- mov ARG2,ARG1
- mov ARG3,ARG2
- call MANGLE(memcpy)
-
- /* load context */
- mov (%rbp),ARG2
- /* load datastack */
- mov 16(ARG2),DS_REG
- /* load retainstack */
- mov 24(ARG2),RS_REG
-
- /* return with new stack */
- ret
-
-DEF(void,throw_impl,(cell quot, void *new_stack, void *vm)):
- /* clear x87 stack, but preserve rounding mode and exception flags */
- sub $2,%rsp
- fnstcw (%rsp)
- fninit
- fldcw (%rsp)
-
- /* shuffle args */
- mov ARG1,%rsp
- mov ARG2,ARG1
-
- /* load context */
- mov (ARG1),ARG2
- /* load datastack */
- mov 16(ARG2),DS_REG
- /* load retainstack */
- mov 24(ARG2),RS_REG
-
- jmp *QUOT_XT_OFFSET(ARG0)
-
-DEF(void,lazy_jit_compile_impl,(cell quot, void *vm)):
- /* load context */
- mov (ARG1),ARG2
- /* save datastack */
- mov DS_REG,16(ARG2)
- /* save retainstack */
- mov RS_REG,24(ARG2)
- /* save callstack */
- lea -8(%rsp),%rbp
- mov %rbp,(ARG2)
-
- /* compile quotation */
- sub $8,%rsp
- call MANGLE(lazy_jit_compile)
- add $8,%rsp
-
- /* call quotation */
- jmp *QUOT_XT_OFFSET(RETURN_REG)
-
-DEF(long long,read_timestamp_counter,(void)):
- mov $0,%rax
- rdtsc
- shl $32,%rdx
- or %rdx,%rax
- ret
-
-DEF(void,get_sse_env,(void*)):
- stmxcsr (%rdi)
- ret
-
-DEF(void,set_sse_env,(const void*)):
- ldmxcsr (%rdi)
- ret
-
-DEF(void,get_x87_env,(void*)):
- fnstsw (%rdi)
- fnstcw 2(%rdi)
- ret
-
-DEF(void,set_x87_env,(const void*)):
- fnclex
- fldcw 2(%rdi)
- ret
-
-#include "cpu-x86.S"
+++ /dev/null
-/* cpu.x86.features calls this */
-DEF(bool,sse_version,(void)):
- mov $0x1,RETURN_REG
- cpuid
- test $0x100000,%ecx
- jnz sse_42
- test $0x80000,%ecx
- jnz sse_41
- test $0x200,%ecx
- jnz ssse_3
- test $0x1,%ecx
- jnz sse_3
- test $0x4000000,%edx
- jnz sse_2
- test $0x2000000,%edx
- jnz sse_1
- mov $0,%eax
- ret
-sse_42:
- mov $42,RETURN_REG
- ret
-sse_41:
- mov $41,RETURN_REG
- ret
-ssse_3:
- mov $33,RETURN_REG
- ret
-sse_3:
- mov $30,RETURN_REG
- ret
-sse_2:
- mov $20,RETURN_REG
- ret
-sse_1:
- mov $10,RETURN_REG
- ret
-
-#ifdef WINDOWS
- .section .drectve
- .ascii " -export:sse_version"
- .ascii " -export:c_to_factor"
-#endif
return r;
}
-/* Defined in assembly */
-VM_C_API void c_to_factor(cell quot, void *vm);
-VM_C_API void throw_impl(cell quot, void *new_stack, void *vm);
-VM_C_API void lazy_jit_compile_impl(cell quot, void *vm);
-
-VM_C_API void set_callstack(
- void *vm,
- stack_frame *to,
- stack_frame *from,
- cell length,
- void *(*memcpy)(void*,const void*, size_t));
-
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void factor_vm::c_to_factor(cell quot)
+{
+ /* First time this is called, wrap the c-to-factor sub-primitive inside
+ of a callback stub, which saves and restores non-volatile registers
+ as per platform ABI conventions, so that the Factor compiler can treat
+ all registers as volatile */
+ if(!c_to_factor_func)
+ {
+ tagged<word> c_to_factor_word(special_objects[C_TO_FACTOR_WORD]);
+ code_block *c_to_factor_block = callbacks->add(c_to_factor_word.value(),0);
+ c_to_factor_func = (c_to_factor_func_type)c_to_factor_block->xt();
+ }
+
+ c_to_factor_func(quot);
+}
+
+void factor_vm::unwind_native_frames(cell quot, stack_frame *to)
+{
+ tagged<word> unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]);
+ unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->xt;
+ unwind_native_frames_func(quot,to);
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+typedef void (* c_to_factor_func_type)(cell quot);
+typedef void (* unwind_native_frames_func_type)(cell quot, stack_frame *to);
+
+}
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
- if(!current_gc && to_boolean(special_objects[OBJ_BREAK]))
+ if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
else
callstack_top = ctx->callstack_top;
- throw_impl(special_objects[OBJ_BREAK],callstack_top,this);
+ unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],callstack_top);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
void factor_vm::primitive_call_clear()
{
- throw_impl(ctx->pop(),ctx->callstack_bottom,this);
+ unwind_native_frames(ctx->pop(),ctx->callstack_bottom);
}
/* For testing purposes */
}
}
-/* Do some initialization that we do once only */
-void factor_vm::do_stage1_init()
+/* Compile code in boot image so that we can execute the startup quotation */
+void factor_vm::prepare_boot_image()
{
std::cout << "*** Stage 2 early init... ";
fflush(stdout);
compile_all_words();
update_code_heap_words();
+ initialize_all_quotations();
special_objects[OBJ_STAGE2] = true_object;
std::cout << "done\n";
gc_off = false;
if(!to_boolean(special_objects[OBJ_STAGE2]))
- do_stage1_init();
+ prepare_boot_image();
}
/* May allocate memory */
case RC_ABSOLUTE_PPC_2:
return load_value_masked(rel_absolute_ppc_2_mask,16,0);
case RC_RELATIVE_PPC_2:
- return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to;
+ return load_value_masked(rel_relative_ppc_2_mask,16,0) + relative_to - sizeof(cell);
case RC_RELATIVE_PPC_3:
- return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to;
+ return load_value_masked(rel_relative_ppc_3_mask,6,0) + relative_to - sizeof(cell);
case RC_RELATIVE_ARM_3:
return load_value_masked(rel_relative_arm_3_mask,6,2) + relative_to + sizeof(cell);
case RC_INDIRECT_ARM:
store_value_masked(absolute_value,rel_absolute_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_2:
- store_value_masked(relative_value,rel_relative_ppc_2_mask,0);
+ store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_3:
- store_value_masked(relative_value,rel_relative_ppc_3_mask,0);
+ store_value_masked(relative_value + sizeof(cell),rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_value_masked(relative_value - sizeof(cell),rel_relative_arm_3_mask,2);
#include <vector>
#include <iostream>
+/* Detect target CPU type */
+#if defined(__arm__)
+ #define FACTOR_ARM
+#elif defined(__amd64__) || defined(__x86_64__)
+ #define FACTOR_AMD64
+ #define FACTOR_64
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+ #define FACTOR_X86
+#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC
+#else
+ #error "Unsupported architecture"
+#endif
+
+#ifdef WIN32
+ #define WINDOWS
+#endif
+
/* Forward-declare this since it comes up in function prototypes */
namespace factor
{
#include "alien.hpp"
#include "callbacks.hpp"
#include "dispatch.hpp"
+#include "entry_points.hpp"
#include "vm.hpp"
#include "allot.hpp"
#include "tagged.hpp"
all objects on a minor GC. */
data->mark_all_cards();
primitive_minor_gc();
-
- /* If a word's definition quotation was in old_objects and the
- quotation in new_objects is not compiled, we might leak memory
- by referencing the old quotation unless we recompile all
- unoptimized words. */
- compile_all_words();
- update_code_heap_words();
}
}
OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
OBJ_CALLCC_1, /* used to pass the value in callcc1 */
- OBJ_BREAK = 5, /* quotation called by throw primitive */
+ ERROR_HANDLER_QUOT = 5, /* quotation called when VM throws an error */
OBJ_ERROR, /* a marker consed onto kernel errors */
OBJ_CELL_SIZE = 7, /* sizeof(cell) */
JIT_EXECUTE,
JIT_DECLARE_WORD,
+ /* External entry points */
+ C_TO_FACTOR_WORD,
+ LAZY_JIT_COMPILE_WORD,
+ UNWIND_NATIVE_FRAMES_WORD,
+
/* Incremented on every modify-code-heap call; invalidates call( inline
caching */
REDEFINITION_COUNTER = 47,
void factor_vm::c_to_factor_toplevel(cell quot)
{
- c_to_factor(quot,this);
+ c_to_factor(quot);
}
void init_signals()
for(;;)
{
NS_DURING
- c_to_factor(quot,this);
+ c_to_factor(quot);
NS_VOIDRETURN;
NS_HANDLER
ctx->push(allot_alien(false_object,(cell)localException));
#define FTELL ftello
#define FSEEK fseeko
-#define FIXNUM_FORMAT "%ld"
-#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
-#ifdef FACTOR_64
- #define CELL_HEX_PAD_FORMAT "%016lx"
-#else
- #define CELL_HEX_PAD_FORMAT "%08lx"
-#endif
-
-#define FIXNUM_FORMAT "%ld"
-
#define OPEN_READ(path) fopen(path,"rb")
#define OPEN_WRITE(path) fopen(path,"wb")
return tls_vm()->exception_handler(pe);
}
-bool handler_added = 0;
-
void factor_vm::c_to_factor_toplevel(cell quot)
{
- if(!handler_added){
- if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
- handler_added = 1;
- }
- c_to_factor(quot,this);
+ if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+
+ c_to_factor(quot);
+
RemoveVectoredExceptionHandler((void *)factor::exception_handler);
}
#define STRCMP wcscmp
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
-#define MIN(a,b) ((a)>(b)?(b):(a))
#define FTELL ftello64
#define FSEEK fseeko64
#ifdef WIN64
- #define CELL_FORMAT "%Iu"
#define CELL_HEX_FORMAT "%Ix"
- #define CELL_HEX_PAD_FORMAT "%016Ix"
- #define FIXNUM_FORMAT "%Id"
#else
- #define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
- #define CELL_HEX_PAD_FORMAT "%08lx"
- #define FIXNUM_FORMAT "%ld"
#endif
#define OPEN_READ(path) _wfopen(path,L"rb")
-#if defined(__arm__)
- #define FACTOR_ARM
-#elif defined(__amd64__) || defined(__x86_64__)
- #define FACTOR_AMD64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
- #define FACTOR_X86
-#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
- #define FACTOR_PPC
-#else
- #error "Unsupported architecture"
-#endif
-
#if defined(WINDOWS)
#if defined(WINCE)
#include "os-windows-ce.hpp"
#endif
#include "os-windows.hpp"
+
#if defined(FACTOR_AMD64)
#include "os-windows-nt.64.hpp"
#elif defined(FACTOR_X86)
PRIMITIVE_FORWARD(callstack)
PRIMITIVE_FORWARD(set_datastack)
PRIMITIVE_FORWARD(set_retainstack)
-PRIMITIVE_FORWARD(set_callstack)
PRIMITIVE_FORWARD(exit)
PRIMITIVE_FORWARD(data_room)
PRIMITIVE_FORWARD(code_room)
primitive_callstack,
primitive_set_datastack,
primitive_set_retainstack,
- primitive_set_callstack,
primitive_exit,
primitive_data_room,
primitive_code_room,
/* Primitive calls */
if(primitive_call_p(i,length))
{
- /* On PowerPC, the VM pointer is stored as a register; on other
- platforms, the RT_VM relocation is used and it needs an offset
- parameter */
-#ifndef FACTOR_PPC
+ /* On x86-64 and PowerPC, the VM pointer is stored in
+ a register; on other platforms, the RT_VM relocation
+ is used and it needs an offset parameter */
+#ifdef FACTOR_X86
parameter(tag_fixnum(0));
#endif
parameter(obj.value());
void factor_vm::jit_compile_quot(cell quot_, bool relocating)
{
data_root<quotation> quot(quot_,this);
-
- if(quot->code) return;
-
- code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating);
- set_quot_xt(quot.untagged(),compiled);
+ if(!quot_compiled_p(quot.untagged()))
+ {
+ code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating);
+ set_quot_xt(quot.untagged(),compiled);
+ }
}
void factor_vm::primitive_jit_compile()
jit_compile_quot(ctx->pop(),true);
}
+code_block *factor_vm::lazy_jit_compile_block()
+{
+ return untag<word>(special_objects[LAZY_JIT_COMPILE_WORD])->code;
+}
+
/* push a new quotation on the stack */
void factor_vm::primitive_array_to_quotation()
{
quotation *quot = allot<quotation>(sizeof(quotation));
+
quot->array = ctx->peek();
quot->cached_effect = false_object;
quot->cache_counter = false_object;
- quot->xt = (void *)lazy_jit_compile_impl;
- quot->code = NULL;
+ set_quot_xt(quot,lazy_jit_compile_block());
+
ctx->replace(tag<quotation>(quot));
}
return parent->lazy_jit_compile(quot);
}
+bool factor_vm::quot_compiled_p(quotation *quot)
+{
+ return quot->code != NULL && quot->code != lazy_jit_compile_block();
+}
+
void factor_vm::primitive_quot_compiled_p()
{
tagged<quotation> quot(ctx->pop());
quot.untag_check(this);
- ctx->push(tag_boolean(quot->code != NULL));
+ ctx->push(tag_boolean(quot_compiled_p(quot.untagged())));
+}
+
+cell factor_vm::find_all_quotations()
+{
+ return instances(QUOTATION_TYPE);
+}
+
+void factor_vm::initialize_all_quotations()
+{
+ data_root<array> quotations(find_all_quotations(),this);
+
+ cell length = array_capacity(quotations.untagged());
+ for(cell i = 0; i < length; i++)
+ {
+ data_root<quotation> quot(array_nth(quotations.untagged(),i),this);
+ if(!quot->code)
+ set_quot_xt(quot.untagged(),lazy_jit_compile_block());
+ }
}
}
return cell;
}
+/* On Windows, memcpy() is in a different DLL and the non-optimizing
+compiler can't find it */
+VM_C_API void *factor_memcpy(void *dst, void *src, size_t len)
+{
+ return memcpy(dst,src,len);
+}
+
}
vm_char *safe_strdup(const vm_char *str);
cell read_cell_hex();
+VM_C_API void *factor_memcpy(void *dst, void *src, size_t len);
}
\r
factor_vm::factor_vm() :\r
nursery(0,0),\r
+ c_to_factor_func(NULL),\r
profiling_p(false),\r
gc_off(false),\r
current_gc(NULL),\r
/* Canonical truth value. In Factor, 't' */
cell true_object;
+ /* External entry points */
+ c_to_factor_func_type c_to_factor_func;
+
/* Is call counting enabled? */
bool profiling_p;
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
stack_frame *second_from_top_stack_frame();
void primitive_callstack();
- void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
//quotations
void primitive_jit_compile();
+ code_block *lazy_jit_compile_block();
void primitive_array_to_quotation();
void primitive_quotation_xt();
void set_quot_xt(quotation *quot, code_block *code);
void jit_compile_quot(cell quot_, bool relocating);
fixnum quot_code_offset_to_scan(cell quot_, cell offset);
cell lazy_jit_compile(cell quot);
+ bool quot_compiled_p(quotation *quot);
void primitive_quot_compiled_p();
+ cell find_all_quotations();
+ void initialize_all_quotations();
//dispatch
cell search_lookup_alist(cell table, cell klass);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
+ //entry points
+ void c_to_factor(cell quot);
+ void unwind_native_frames(cell quot, stack_frame *to);
+
//factor
void default_parameters(vm_parameters *p);
- bool factor_arg(const vm_char* str, const vm_char* arg, cell* value);
+ bool factor_arg(const vm_char *str, const vm_char *arg, cell *value);
void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
- void do_stage1_init();
+ void prepare_boot_image();
void init_factor(vm_parameters *p);
void pass_args_to_factor(int argc, vm_char **argv);
void start_factor(vm_parameters *p);
projects / factor.git / commitdiff