Merge branch 'master' into strong-typing

db4
Joe Groff 2009-09-01 21:18:50 -05:00
commit dc0944bad1
18 changed files with 134 additions and 96 deletions

View File

@ -109,7 +109,6 @@ IN: compiler.cfg.intrinsics
} enable-intrinsics ; } enable-intrinsics ;
: enable-float-functions ( -- ) : enable-float-functions ( -- )
! Everything except for fsqrt
{ {
{ math.libm:facos [ drop "acos" emit-unary-float-function ] } { math.libm:facos [ drop "acos" emit-unary-float-function ] }
{ math.libm:fasin [ drop "asin" emit-unary-float-function ] } { math.libm:fasin [ drop "asin" emit-unary-float-function ] }
@ -127,6 +126,9 @@ IN: compiler.cfg.intrinsics
{ math.libm:facosh [ drop "acosh" emit-unary-float-function ] } { math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
{ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
{ math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
{ math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
{ math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
{ math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
} enable-intrinsics ; } enable-intrinsics ;
: enable-min/max ( -- ) : enable-min/max ( -- )

View File

@ -281,6 +281,23 @@ M:: ppc %box-float ( dst src temp -- )
dst 16 float temp %allot dst 16 float temp %allot
src dst float-offset STFD ; src dst float-offset STFD ;
: float-function-param ( i spill-slot -- )
[ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
: float-function-return ( reg -- )
float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
func f %alien-invoke
dst float-function-return ;
M:: ppc %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param
1 src2 float-function-param
func f %alien-invoke
dst float-function-return ;
M:: ppc %unbox-any-c-ptr ( dst src temp -- ) M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[ [
{ "is-byte-array" "end" "start" } [ define-label ] each { "is-byte-array" "end" "start" } [ define-label ] each
@ -338,7 +355,8 @@ M:: ppc %box-alien ( dst src temp -- )
M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
[ [
"end" define-label "end" define-label
"ok" define-label "alloc" define-label
"simple-case" define-label
! If displacement is zero, return the base ! If displacement is zero, return the base
dst base MR dst base MR
0 displacement 0 CMPI 0 displacement 0 CMPI
@ -347,19 +365,21 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
displacement' :> temp displacement' :> temp
dst 4 cells alien temp %allot dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it ! If base is already a displaced alien, unpack it
base' base MR
displacement' displacement MR
0 base \ f tag-number CMPI 0 base \ f tag-number CMPI
"ok" get BEQ "simple-case" get BEQ
temp base header-offset LWZ temp base header-offset LWZ
0 temp alien type-number tag-fixnum CMPI 0 temp alien type-number tag-fixnum CMPI
"ok" get BNE "simple-case" get BNE
! displacement += base.displacement ! displacement += base.displacement
temp base 3 alien@ LWZ temp base 3 alien@ LWZ
displacement' displacement temp ADD displacement' displacement temp ADD
! base = base.base ! base = base.base
base' base 1 alien@ LWZ base' base 1 alien@ LWZ
"ok" resolve-label "alloc" get B
"simple-case" resolve-label
displacement' displacement MR
base' base MR
"alloc" resolve-label
! Store underlying-alien slot ! Store underlying-alien slot
base' dst 1 alien@ STW base' dst 1 alien@ STW
! Store offset ! Store offset
@ -678,6 +698,8 @@ M: ppc %unbox-small-struct ( size -- )
{ 4 [ %unbox-struct-4 ] } { 4 [ %unbox-struct-4 ] }
} case ; } case ;
enable-float-functions
USE: vocabs.loader USE: vocabs.loader
{ {

View File

@ -218,12 +218,12 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! x86-64. ! x86-64.
enable-alien-4-intrinsics enable-alien-4-intrinsics
! SSE2 is always available on x86-64.
enable-sse2
! Enable fast calling of libc math functions ! Enable fast calling of libc math functions
enable-float-functions enable-float-functions
! SSE2 is always available on x86-64.
enable-sse2
USE: vocabs.loader USE: vocabs.loader
{ {

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types kernel destructors bit-arrays USING: accessors classes.struct kernel destructors bit-arrays
sequences assocs struct-arrays math namespaces locals fry unix sequences assocs struct-arrays math namespaces locals fry unix
unix.linux.epoll unix.time io.ports io.backend.unix unix.linux.epoll unix.time io.ports io.backend.unix
io.backend.unix.multiplexers ; io.backend.unix.multiplexers ;
@ -16,14 +16,14 @@ TUPLE: epoll-mx < mx events ;
: <epoll-mx> ( -- mx ) : <epoll-mx> ( -- mx )
epoll-mx new-mx epoll-mx new-mx
max-events epoll_create dup io-error >>fd max-events epoll_create dup io-error >>fd
max-events "epoll-event" <struct-array> >>events ; max-events epoll-event <struct-array> >>events ;
M: epoll-mx dispose* fd>> close-file ; M: epoll-mx dispose* fd>> close-file ;
: make-event ( fd events -- event ) : make-event ( fd events -- event )
"epoll-event" <c-object> epoll-event <struct>
[ set-epoll-event-events ] keep swap >>events
[ set-epoll-event-fd ] keep ; swap >>fd ;
:: do-epoll-ctl ( fd mx what events -- ) :: do-epoll-ctl ( fd mx what events -- )
mx fd>> what fd fd events make-event epoll_ctl io-error ; mx fd>> what fd fd events make-event epoll_ctl io-error ;
@ -55,7 +55,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
epoll_wait multiplexer-error ; epoll_wait multiplexer-error ;
: handle-event ( event mx -- ) : handle-event ( event mx -- )
[ epoll-event-fd ] dip [ fd>> ] dip
[ EPOLLIN EPOLLOUT bitor do-epoll-del ] [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
[ input-available ] [ output-available ] 2tri ; [ input-available ] [ output-available ] 2tri ;

View File

@ -51,5 +51,5 @@ M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
M: freebsd file-systems ( -- array ) M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error f 0 0 getfsstat dup io-error
\ statfs <struct-array> \ statfs <struct-array>
[ dup length 0 getfsstat io-error ] [ dup byte-length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;

View File

@ -48,5 +48,5 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
M: netbsd file-systems ( -- array ) M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error f 0 0 getvfsstat dup io-error
\ statvfs <struct-array> \ statvfs <struct-array>
[ dup length 0 getvfsstat io-error ] [ dup byte-length 0 getvfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;

View File

@ -8,11 +8,11 @@ arrays io.files.info.unix classes.struct struct-arrays
io.encodings.utf8 ; io.encodings.utf8 ;
IN: io.files.unix.openbsd IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info TUPLE: openbsd-file-system-info < unix-file-system-info
io-size sync-writes sync-reads async-writes async-reads io-size sync-writes sync-reads async-writes async-reads
owner ; owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ; M: openbsd new-file-system-info openbsd-file-system-info new ;
M: openbsd file-system-statfs M: openbsd file-system-statfs
\ statfs <struct> [ statfs io-error ] keep ; \ statfs <struct> [ statfs io-error ] keep ;
@ -49,5 +49,5 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
M: openbsd file-systems ( -- seq ) M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error f 0 0 getfsstat dup io-error
\ statfs <struct-array> \ statfs <struct-array>
[ dup length 0 getfsstat io-error ] [ dup byte-length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; [ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;

View File

@ -7,11 +7,11 @@ $nl
"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ; "The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
HELP: <struct-array> HELP: <struct-array>
{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } } { $values { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
{ $description "Creates a new array for holding values of the specified C type." } ; { $description "Creates a new array for holding values of the specified struct type." } ;
HELP: <direct-struct-array> HELP: <direct-struct-array>
{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } } { $values { "alien" c-ptr } { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
HELP: struct-array-on HELP: struct-array-on

View File

@ -51,3 +51,5 @@ STRUCT: fixed-string { text char[100] } ;
[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ [ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
] unit-test ] unit-test
[ 10 "int" <struct-array> ] must-fail

View File

@ -5,9 +5,6 @@ classes classes.struct kernel libc math parser sequences
sequences.private words fry memoize compiler.units ; sequences.private words fry memoize compiler.units ;
IN: struct-arrays IN: struct-arrays
: c-type-struct-class ( c-type -- class )
c-type boxed-class>> ; foldable
TUPLE: struct-array TUPLE: struct-array
{ underlying c-ptr read-only } { underlying c-ptr read-only }
{ length array-capacity read-only } { length array-capacity read-only }
@ -15,35 +12,39 @@ TUPLE: struct-array
{ class read-only } { class read-only }
{ ctor read-only } ; { ctor read-only } ;
M: struct-array length length>> ; inline <PRIVATE
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
: (nth-ptr) ( i struct-array -- alien ) : (nth-ptr) ( i struct-array -- alien )
[ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
: (struct-element-constructor) ( struct-class -- word )
[
"struct-array-ctor" f <word>
[ swap '[ _ memory>struct ] (( alien -- object )) define-inline ] keep
] with-compilation-unit ;
! Foldable memo word. This is an optimization; by precompiling a
! constructor for array elements, we avoid memory>struct's slow path.
MEMO: struct-element-constructor ( struct-class -- word )
(struct-element-constructor) ; foldable
PRIVATE>
M: struct-array length length>> ; inline
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
M: struct-array nth-unsafe M: struct-array nth-unsafe
[ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
M: struct-array set-nth-unsafe M: struct-array set-nth-unsafe
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
: (struct-element-constructor) ( c-type -- word ) ERROR: not-a-struct-class struct-class ;
[
"struct-array-ctor" f <word>
[
swap dup struct-class?
[ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
(( alien -- object )) define-inline
] keep
] with-compilation-unit ;
! Foldable memo word. This is an optimization; by precompiling a : <direct-struct-array> ( alien length struct-class -- struct-array )
! constructor for array elements, we avoid memory>struct's slow path. dup struct-class? [ not-a-struct-class ] unless
MEMO: struct-element-constructor ( c-type -- word ) [ heap-size ] [ ] [ struct-element-constructor ]
(struct-element-constructor) ; foldable
: <direct-struct-array> ( alien length c-type -- struct-array )
[ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
tri struct-array boa ; inline tri struct-array boa ; inline
M: struct-array new-sequence M: struct-array new-sequence
@ -54,7 +55,7 @@ M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
<direct-struct-array> ; inline <direct-struct-array> ; inline
: <struct-array> ( length c-type -- struct-array ) : <struct-array> ( length struct-class -- struct-array )
[ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
ERROR: bad-byte-array-length byte-array ; ERROR: bad-byte-array-length byte-array ;

View File

@ -1,11 +1,11 @@
IN: struct-vectors IN: struct-vectors
USING: help.markup help.syntax alien strings math ; USING: help.markup help.syntax classes.struct alien strings math ;
HELP: struct-vector HELP: struct-vector
{ $class-description "The class of growable C struct and union arrays." } ; { $class-description "The class of growable C struct and union arrays." } ;
HELP: <struct-vector> HELP: <struct-vector>
{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } } { $values { "capacity" integer } { "struct-class" struct-class } { "struct-vector" struct-vector } }
{ $description "Creates a new vector with the given initial capacity." } ; { $description "Creates a new vector with the given initial capacity." } ;
ARTICLE: "struct-vectors" "C struct and union vectors" ARTICLE: "struct-vectors" "C struct and union vectors"

View File

@ -1,21 +1,16 @@
IN: struct-vectors.tests IN: struct-vectors.tests
USING: struct-vectors tools.test alien.c-types alien.syntax USING: struct-vectors tools.test alien.c-types classes.struct accessors
namespaces kernel sequences ; namespaces kernel sequences ;
C-STRUCT: point STRUCT: point { x float } { y float } ;
{ "float" "x" }
{ "float" "y" } ;
: make-point ( x y -- point ) : make-point ( x y -- point ) point <struct-boa> ;
"point" <c-object>
[ set-point-y ] keep
[ set-point-x ] keep ;
[ ] [ 1 "point" <struct-vector> "v" set ] unit-test [ ] [ 1 point <struct-vector> "v" set ] unit-test
[ 1.5 6.0 ] [ [ 1.5 6.0 ] [
1.0 2.0 make-point "v" get push 1.0 2.0 make-point "v" get push
3.0 4.5 make-point "v" get push 3.0 4.5 make-point "v" get push
1.5 6.0 make-point "v" get push 1.5 6.0 make-point "v" get push
"v" get pop [ point-x ] [ point-y ] bi "v" get pop [ x>> ] [ y>> ] bi
] unit-test ] unit-test

View File

@ -9,10 +9,11 @@ TUPLE: struct-vector
{ length array-capacity } { length array-capacity }
{ c-type read-only } ; { c-type read-only } ;
: <struct-vector> ( capacity c-type -- struct-vector ) : <struct-vector> ( capacity struct-class -- struct-vector )
[ <struct-array> 0 ] keep struct-vector boa ; inline [ <struct-array> 0 ] keep struct-vector boa ; inline
M: struct-vector byte-length underlying>> byte-length ; M: struct-vector byte-length underlying>> byte-length ;
M: struct-vector new-sequence M: struct-vector new-sequence
[ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
struct-vector boa ; struct-vector boa ;

View File

@ -1,16 +1,16 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll IN: unix.linux.epoll
USING: alien.syntax math ; USING: alien.syntax classes.struct math ;
FUNCTION: int epoll_create ( int size ) ; FUNCTION: int epoll_create ( int size ) ;
FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
C-STRUCT: epoll-event STRUCT: epoll-event
{ "uint" "events" } { events uint }
{ "uint" "fd" } { fd uint }
{ "uint" "padding" } ; { padding uint } ;
FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;

View File

@ -4,7 +4,7 @@ namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets destructors fry math.parser generalizations sets
specialized-arrays.alien specialized-arrays.direct.alien specialized-arrays.alien specialized-arrays.direct.alien
windows.kernel32 ; windows.kernel32 classes.struct ;
IN: windows.com.wrapper IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ; TUPLE: com-wrapper < disposable callbacks vtbls ;

View File

@ -25,13 +25,18 @@ unit-test
[ "e" string>number ] [ "e" string>number ]
unit-test unit-test
[ 100000 ] [ 100000 ] [ "100,000" string>number ] unit-test
[ "100,000" string>number ]
unit-test
[ 100000.0 ] [ 100000.0 ] [ "100,000.0" string>number ] unit-test
[ "100,000.0" string>number ]
unit-test [ f ] [ "," string>number ] unit-test
[ f ] [ "-," string>number ] unit-test
[ f ] [ "1," string>number ] unit-test
[ f ] [ "-1," string>number ] unit-test
[ f ] [ ",2" string>number ] unit-test
[ f ] [ "-,2" string>number ] unit-test
[ 2.0 ] [ "2." string>number ] unit-test
[ "100.0" ] [ "100.0" ]
[ "1.0e2" string>number number>string ] [ "1.0e2" string>number number>string ]

View File

@ -86,16 +86,27 @@ SYMBOL: negative?
[ CHAR: , eq? not ] filter [ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ; >byte-array 0 suffix (string>float) ;
: number-char? ( char -- ? )
"0123456789." member? ;
: numeric-looking? ( str -- ? )
"-" ?head drop
dup empty? [ drop f ] [
dup first number-char? [
last number-char?
] [ drop f ] if
] if ;
PRIVATE> PRIVATE>
: base> ( str radix -- n/f ) : base> ( str radix -- n/f )
over empty? [ 2drop f ] [ over numeric-looking? [
over [ "/." member? ] find nip { over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] } { CHAR: / [ string>ratio ] }
{ CHAR: . [ drop string>float ] } { CHAR: . [ drop string>float ] }
[ drop string>integer ] [ drop string>integer ]
} case } case
] if ; ] [ 2drop f ] if ;
: string>number ( str -- n/f ) 10 base> ; : string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ; : bin> ( str -- n/f ) 2 base> ;

View File

@ -1,9 +1,8 @@
USING: accessors arrays byte-arrays combinators USING: accessors arrays byte-arrays combinators
combinators.short-circuit fry hints images kernel locals math combinators.short-circuit fry hints images kernel locals math
math.affine-transforms math.functions math.order math.affine-transforms math.functions math.order math.polynomials
math.polynomials math.private math.vectors random math.vectors random random.mersenne-twister sequences
random.mersenne-twister sequences sequences.private sequences.private sequences.product ;
sequences.product ;
IN: noise IN: noise
: <perlin-noise-table> ( -- table ) : <perlin-noise-table> ( -- table )
@ -35,25 +34,25 @@ HINTS: (fade) { float float float } ;
HINTS: grad { fixnum float float float } ; HINTS: grad { fixnum float float float } ;
: unit-cube ( point -- cube ) : unit-cube ( point -- cube )
[ floor >fixnum 256 rem ] map ; [ floor 256 rem ] map ;
:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb ) :: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
x table nth-unsafe y fixnum+fast :> a x table nth-unsafe y + :> a
x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b x 1 + table nth-unsafe y + :> b
a table nth-unsafe z fixnum+fast :> aa a table nth-unsafe z + :> aa
b table nth-unsafe z fixnum+fast :> ba b table nth-unsafe z + :> ba
a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab a 1 + table nth-unsafe z + :> ab
b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb b 1 + table nth-unsafe z + :> bb
aa table nth-unsafe aa table nth-unsafe
ba table nth-unsafe ba table nth-unsafe
ab table nth-unsafe ab table nth-unsafe
bb table nth-unsafe bb table nth-unsafe
aa 1 fixnum+fast table nth-unsafe aa 1 + table nth-unsafe
ba 1 fixnum+fast table nth-unsafe ba 1 + table nth-unsafe
ab 1 fixnum+fast table nth-unsafe ab 1 + table nth-unsafe
bb 1 fixnum+fast table nth-unsafe ; inline bb 1 + table nth-unsafe ; inline
HINTS: hashes { byte-array fixnum fixnum fixnum } ; HINTS: hashes { byte-array fixnum fixnum fixnum } ;