From 6f1a7c731cfadc3965fd0a7c6a293390e933895d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 30 Aug 2009 20:56:04 -0500 Subject: [PATCH 1/7] cpu.ppc: fix %box-displaced-alien --- basis/cpu/ppc/ppc.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 33619ca3e3..b4f6c49183 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -338,7 +338,8 @@ M:: ppc %box-alien ( dst src temp -- ) M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) [ "end" define-label - "ok" define-label + "alloc" define-label + "simple-case" define-label ! If displacement is zero, return the base dst base MR 0 displacement 0 CMPI @@ -347,19 +348,21 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- ) displacement' :> temp dst 4 cells alien temp %allot ! If base is already a displaced alien, unpack it - base' base MR - displacement' displacement MR 0 base \ f tag-number CMPI - "ok" get BEQ + "simple-case" get BEQ temp base header-offset LWZ 0 temp alien type-number tag-fixnum CMPI - "ok" get BNE + "simple-case" get BNE ! displacement += base.displacement temp base 3 alien@ LWZ displacement' displacement temp ADD ! base = base.base 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 base' dst 1 alien@ STW ! Store offset From 522f426ba7a8103520bbc0ddb350c18ac16ccb79 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Sep 2009 13:04:00 -0500 Subject: [PATCH 2/7] fix help lint failures --- basis/alien/c-types/c-types-docs.factor | 2 +- basis/struct-arrays/struct-arrays-docs.factor | 2 +- extra/gpu/shaders/shaders-docs.factor | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index b6b28d0a95..ac9a959d4c 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -49,7 +49,7 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: -{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } +{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 7b49d6ef42..3e7582f8cd 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -15,7 +15,7 @@ HELP: { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; HELP: struct-array-on -{ $value { "struct" struct } { "length" integer } } +{ $values { "struct" struct } { "length" integer } { "struct-array" struct-array } } { $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." } { $examples "This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:" diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 8ccc65da43..3ffe8e96bb 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license USING: classes classes.struct gpu.buffers help.markup help.syntax -images kernel math multiline quotations sequences strings ; +images kernel math multiline quotations sequences strings words ; IN: gpu.shaders HELP: @@ -86,7 +86,7 @@ HELP: define-vertex-format HELP: define-vertex-struct { $values - { "struct-name" string } { "vertex-format" vertex-format } + { "class" word } { "vertex-format" vertex-format } } { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ; From 20376674735156104e2d3853c05cd949b0fe209e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:46:08 -0500 Subject: [PATCH 3/7] io.backend.unix.multiplexers.epoll: update for STRUCT: --- .../backend/unix/multiplexers/epoll/epoll.factor | 14 +++++++------- basis/unix/linux/epoll/epoll.factor | 10 +++++----- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index 98c48c113d..11fa5620f2 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! 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 unix.linux.epoll unix.time io.ports io.backend.unix io.backend.unix.multiplexers ; @@ -16,14 +16,14 @@ TUPLE: epoll-mx < mx events ; : ( -- mx ) epoll-mx new-mx max-events epoll_create dup io-error >>fd - max-events "epoll-event" >>events ; + max-events epoll-event >>events ; M: epoll-mx dispose* fd>> close-file ; : make-event ( fd events -- event ) - "epoll-event" - [ set-epoll-event-events ] keep - [ set-epoll-event-fd ] keep ; + epoll-event + swap >>events + swap >>fd ; :: do-epoll-ctl ( fd mx what events -- ) 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 ; : handle-event ( event mx -- ) - [ epoll-event-fd ] dip + [ fd>> ] dip [ EPOLLIN EPOLLOUT bitor do-epoll-del ] [ input-available ] [ output-available ] 2tri ; diff --git a/basis/unix/linux/epoll/epoll.factor b/basis/unix/linux/epoll/epoll.factor index 7c68dfa45a..966db32f60 100644 --- a/basis/unix/linux/epoll/epoll.factor +++ b/basis/unix/linux/epoll/epoll.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix.linux.epoll -USING: alien.syntax math ; +USING: alien.syntax classes.struct math ; FUNCTION: int epoll_create ( int size ) ; FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; -C-STRUCT: epoll-event - { "uint" "events" } - { "uint" "fd" } - { "uint" "padding" } ; +STRUCT: epoll-event +{ events uint } +{ fd uint } +{ padding uint } ; FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; From 7bdd819d512ba024008aef9290b941a373baa14b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:46:24 -0500 Subject: [PATCH 4/7] struct-arrays: remove support for arrays of old-style structs --- basis/struct-arrays/struct-arrays-docs.factor | 6 +-- basis/struct-arrays/struct-arrays.factor | 42 +++++++++---------- 2 files changed, 23 insertions(+), 25 deletions(-) diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 7b49d6ef42..175b2e2783 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -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." } ; HELP: -{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } } -{ $description "Creates a new array for holding values of the specified C type." } ; +{ $values { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } } +{ $description "Creates a new array for holding values of the specified struct type." } ; HELP: -{ $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" } "." } ; HELP: struct-array-on diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index cc34072d2c..3adc4496ee 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -5,9 +5,6 @@ classes classes.struct kernel libc math parser sequences sequences.private words fry memoize compiler.units ; IN: struct-arrays -: c-type-struct-class ( c-type -- class ) - c-type boxed-class>> ; foldable - TUPLE: struct-array { underlying c-ptr read-only } { length array-capacity read-only } @@ -15,35 +12,36 @@ TUPLE: struct-array { class read-only } { ctor read-only } ; -M: struct-array length length>> ; inline -M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline +> * >fixnum ] [ underlying>> ] bi ; inline +: (struct-element-constructor) ( struct-class -- word ) + [ + "struct-array-ctor" f + [ 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 [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline -: (struct-element-constructor) ( c-type -- word ) - [ - "struct-array-ctor" f - [ - 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 -! constructor for array elements, we avoid memory>struct's slow path. -MEMO: struct-element-constructor ( c-type -- word ) - (struct-element-constructor) ; foldable - -: ( alien length c-type -- struct-array ) - [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ] +: ( alien length struct-class -- struct-array ) + [ heap-size ] [ ] [ struct-element-constructor ] tri struct-array boa ; inline M: struct-array new-sequence From 1efcf36083b5737502383a4f925442049c5c4255 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:47:04 -0500 Subject: [PATCH 5/7] struct-vectors: update unit test to use new structs --- basis/struct-vectors/struct-vectors-docs.factor | 4 ++-- basis/struct-vectors/struct-vectors-tests.factor | 15 +++++---------- basis/struct-vectors/struct-vectors.factor | 3 ++- 3 files changed, 9 insertions(+), 13 deletions(-) diff --git a/basis/struct-vectors/struct-vectors-docs.factor b/basis/struct-vectors/struct-vectors-docs.factor index 368b054565..fe1b8991cf 100644 --- a/basis/struct-vectors/struct-vectors-docs.factor +++ b/basis/struct-vectors/struct-vectors-docs.factor @@ -1,11 +1,11 @@ IN: struct-vectors -USING: help.markup help.syntax alien strings math ; +USING: help.markup help.syntax classes.struct alien strings math ; HELP: struct-vector { $class-description "The class of growable C struct and union arrays." } ; HELP: -{ $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." } ; ARTICLE: "struct-vectors" "C struct and union vectors" diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor index f57c64152c..dec2e96040 100644 --- a/basis/struct-vectors/struct-vectors-tests.factor +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -1,21 +1,16 @@ 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 ; -C-STRUCT: point - { "float" "x" } - { "float" "y" } ; +STRUCT: point { x float } { y float } ; -: make-point ( x y -- point ) - "point" - [ set-point-y ] keep - [ set-point-x ] keep ; +: make-point ( x y -- point ) point ; -[ ] [ 1 "point" "v" set ] unit-test +[ ] [ 1 point "v" set ] unit-test [ 1.5 6.0 ] [ 1.0 2.0 make-point "v" get push 3.0 4.5 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 \ No newline at end of file diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor index 5a0654ea16..d4aa03c7ed 100644 --- a/basis/struct-vectors/struct-vectors.factor +++ b/basis/struct-vectors/struct-vectors.factor @@ -9,10 +9,11 @@ TUPLE: struct-vector { length array-capacity } { c-type read-only } ; -: ( capacity c-type -- struct-vector ) +: ( capacity struct-class -- struct-vector ) [ 0 ] keep struct-vector boa ; inline M: struct-vector byte-length underlying>> byte-length ; + M: struct-vector new-sequence [ c-type>> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi struct-vector boa ; From b8aa894960e8fc8420b1ea432b0b75b8f71c8433 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 14:58:49 -0500 Subject: [PATCH 6/7] struct-arrays: fix help lint, throw error if class parameter is not a struct class --- basis/struct-arrays/struct-arrays-tests.factor | 2 ++ basis/struct-arrays/struct-arrays.factor | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index a57bb0259c..0a79f47a34 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -51,3 +51,5 @@ STRUCT: fixed-string { text char[100] } ; [ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ ALIEN: 123 4 fixed-string [ (underlying)>> ] { } map-as ] unit-test + +[ 10 "int" ] must-fail \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 3adc4496ee..15f996f3bf 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -40,7 +40,10 @@ M: struct-array nth-unsafe M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline +ERROR: not-a-struct-class struct-class ; + : ( alien length struct-class -- struct-array ) + dup struct-class? [ not-a-struct-class ] unless [ heap-size ] [ ] [ struct-element-constructor ] tri struct-array boa ; inline @@ -52,7 +55,7 @@ M: struct-array resize ( n seq -- newseq ) [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi ; inline -: ( length c-type -- struct-array ) +: ( length struct-class -- struct-array ) [ heap-size * ] 2keep ; inline ERROR: bad-byte-array-length byte-array ; From f91b539c318643d9c98301e655cfe1bbd3d0e161 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 1 Sep 2009 15:19:26 -0500 Subject: [PATCH 7/7] cpu.ppc: implement fast float function calls; 3x speedup on benchmark.struct-arrays on PowerPC --- .../compiler/cfg/intrinsics/intrinsics.factor | 4 +++- basis/cpu/ppc/ppc.factor | 19 +++++++++++++++++++ basis/cpu/x86/64/64.factor | 6 +++--- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 9766c658c9..920def14c1 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -109,7 +109,6 @@ IN: compiler.cfg.intrinsics } enable-intrinsics ; : enable-float-functions ( -- ) - ! Everything except for fsqrt { { math.libm:facos [ drop "acos" 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:fasinh [ drop "asinh" 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-min/max ( -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index b4f6c49183..20d1adcd6f 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -281,6 +281,23 @@ M:: ppc %box-float ( dst src temp -- ) dst 16 float temp %allot 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 -- ) [ { "is-byte-array" "end" "start" } [ define-label ] each @@ -681,6 +698,8 @@ M: ppc %unbox-small-struct ( size -- ) { 4 [ %unbox-struct-4 ] } } case ; +enable-float-functions + USE: vocabs.loader { diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 98a8b3bc24..a7a4e783c3 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -218,12 +218,12 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) ! x86-64. enable-alien-4-intrinsics -! SSE2 is always available on x86-64. -enable-sse2 - ! Enable fast calling of libc math functions enable-float-functions +! SSE2 is always available on x86-64. +enable-sse2 + USE: vocabs.loader {